Improve the call-with-delay-logging procedure

Support arguments to the passed procedure, and report more of the things
involved in the monitored time period.

1 files changed, 25 insertions, 23 deletions

diff --git a/guix-build-coordinator/utils.scm b/guix-build-coordinator/utils.scm
index 96af7ba..a823621 100644
--- a/guix-build-coordinator/utils.scm
+++ b/guix-build-coordinator/utils.scm
@@ -675,7 +675,7 @@ References: ~a~%"
          (lambda (recorder)
            (recorder proc duration))))
 
-(define* (call-with-delay-logging thunk #:key (threshold 1))
+(define* (call-with-delay-logging proc #:key (threshold 1) (args '()))
   (let ((start (get-internal-real-time))
         (trace '())
         (root-logger? (eq? #f (fluid-ref delay-logging-fluid))))
@@ -697,33 +697,35 @@ References: ~a~%"
                                         (fluid-ref delay-logging-depth-fluid))
                                   trace))
                       #t)
-                    thunk)
-                  (thunk)))))
+                    (lambda ()
+                      (apply proc args)))
+                  (apply proc args)))))
       (lambda vals
         (let ((elapsed-seconds
                (/ (- (get-internal-real-time)
                      start)
                   internal-time-units-per-second)))
-          (when (> elapsed-seconds threshold)
-            (let ((lines
-                   (cons
-                    (simple-format #f "warning: delay of ~A seconds: ~A"
-                                   (format-seconds elapsed-seconds)
-                                   thunk)
-                    (map (match-lambda
-                           ((proc duration depth)
-                            (string-append
-                             (make-string (* 2 depth) #\space)
-                             (simple-format #f "~A: ~A"
-                                            (format-seconds duration)
-                                            proc))))
-                         trace))))
-              (if root-logger?
-                  (display (string-append
-                            (string-join lines "\n")
-                            "\n"))
-                  ((fluid-ref delay-logging-fluid) thunk elapsed-seconds))))
-          (apply values vals))))))
+          (if (and (> elapsed-seconds threshold)
+                   root-logger?)
+              (let ((lines
+                     (cons
+                      (simple-format #f "warning: delay of ~A seconds: ~A"
+                                     (format-seconds elapsed-seconds)
+                                     proc)
+                      (map (match-lambda
+                             ((proc duration depth)
+                              (string-append
+                               (make-string (* 2 depth) #\space)
+                               (simple-format #f "~A: ~A"
+                                              (format-seconds duration)
+                                              proc))))
+                           trace))))
+                (display (string-append
+                          (string-join lines "\n")
+                          "\n")))
+              (unless root-logger?
+                ((fluid-ref delay-logging-fluid) proc elapsed-seconds))))
+        (apply values vals)))))
 
 (define (call-with-time-logging name thunk)
   (let ((start   (current-time time-utc)))