Log delays in the thread pool channel

As I think with lots of requests, this could become a bottleneck.

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)