diff options
| -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))) |