[no subject]

[Ludovic Courtès]

branch: master
commit 8c6fe0be32664b74b34302bab1a3dea673ebee6d
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Thu Sep 21 23:55:36 2023 +0200

    remote-server: Pop builds for any worker-supported system.
    
    Previously, for workers supporting multiple systems, this would pick a
    system at random and return #f, even if pending builds are available for
    one of the other systems supported by the worker.  Thus, it would
    practically divide throughput by N for a worker supporting N systems.
    
    * src/cuirass/scripts/remote-server.scm (random-seed, shuffle): New
    procedures.
    (pop-build): Change to return a build for *any* of the systems supported
    by WORKER.
---
 src/cuirass/scripts/remote-server.scm | 26 ++++++++++++++++++++------
 1 file changed, 20 insertions(+), 6 deletions(-)

diff --git a/src/cuirass/scripts/remote-server.scm 
b/src/cuirass/scripts/remote-server.scm
index bbe19f1..e3a683d 100644
--- a/src/cuirass/scripts/remote-server.scm
+++ b/src/cuirass/scripts/remote-server.scm
@@ -221,15 +221,29 @@ and store the result inside the BOX."
 ;;; Build workers.
 ;;;
 
-(define (pop-build name)
-  (define (random-system systems)
-    (list-ref systems (random (length systems))))
+(define (random-seed)
+  (logxor (getpid) (car (gettimeofday))))
+
+(define shuffle                            ;copied from (guix scripts offload)
+  (let ((state (seed->random-state (random-seed))))
+    (lambda (lst)
+      "Return LST shuffled (using the Fisher-Yates algorithm.)"
+      (define vec (list->vector lst))
+      (let loop ((result '())
+                 (i (vector-length vec)))
+        (if (zero? i)
+            result
+            (let* ((j (random i state))
+                   (val (vector-ref vec j)))
+              (vector-set! vec j (vector-ref vec (- i 1)))
+              (loop (cons val result) (- i 1))))))))
 
+(define (pop-build name)
+  "Return a pending build that worker NAME can perform."
   (let ((worker (db-get-worker name)))
     (and worker
-         (let ((system (random-system
-                        (worker-systems worker))))
-           (db-get-pending-build system)))))
+         (any db-get-pending-build
+              (shuffle (worker-systems worker))))))
 
 (define* (read-worker-exp sexp #:key peer-address reply-worker)
   "Read the given SEXP sent by a worker.  REPLY-WORKER is a procedure that can