From ff77bbea7e647a07c5601e51704c04258a73b79f Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Sun, 2 Oct 2022 15:08:18 +0100
Subject: [PATCH] Make it possible to increase the number of thread pool
 threads

And double the default to 16.
---
 guix-data-service/utils.scm  |  9 +++++++--
 scripts/guix-data-service.in | 13 ++++++++++++-
 2 files changed, 19 insertions(+), 3 deletions(-)

diff --git a/guix-data-service/utils.scm b/guix-data-service/utils.scm
index f5a1128..6be5cc5 100644
--- a/guix-data-service/utils.scm
+++ b/guix-data-service/utils.scm
@@ -28,6 +28,7 @@
             with-time-logging
             prevent-inlining-for-tests
 
+            %thread-pool-threads
             parallel-via-thread-pool-channel
             par-map&
             letpar&
@@ -55,7 +56,10 @@
 (define-syntax-rule (prevent-inlining-for-tests var)
   (set! var var))
 
-(define* (make-thread-pool-channel #:key (threads 8))
+(define %thread-pool-threads
+  (make-parameter 8))
+
+(define* (make-thread-pool-channel threads)
   (define (delay-logger seconds-delayed)
     (when (> seconds-delayed 1)
       (format
@@ -107,7 +111,8 @@
 (define (make-thread-pool-channel!')
   (with-mutex %thread-pool-mutex
     (unless %thread-pool-channel
-      (set! %thread-pool-channel (make-thread-pool-channel))
+      (set! %thread-pool-channel (make-thread-pool-channel
+                                  (%thread-pool-threads)))
       (set! make-thread-pool-channel! (lambda () #t)))))
 
 (define make-thread-pool-channel!
diff --git a/scripts/guix-data-service.in b/scripts/guix-data-service.in
index e0b35c6..5f0dc25 100644
--- a/scripts/guix-data-service.in
+++ b/scripts/guix-data-service.in
@@ -33,6 +33,7 @@
              (system repl repl)
              (gcrypt pk-crypto)
              (guix pki)
+             (guix-data-service utils)
              (guix-data-service config)
              (guix-data-service database)
              (guix-data-service substitutes)
@@ -91,6 +92,12 @@
                   (alist-cons 'host
                               arg
                               (alist-delete 'host result))))
+        (option '("thread-pool-threads") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'thread-pool-threads
+                              (string->number arg)
+                              (alist-delete 'thread-pool-threads
+                                            result))))
         (option '("postgresql-statement-timeout") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'postgresql-statement-timeout
@@ -111,6 +118,7 @@
           (_ #t)))
     (port                                 . 8765)
     (host                                 . "0.0.0.0")
+    (thread-pool-threads                  . 16)
     (postgresql-statement-timeout         . 60000)))
 
 
@@ -171,7 +179,10 @@
                                (current-error-port))
                       #f)))
                  (%show-error-details
-                  (assoc-ref opts 'show-error-details)))
+                  (assoc-ref opts 'show-error-details))
+
+                 (%thread-pool-threads
+                  (assoc-ref opts 'thread-pool-threads)))
 
     (let* ((startup-completed
             (make-atomic-box