Track worker thread task durations

So this can be logged.

1 files changed, 32 insertions, 19 deletions

diff --git a/guix-build-coordinator/utils/fibers.scm b/guix-build-coordinator/utils/fibers.scm
index f260682..47ae072 100644
--- a/guix-build-coordinator/utils/fibers.scm
+++ b/guix-build-coordinator/utils/fibers.scm
@@ -39,22 +39,31 @@ arguments of the worker thread procedure."
                                         internal-time-units-per-second))
                        (put-message
                         reply
-                        (with-exception-handler
-                            (lambda (exn)
-                              (cons 'worker-thread-error exn))
-                          (lambda ()
-                            (with-throw-handler #t
-                              (lambda ()
-                                (call-with-values
-                                    (lambda ()
-                                      (apply proc args))
-                                  (lambda vals vals)))
-                              (lambda (key . args)
-                                (simple-format
-                                 (current-error-port)
-                                 "worker-thread: exception: ~A ~A\n" key args)
-                                (backtrace))))
-                          #:unwind? #t)))))
+                        (let ((start-time (get-internal-real-time)))
+                          (with-exception-handler
+                              (lambda (exn)
+                                (list 'worker-thread-error
+                                      (/ (- (get-internal-real-time)
+                                            start-time)
+                                         internal-time-units-per-second)
+                                      exn))
+                            (lambda ()
+                              (with-throw-handler #t
+                                (lambda ()
+                                  (call-with-values
+                                      (lambda ()
+                                        (apply proc args))
+                                    (lambda vals
+                                      (cons (/ (- (get-internal-real-time)
+                                                  start-time)
+                                               internal-time-units-per-second)
+                                            vals))))
+                                (lambda (key . args)
+                                  (simple-format
+                                   (current-error-port)
+                                   "worker-thread: exception: ~A ~A\n" key args)
+                                  (backtrace))))
+                            #:unwind? #t))))))
                   (if (number? current-lifetime)
                       (unless (< current-lifetime 0)
                         (loop (if current-lifetime
@@ -67,7 +76,7 @@ arguments of the worker thread procedure."
        (iota parallelism))
       channel)))
 
-(define (call-with-worker-thread channel proc)
+(define* (call-with-worker-thread channel proc #:key duration-logger)
   "Send PROC to the worker thread through CHANNEL.  Return the result of PROC.
 If already in the worker thread, call PROC immediately."
   (let ((args (%worker-thread-args)))
@@ -76,9 +85,13 @@ If already in the worker thread, call PROC immediately."
         (let ((reply (make-channel)))
           (put-message channel (list reply (get-internal-real-time) proc))
           (match (get-message reply)
-            (('worker-thread-error . exn)
+            (('worker-thread-error duration exn)
+             (when duration-logger
+               (duration-logger duration))
              (raise-exception exn))
-            (result
+            ((duration . result)
+             (when duration-logger
+               (duration-logger duration))
              (apply values result)))))))
 
 ;; Copied from (fibers web server)