diff options
| author | Christopher Baines <mail@cbaines.net> | 2024-07-02 11:42:34 +0200 |
|---|---|---|
| committer | Christopher Baines <mail@cbaines.net> | 2024-07-02 14:39:38 +0200 |
| commit | f9ac1fce7c297f3a37e1ba36b8ffd2a5b75821fb (patch) | |
| tree | f6ab0c9dc0e1e271b43e39e5ab25a1e84d1cbf97 /guix-build-coordinator | |
| parent | 0b260b8b16354b45f59c0eb0cf7aa2ca6b5ee9de (diff) | |
| download | build-coordinator-f9ac1fce7c297f3a37e1ba36b8ffd2a5b75821fb.tar build-coordinator-f9ac1fce7c297f3a37e1ba36b8ffd2a5b75821fb.tar.gz | |
Track the procedures the worker threads are running
Diffstat (limited to 'guix-build-coordinator')
| -rw-r--r-- | guix-build-coordinator/utils/fibers.scm | 17 |
1 files changed, 14 insertions, 3 deletions
diff --git a/guix-build-coordinator/utils/fibers.scm b/guix-build-coordinator/utils/fibers.scm index 93626c7..a064175 100644 --- a/guix-build-coordinator/utils/fibers.scm +++ b/guix-build-coordinator/utils/fibers.scm @@ -51,6 +51,8 @@ (name "unnamed")) "Return a channel used to offload work to a dedicated thread. ARGS are the arguments of the worker thread procedure." + (define thread-proc-vector + (make-vector parallelism #f)) (define (initializer/safe) (let ((args @@ -103,7 +105,7 @@ arguments of the worker thread procedure." (sleep 1) (destructor/safe args))))) - (define (process channel args) + (define (process thread-index channel args) (let loop ((current-lifetime lifetime)) (let ((exception? (match (get-message channel) @@ -124,6 +126,9 @@ arguments of the worker thread procedure." internal-time-units-per-second) exn)) (lambda () + (vector-set! thread-proc-vector + thread-index + proc) (with-throw-handler #t (lambda () (call-with-values @@ -149,6 +154,10 @@ arguments of the worker thread procedure." (put-message reply response) + (vector-set! thread-proc-vector + thread-index + #f) + (match response (('worker-thread-error duration _) (when duration-logger @@ -188,7 +197,7 @@ arguments of the worker thread procedure." "worker-thread-channel: exception: ~A\n" exn)) (lambda () (parameterize ((%worker-thread-args args)) - (process channel args))) + (process thread-index channel args))) #:unwind? #t) (when destructor @@ -196,7 +205,9 @@ arguments of the worker thread procedure." (init (initializer/safe)))))) (iota parallelism)) - channel)) + + (values channel + thread-proc-vector))) (define &worker-thread-timeout (make-exception-type '&worker-thread-timeout |