diff options
| author | Christopher Baines <mail@cbaines.net> | 2020-11-30 20:37:07 +0000 |
|---|---|---|
| committer | Christopher Baines <mail@cbaines.net> | 2020-11-30 20:37:07 +0000 |
| commit | 05d6399e6aaf320a1e4aab5f2df45d6ff30dcb2e (patch) | |
| tree | cee5aa98739339ae89184d5109c19485007ee1b7 /guix-build-coordinator/utils | |
| parent | b234b59c4a30b7a5d8b1af36d3b607f3d980362a (diff) | |
| download | build-coordinator-05d6399e6aaf320a1e4aab5f2df45d6ff30dcb2e.tar build-coordinator-05d6399e6aaf320a1e4aab5f2df45d6ff30dcb2e.tar.gz | |
Support tracking delays in worker thread channels
Diffstat (limited to 'guix-build-coordinator/utils')
| -rw-r--r-- | guix-build-coordinator/utils/fibers.scm | 50 |
1 files changed, 28 insertions, 22 deletions
diff --git a/guix-build-coordinator/utils/fibers.scm b/guix-build-coordinator/utils/fibers.scm index a39b3bb..2dfb087 100644 --- a/guix-build-coordinator/utils/fibers.scm +++ b/guix-build-coordinator/utils/fibers.scm @@ -15,7 +15,8 @@ (make-parameter #f)) (define* (make-worker-thread-channel initializer - #:key (parallelism 1)) + #:key (parallelism 1) + (delay-logger (lambda _ #f))) "Return a channel used to offload work to a dedicated thread. ARGS are the arguments of the worker thread procedure." (parameterize (((@@ (fibers internal) current-fiber) #f)) @@ -28,26 +29,31 @@ arguments of the worker thread procedure." (parameterize ((%worker-thread-args args)) (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 - (lambda () - (apply proc args)) - (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 + (lambda () + (apply proc args)) + (lambda vals vals))))) + #:unwind? #t))))) (loop))))))) (iota parallelism)) channel))) @@ -59,7 +65,7 @@ If already in the worker thread, call PROC immediately." (if args (apply proc args) (let ((reply (make-channel))) - (put-message channel (cons reply proc)) + (put-message channel (list reply (get-internal-real-time) proc)) (match (get-message reply) (('worker-thread-error . exn) (raise-exception exn)) |