Add a tracing style delay logger

This tracks delays and can report a breakdown by procedure.

1 files changed, 63 insertions, 0 deletions

diff --git a/guix-build-coordinator/utils.scm b/guix-build-coordinator/utils.scm
index 2c1338a..c1170f5 100644
--- a/guix-build-coordinator/utils.scm
+++ b/guix-build-coordinator/utils.scm
@@ -55,6 +55,9 @@
             s3-list-objects
             s3-cp
 
+            log-delay
+            call-with-delay-logging
+
             with-time-logging
 
             create-work-queue
@@ -662,6 +665,66 @@ References: ~a~%"
            command))))
       #t)))
 
+(define delay-logging-fluid
+  (make-thread-local-fluid))
+(define delay-logging-depth-fluid
+  (make-thread-local-fluid 0))
+
+(define (log-delay proc duration)
+  (and=> (fluid-ref delay-logging-fluid)
+         (lambda (recorder)
+           (recorder proc duration))))
+
+(define* (call-with-delay-logging thunk #:key (threshold 1))
+  (let ((start (get-internal-real-time))
+        (trace '())
+        (root-logger? (eq? #f (fluid-ref delay-logging-fluid))))
+
+    (define (format-seconds seconds)
+      (format #f "~1,2f" seconds))
+
+    (call-with-values
+        (lambda ()
+          (with-fluid* delay-logging-depth-fluid
+            (+ 1 (fluid-ref delay-logging-depth-fluid))
+            (lambda ()
+              (if root-logger?
+                  (with-fluid* delay-logging-fluid
+                    (lambda (proc duration)
+                      (set! trace
+                            (cons (list proc
+                                        duration
+                                        (fluid-ref delay-logging-depth-fluid))
+                                  trace))
+                      #t)
+                    thunk)
+                  (thunk)))))
+      (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))))))
+
 (define (call-with-time-logging name thunk)
   (let ((start   (current-time time-utc)))
     (call-with-values