Support expiring worker threads on exception

1 files changed, 55 insertions, 45 deletions

diff --git a/guix-build-coordinator/utils/fibers.scm b/guix-build-coordinator/utils/fibers.scm
index 4663adc..99ca27f 100644
--- a/guix-build-coordinator/utils/fibers.scm
+++ b/guix-build-coordinator/utils/fibers.scm
@@ -22,7 +22,8 @@
                                      (delay-logger (lambda _ #f))
                                      destructor
                                      lifetime
-                                     (log-exception? (const #t)))
+                                     (log-exception? (const #t))
+                                     (expire-on-exception? #f))
   "Return a channel used to offload work to a dedicated thread.  ARGS are the
 arguments of the worker thread procedure."
   (let ((channel (make-channel)))
@@ -33,50 +34,59 @@ arguments of the worker thread procedure."
           (let init ((args (initializer)))
             (parameterize ((%worker-thread-args args))
               (let loop ((current-lifetime lifetime))
-                (match (get-message channel)
-                  (((? 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
-                      (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 args
-                                (when (match args
-                                        (('%exception exn)
-                                         (log-exception? exn))
-                                        (_ #t))
-                                  (simple-format
-                                   (current-error-port)
-                                   "worker-thread: exception: ~A\n" args)
-                                  (backtrace)))))
-                          #:unwind? #t))))))
-                (if (number? current-lifetime)
-                    (unless (< current-lifetime 0)
-                      (loop (if current-lifetime
-                                (- current-lifetime 1)
-                                #f)))
-                    (loop #f))))
+                (let ((exception?
+                       (match (get-message channel)
+                         (((? channel? reply) sent-time (? procedure? proc))
+                          (let ((time-delay
+                                 (- (get-internal-real-time)
+                                    sent-time)))
+                            (delay-logger (/ time-delay
+                                             internal-time-units-per-second))
+
+                            (let* ((start-time (get-internal-real-time))
+                                   (response
+                                    (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 args
+                                            (when (match args
+                                                    (('%exception exn)
+                                                     (log-exception? exn))
+                                                    (_ #t))
+                                              (simple-format
+                                               (current-error-port)
+                                               "worker-thread: exception: ~A\n" args)
+                                              (backtrace)))))
+                                      #:unwind? #t)))
+                              (put-message reply
+                                           response)
+
+                              (match response
+                                (('worker-thread-error rest ...) #t)
+                                (_ #f))))))))
+                  (unless (and expire-on-exception?
+                               exception?)
+                    (if (number? current-lifetime)
+                        (unless (< current-lifetime 0)
+                          (loop (if current-lifetime
+                                    (- current-lifetime 1)
+                                    #f)))
+                        (loop #f))))))
             (when destructor
               (apply destructor args))
             (init (initializer))))))