diff options
| -rw-r--r-- | guix-data-service/utils.scm | 60 |
1 files changed, 37 insertions, 23 deletions
diff --git a/guix-data-service/utils.scm b/guix-data-service/utils.scm index d59c18f..f5a1128 100644 --- a/guix-data-service/utils.scm +++ b/guix-data-service/utils.scm @@ -19,6 +19,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (ice-9 match) + #:use-module (ice-9 format) #:use-module (ice-9 threads) #:use-module (fibers) #:use-module (fibers channels) @@ -54,8 +55,14 @@ (define-syntax-rule (prevent-inlining-for-tests var) (set! var var)) - (define* (make-thread-pool-channel #:key (threads 8)) + (define (delay-logger seconds-delayed) + (when (> seconds-delayed 1) + (format + (current-error-port) + "warning: thread pool delayed by ~1,2f seconds~%" + seconds-delayed))) + (let ((channel (make-channel))) (for-each (lambda _ @@ -63,27 +70,32 @@ (lambda () (let loop () (match (get-message channel) - (((? channel? reply) . (? procedure? proc)) - (put-message - reply - (with-exception-handler - (lambda (exn) - (cons 'worker-thread-error exn)) - (lambda () - (with-exception-handler - (lambda (exn) - (simple-format - (current-error-port) - "worker thread: exception: ~A\n" - exn) - (backtrace) - (raise-exception exn)) - (lambda () - (call-with-values - proc - (lambda vals - vals))))) - #:unwind? #t)) + (((? 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 + (with-exception-handler + (lambda (exn) + (cons 'worker-thread-error exn)) + (lambda () + (with-exception-handler + (lambda (exn) + (simple-format + (current-error-port) + "worker thread: exception: ~A\n" + exn) + (backtrace) + (raise-exception exn)) + (lambda () + (call-with-values + proc + (lambda vals + vals))))) + #:unwind? #t))) (loop)) (_ #f)))))) (iota threads)) @@ -106,7 +118,9 @@ (let ((reply (make-channel))) (spawn-fiber (lambda () - (put-message %thread-pool-channel (cons reply thunk)))) + (put-message %thread-pool-channel (list reply + (get-internal-real-time) + thunk)))) reply)) (define (fetch-result-of-defered-thunk reply-channel) |