From 9c155031960d5d9a0c8fddf97bf37c88146eedce Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Mon, 10 Apr 2023 10:06:24 +0100
Subject: Add priority support to create-work-queue

This isn't ideal as the process-job interface changes when you enable
prioritisation, but that's not a big issue.

This should enable prioritising post build operations.
---
 guix-build-coordinator/utils.scm | 43 +++++++++++++++++++++++++++++-----------
 1 file changed, 31 insertions(+), 12 deletions(-)

diff --git a/guix-build-coordinator/utils.scm b/guix-build-coordinator/utils.scm
index 005ebc8..0aaba2e 100644
--- a/guix-build-coordinator/utils.scm
+++ b/guix-build-coordinator/utils.scm
@@ -968,7 +968,8 @@ References: ~a~%"
                             #:key thread-start-delay
                             (thread-stop-delay
                              (make-time time-duration 0 0))
-                            (name "unnamed"))
+                            (name "unnamed")
+                            priority<?)
   (let ((queue (make-q))
         (queue-mutex (make-mutex))
         (job-available (make-condition-variable))
@@ -988,11 +989,24 @@ References: ~a~%"
        (else
         thread-count-parameter)))
 
-    (define (process-job . args)
-      (with-mutex queue-mutex
-        (enq! queue args)
-        (start-new-threads-if-necessary (get-thread-count))
-        (signal-condition-variable job-available)))
+    (define process-job
+      (if priority<?
+          (lambda* (args #:key priority)
+            (with-mutex queue-mutex
+              (enq! queue (cons priority args))
+              (stable-sort! (car queue)
+                            (lambda (a b)
+                              (priority<?
+                               (car a)
+                               (car b))))
+              (sync-q! queue)
+              (start-new-threads-if-necessary (get-thread-count))
+              (signal-condition-variable job-available)))
+          (lambda args
+            (with-mutex queue-mutex
+              (enq! queue args)
+              (start-new-threads-if-necessary (get-thread-count))
+              (signal-condition-variable job-available)))))
 
     (define (count-threads)
       (with-mutex queue-mutex
@@ -1007,11 +1021,12 @@ References: ~a~%"
 
     (define (list-jobs)
       (with-mutex queue-mutex
-        (append (list-copy
-                 (car queue))
+        (append (if priority<?
+                    (map cdr (car queue))
+                    (list-copy (car queue)))
                 (hash-fold (lambda (key val result)
-                             (or (and val
-                                      (cons val result))
+                             (if val
+                                 (cons val result)
                                  result))
                            '()
                            running-job-args))))
@@ -1080,9 +1095,13 @@ References: ~a~%"
                               ;; the job in the mean time
                               (if (q-empty? queue)
                                   #f
-                                  (deq! queue))
+                                  (if priority<?
+                                      (cdr (deq! queue))
+                                      (deq! queue)))
                               #f)
-                          (deq! queue))))
+                          (if priority<?
+                              (cdr (deq! queue))
+                              (deq! queue)))))
 
                  (if job-args
                      (begin
-- 
cgit v1.2.3