cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Log delays in the thread pool channel

Browse source 
As I think with lots of requests, this could become a bottleneck.
This commit is contained in:
Christopher Baines 2022-10-02 14:57:02 +01:00
parent 640386a84d
commit ce2e13aa45
1 changed files with 37 additions and 23 deletions
Download patch file Download diff file Expand all files Collapse all files

60
guix-data-service/utils.scm
View file

@ -19,6 +19,7 @@
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 format)
#:use-module (ice-9 threads) #:use-module (ice-9 threads)
#:use-module (fibers) #:use-module (fibers)
#:use-module (fibers channels) #:use-module (fibers channels)
@ -54,8 +55,14 @@
(define-syntax-rule (prevent-inlining-for-tests var) (define-syntax-rule (prevent-inlining-for-tests var)
(set! var var)) (set! var var))
(define* (make-thread-pool-channel #:key (threads 8)) (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))) (let ((channel (make-channel)))
(for-each (for-each
(lambda _ (lambda _
@ -63,27 +70,32 @@
(lambda () (lambda ()
(let loop () (let loop ()
(match (get-message channel) (match (get-message channel)
(((? channel? reply) . (? procedure? proc)) (((? channel? reply) sent-time (? procedure? proc))
(put-message (let ((time-delay
reply (- (get-internal-real-time)
(with-exception-handler sent-time)))
(lambda (exn) (delay-logger (/ time-delay
(cons 'worker-thread-error exn)) internal-time-units-per-second))
(lambda () (put-message
(with-exception-handler reply
(lambda (exn) (with-exception-handler
(simple-format (lambda (exn)
(current-error-port) (cons 'worker-thread-error exn))
"worker thread: exception: ~A\n" (lambda ()
exn) (with-exception-handler
(backtrace) (lambda (exn)
(raise-exception exn)) (simple-format
(lambda () (current-error-port)
(call-with-values "worker thread: exception: ~A\n"
proc exn)
(lambda vals (backtrace)
vals))))) (raise-exception exn))
#:unwind? #t)) (lambda ()
(call-with-values
proc
(lambda vals
vals)))))
#:unwind? #t)))
(loop)) (loop))
(_ #f)))))) (_ #f))))))
(iota threads)) (iota threads))
@ -106,7 +118,9 @@
(let ((reply (make-channel))) (let ((reply (make-channel)))
(spawn-fiber (spawn-fiber
(lambda () (lambda ()
(put-message %thread-pool-channel (cons reply thunk)))) (put-message %thread-pool-channel (list reply
(get-internal-real-time)
thunk))))
reply)) reply))
(define (fetch-result-of-defered-thunk reply-channel) (define (fetch-result-of-defered-thunk reply-channel)