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