diff options
author | Christopher Baines <mail@cbaines.net> | 2021-11-18 00:03:37 +0000 |
---|---|---|
committer | Christopher Baines <mail@cbaines.net> | 2021-11-18 00:03:37 +0000 |
commit | 392f19511b12ec10780c4ec7eb4469d81750ee3f (patch) | |
tree | f86e92a03e0022b9c8f8e98345b70de0ee1d247e | |
parent | 0367c8fe3951ed38d6553f815f7bcd02453def0e (diff) | |
download | build-coordinator-392f19511b12ec10780c4ec7eb4469d81750ee3f.tar build-coordinator-392f19511b12ec10780c4ec7eb4469d81750ee3f.tar.gz |
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.
-rw-r--r-- | guix-build-coordinator/utils.scm | 48 |
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))) |