summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorChristopher Baines <mail@cbaines.net>2020-01-24 19:04:21 +0000
committerChristopher Baines <mail@cbaines.net>2020-01-25 22:32:09 +0000
commite34d773faf7309d4273fe204149845999d4ed8a7 (patch)
tree36c04c21af678ceaedb1527fbb1623852a9be76f
parent0d23a6d374340f3f9a3b035f960abd39447e11c3 (diff)
downloadcuirass-e34d773faf7309d4273fe204149845999d4ed8a7.tar
cuirass-e34d773faf7309d4273fe204149845999d4ed8a7.tar.gz
Adjust make-worker-thread-channel to take an initializer.
While this is a generic method, and initializer function will give the flexibility required to create multiple worker threads for performing SQLite queries, each with it's own database connection (as a result of calling the initializer once for each thread). Without this change, they'd all have to use the same connection, which would not work. * src/cuirass/utils.scm (make-worker-thread-channel): Change procedure to take an initializer, rather than arguments directly. * src/cuirass/database.scm (with-database): Adjust to call make-worker-thread-channel with an initializer. * tests/database.scm (db-init): Change to use make-worker-thread-channel initializer. * tests/http.scm (db-init): Change to use make-worker-thread-channel initializer.
-rw-r--r--src/cuirass/database.scm25
-rw-r--r--src/cuirass/utils.scm19
-rw-r--r--tests/database.scm4
-rw-r--r--tests/http.scm4
4 files changed, 23 insertions, 29 deletions
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index 2468804..c82e306 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -434,24 +434,13 @@ WHERE id = " eval-id ";")
(#:in_progress . #f)))))
(define-syntax-rule (with-database body ...)
- "Run BODY with %DB-CHANNEL being dynamically bound to a channel implementing
-a critical section that allows database operations to be serialized."
- ;; XXX: We don't install an unwind handler to play well with delimited
- ;; continuations and fibers. But as a consequence, we leak DB when BODY
- ;; raises an exception.
- (let ((db (db-open)))
- (unwind-protect
- ;; Process database queries sequentially in a thread. We need this
- ;; because otherwise we would need to use the SQLite multithreading
- ;; feature for which it is required to wait until the database is
- ;; available, and the waiting would happen in non-cooperative and
- ;; non-resumable code that blocks the fibers scheduler. Now the database
- ;; access blocks on PUT-MESSAGE, which allows the scheduler to schedule
- ;; another fiber. Also, creating one new handle for each request would
- ;; be costly and may defeat statement caching.
- (parameterize ((%db-channel (make-worker-thread-channel db)))
- body ...)
- (db-close db))))
+ "Run BODY with %DB-CHANNEL being dynamically bound to a channel providing a
+worker thread that allows database operations to run without intefering with
+fibers."
+ (parameterize ((%db-channel (make-worker-thread-channel
+ (lambda ()
+ (list (db-open))))))
+ body ...))
(define* (read-quoted-string #:optional (port (current-input-port)))
"Read all of the characters out of PORT and return them as a SQL quoted
diff --git a/src/cuirass/utils.scm b/src/cuirass/utils.scm
index 514899e..dfed4a9 100644
--- a/src/cuirass/utils.scm
+++ b/src/cuirass/utils.scm
@@ -99,19 +99,20 @@ delimited continuations and fibers."
(define %worker-thread-args
(make-parameter #f))
-(define (make-worker-thread-channel . args)
+(define (make-worker-thread-channel initializer)
"Return a channel used to offload work to a dedicated thread. ARGS are the
arguments of the worker thread procedure."
(parameterize (((@@ (fibers internal) current-fiber) #f))
(let ((channel (make-channel)))
- (call-with-new-thread
- (lambda ()
- (parameterize ((%worker-thread-args args))
- (let loop ()
- (match (get-message channel)
- (((? channel? reply) . (? procedure? proc))
- (put-message reply (apply proc args))))
- (loop)))))
+ (let ((args (initializer)))
+ (call-with-new-thread
+ (lambda ()
+ (parameterize ((%worker-thread-args args))
+ (let loop ()
+ (match (get-message channel)
+ (((? channel? reply) . (? procedure? proc))
+ (put-message reply (apply proc args))))
+ (loop))))))
channel)))
(define (call-with-worker-thread channel proc)
diff --git a/tests/database.scm b/tests/database.scm
index 271f166..6098465 100644
--- a/tests/database.scm
+++ b/tests/database.scm
@@ -87,7 +87,9 @@
(test-assert "db-init"
(begin
(%db (db-init database-name))
- (%db-channel (make-worker-thread-channel (%db)))
+ (%db-channel (make-worker-thread-channel
+ (lambda ()
+ (list (%db)))))
#t))
(test-assert "sqlite-exec"
diff --git a/tests/http.scm b/tests/http.scm
index 337a775..d20a3c3 100644
--- a/tests/http.scm
+++ b/tests/http.scm
@@ -108,7 +108,9 @@
(test-assert "db-init"
(begin
(%db (db-init database-name))
- (%db-channel (make-worker-thread-channel (%db)))
+ (%db-channel (make-worker-thread-channel
+ (lambda ()
+ (list (%db)))))
#t))
(test-assert "cuirass-run"