From 39db021afdb48d0a08a3d8c17eff802af51fefbf Mon Sep 17 00:00:00 2001
From: Mathieu Othacehe <othacehe@gnu.org>
Date: Wed, 30 Sep 2020 11:56:04 +0200
Subject: Add evaluation database workers.

Evaluation registration involves running a large number of SQL queries. This
can cause some database worker starvation as well as some contention. To avoid
this issue, spawn database workers dedicated to evaluation registration.

* src/cuirass/database.scm (%db-registration-channel): New variable.
(with-db-registration-worker-thread, with-registration-workers): New macros.
(with-db-worker-thread-no-timeout): Remove it.
(db-register-builds): Run registration in dedicated database workers using
"with-db-registration-worker-thread" macro.
* bin/cuirass.in (main): Spawn database registration workers by calling
"with-registration-workers" macro.
---
 bin/cuirass.in           | 11 ++++++-----
 src/cuirass/database.scm | 47 ++++++++++++++++++++++++++++++++++-------------
 2 files changed, 40 insertions(+), 18 deletions(-)

diff --git a/bin/cuirass.in b/bin/cuirass.in
index 55e92b6..8da9369 100644
--- a/bin/cuirass.in
+++ b/bin/cuirass.in
@@ -194,11 +194,12 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
                               (essential-task
                                'build exit-channel
                                (lambda ()
-                                 (while #t
-                                   (process-specs (db-get-specifications))
-                                   (log-message
-                                    "next evaluation in ~a seconds" interval)
-                                   (sleep interval)))))
+                                 (with-registration-workers
+                                  (while #t
+                                    (process-specs (db-get-specifications))
+                                    (log-message
+                                     "next evaluation in ~a seconds" interval)
+                                    (sleep interval))))))
 
                              (spawn-fiber
                               (essential-task
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index 4de94f4..ff2a5e4 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -94,7 +94,8 @@
             %record-events?
             ;; Macros.
             with-db-worker-thread
-            with-database))
+            with-database
+            with-registration-workers))
 
 (define (%sqlite-exec db sql . args)
   "Evaluate the given SQL query with the given ARGS.  Return the list of
@@ -189,6 +190,9 @@ specified."
 (define %db-channel
   (make-parameter #f))
 
+(define %db-registration-channel
+  (make-parameter #f))
+
 (define %record-events?
   (make-parameter #f))
 
@@ -207,12 +211,13 @@ connection."
         (format #f "Database worker unresponsive for ~a seconds."
                 (number->string timeout)))))))
 
-(define-syntax-rule (with-db-worker-thread-no-timeout db exp ...)
-  "This is similar to WITH-DB-WORKER-THREAD but it does not setup a timeout.
-This should be used with care as blocking too long in EXP can lead to workers
-starvation."
+(define-syntax-rule (with-db-registration-worker-thread db exp ...)
+  "Similar to WITH-DB-WORKER-THREAD but evaluates EXP in database workers
+dedicated to evaluation registration.  It is expected those workers to be busy
+for long durations as registration involves running a large number of SQL
+queries.  For this reason, do not setup a timeout here."
   (call-with-worker-thread
-   (%db-channel)
+   (%db-registration-channel)
    (lambda (db) exp ...)))
 
 (define (read-sql-file file-name)
@@ -530,13 +535,26 @@ now "," checkouttime "," evaltime ");")
 
 (define-syntax-rule (with-database body ...)
   "Run BODY with %DB-CHANNEL being dynamically bound to a channel providing a
-worker thread that allows database operations to run without intefering with
+worker thread that allows database operations to run without interfering with
 fibers."
-  (parameterize ((%db-channel (make-worker-thread-channel
-                               (lambda ()
-                                 (list (db-open)))
-                               #:parallelism
-                               (min (current-processor-count) 4))))
+  (parameterize ((%db-channel
+                  (make-worker-thread-channel
+                   (lambda ()
+                     (list (db-open)))
+                   #:parallelism
+                   (min (current-processor-count) 4))))
+    body ...))
+
+(define-syntax-rule (with-registration-workers body ...)
+  "Run BODY with %DB-REGISTRATION-CHANNEL being dynamically bound to a channel
+providing worker threads that allow registration database operations to run
+without interfering with fibers."
+  (parameterize ((%db-registration-channel
+                  (make-worker-thread-channel
+                   (lambda ()
+                     (list (db-open)))
+                   #:parallelism
+                   (min (current-processor-count) 4))))
     body ...))
 
 (define* (read-quoted-string #:optional (port (current-input-port)))
@@ -685,7 +703,10 @@ path) VALUES ("
                           (#:stoptime . 0))))
              (db-add-build build)))))
 
-  (with-db-worker-thread-no-timeout db (filter-map register jobs)))
+  ;; New builds registration involves running a large number of SQL queries.
+  ;; To keep database workers available, use specific database workers
+  ;; dedicated to evaluation registration.
+  (with-db-registration-worker-thread db (filter-map register jobs)))
 
 (define* (db-update-build-status! drv status #:key log-file)
   "Update the database so that DRV's status is STATUS.  This also updates the
-- 
cgit v1.2.3