1 files changed, 28 insertions, 22 deletions
diff --git a/guix-build-coordinator/utils/fibers.scm b/guix-build-coordinator/utils/fibers.scm
index a39b3bb..2dfb087 100644
--- a/guix-build-coordinator/utils/fibers.scm
+++ b/guix-build-coordinator/utils/fibers.scm
@@ -15,7 +15,8 @@
   (make-parameter #f))
 
 (define* (make-worker-thread-channel initializer
-                                     #:key (parallelism 1))
+                                     #:key (parallelism 1)
+                                     (delay-logger (lambda _ #f)))
   "Return a channel used to offload work to a dedicated thread.  ARGS are the
 arguments of the worker thread procedure."
   (parameterize (((@@ (fibers internal) current-fiber) #f))
@@ -28,26 +29,31 @@ arguments of the worker thread procedure."
               (parameterize ((%worker-thread-args args))
                 (let loop ()
                   (match (get-message channel)
-                    (((? channel? reply) . (? procedure? proc))
-                     (put-message
-                      reply
-                      (with-exception-handler
-                          (lambda (exn)
-                            (cons 'worker-thread-error exn))
-                        (lambda ()
-                          (with-exception-handler
-                              (lambda (exn)
-                                (simple-format
-                                 (current-error-port)
-                                 "worker-thread: exception: ~A\n" exn)
-                                (backtrace)
-                                (raise-exception exn))
-                            (lambda ()
-                              (call-with-values
-                                  (lambda ()
-                                    (apply proc args))
-                                (lambda vals vals)))))
-                        #:unwind? #t))))
+                    (((? channel? reply) sent-time (? procedure? proc))
+                     (let ((time-delay
+                            (- (get-internal-real-time)
+                               sent-time)))
+                       (delay-logger (/ time-delay
+                                        internal-time-units-per-second))
+                       (put-message
+                        reply
+                        (with-exception-handler
+                            (lambda (exn)
+                              (cons 'worker-thread-error exn))
+                          (lambda ()
+                            (with-exception-handler
+                                (lambda (exn)
+                                  (simple-format
+                                   (current-error-port)
+                                   "worker-thread: exception: ~A\n" exn)
+                                  (backtrace)
+                                  (raise-exception exn))
+                              (lambda ()
+                                (call-with-values
+                                    (lambda ()
+                                      (apply proc args))
+                                  (lambda vals vals)))))
+                          #:unwind? #t)))))
                   (loop)))))))
        (iota parallelism))
       channel)))
@@ -59,7 +65,7 @@ If already in the worker thread, call PROC immediately."
     (if args
         (apply proc args)
         (let ((reply (make-channel)))
-          (put-message channel (cons reply proc))
+          (put-message channel (list reply (get-internal-real-time) proc))
           (match (get-message reply)
             (('worker-thread-error . exn)
              (raise-exception exn))