cbaines/guile-knots
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Rename worker threads to thread pool

Browse source 
I think this needs more work, maybe the thread pool should be more
similar to the resource pool, but I think the name change is still
helpful.

Maybe there's a need for a variable size thread pool and that can
better integrate with the work queue.
This commit is contained in:
Christopher Baines 2025-01-13 12:22:27 +00:00
parent dcb56ee2c5
commit d572f591a3
4 changed files with 111 additions and 97 deletions
Download patch file Download diff file Expand all files Collapse all files

4
Makefile.am
View file

@ -9,7 +9,7 @@ SOURCES = \
knots/resource-pool.scm \ knots/resource-pool.scm \
knots/timeout.scm \ knots/timeout.scm \
knots/web-server.scm \ knots/web-server.scm \
knots/worker-threads.scm knots/thread-pool.scm
SCM_TESTS = \ SCM_TESTS = \
tests/non-blocking.scm \ tests/non-blocking.scm \
@ -20,7 +20,7 @@ SCM_TESTS = \
tests/web-server.scm \ tests/web-server.scm \
tests/parallelism.scm \ tests/parallelism.scm \
tests/resource-pool.scm \ tests/resource-pool.scm \
tests/worker-threads.scm tests/thread-pool.scm
TESTS_GOBJECTS = $(SCM_TESTS:%.scm=%.go) TESTS_GOBJECTS = $(SCM_TESTS:%.scm=%.go)

128
knots/worker-threads.scm → knots/thread-pool.scm
View file

@ -17,7 +17,7 @@
;;; along with the guix-data-service. If not, see ;;; along with the guix-data-service. If not, see
;;; <http://www.gnu.org/licenses/>. ;;; <http://www.gnu.org/licenses/>.
(define-module (knots worker-threads) (define-module (knots thread-pool)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (srfi srfi-19) #:use-module (srfi srfi-19)
@ -35,18 +35,18 @@
#:export (set-thread-name #:export (set-thread-name
thread-name thread-name
worker-thread-set? thread-pool?
worker-thread-set-channel thread-pool-channel
worker-thread-set-arguments-parameter thread-pool-arguments-parameter
worker-thread-set-thread-proc-vector thread-pool-proc-vector
make-worker-thread-set make-thread-pool
call-with-worker-thread call-with-thread
&worker-thread-timeout &thread-pool-timeout
worker-thread-timeout-error? thread-pool-timeout-error?
%worker-thread-default-timeout %thread-pool-default-timeout
create-work-queue)) create-work-queue))
@ -145,31 +145,30 @@ from there, or #f if that would be an empty string."
thread-name/linux thread-name/linux
(const ""))) (const "")))
(define-record-type <worker-thread-set> (define-record-type <thread-pool>
(worker-thread-set channel (thread-pool channel arguments-parameter proc-vector)
arguments-parameter thread-pool?
thread-proc-vector) (channel thread-pool-channel)
worker-thread-set? (arguments-parameter thread-pool-arguments-parameter)
(channel worker-thread-set-channel) (proc-vector thread-pool-proc-vector))
(arguments-parameter worker-thread-set-arguments-parameter)
(thread-proc-vector worker-thread-set-thread-proc-vector))
(define* (make-worker-thread-set initializer (define* (make-thread-pool size
#:key (parallelism 1) #:key
(delay-logger (lambda _ #f)) thread-initializer
(duration-logger (const #f)) thread-destructor
destructor (delay-logger (lambda _ #f))
lifetime (duration-logger (const #f))
(log-exception? (const #t)) thread-lifetime
(expire-on-exception? #f) (log-exception? (const #t))
(name "unnamed")) (expire-on-exception? #f)
(name "unnamed"))
"Return a channel used to offload work to a dedicated thread. ARGS are the "Return a channel used to offload work to a dedicated thread. ARGS are the
arguments of the worker thread procedure." arguments of the thread pool procedure."
(define param (define param
(make-parameter #f)) (make-parameter #f))
(define thread-proc-vector (define thread-proc-vector
(make-vector parallelism #f)) (make-vector size #f))
(define (initializer/safe) (define (initializer/safe)
(let ((args (let ((args
@ -177,14 +176,14 @@ arguments of the worker thread procedure."
(lambda (exn) (lambda (exn)
(simple-format (simple-format
(current-error-port) (current-error-port)
"exception running initializer in worker thread (~A): ~A:\n ~A\n" "exception running initializer in thread pool (~A): ~A:\n ~A\n"
name name
initializer thread-initializer
exn) exn)
#f) #f)
(lambda () (lambda ()
(with-throw-handler #t (with-throw-handler #t
initializer thread-initializer
(lambda args (lambda args
(backtrace)))) (backtrace))))
#:unwind? #t))) #:unwind? #t)))
@ -202,15 +201,15 @@ arguments of the worker thread procedure."
(lambda (exn) (lambda (exn)
(simple-format (simple-format
(current-error-port) (current-error-port)
"exception running destructor in worker thread (~A): ~A:\n ~A\n" "exception running destructor in thread pool (~A): ~A:\n ~A\n"
name name
destructor thread-destructor
exn) exn)
#f) #f)
(lambda () (lambda ()
(with-throw-handler #t (with-throw-handler #t
(lambda () (lambda ()
(apply destructor args) (apply thread-destructor args)
#t) #t)
(lambda _ (lambda _
(backtrace)))) (backtrace))))
@ -223,7 +222,7 @@ arguments of the worker thread procedure."
(destructor/safe args))))) (destructor/safe args)))))
(define (process thread-index channel args) (define (process thread-index channel args)
(let loop ((current-lifetime lifetime)) (let loop ((current-lifetime thread-lifetime))
(let ((exception? (let ((exception?
(match (get-message channel) (match (get-message channel)
(((? channel? reply) sent-time (? procedure? proc)) (((? channel? reply) sent-time (? procedure? proc))
@ -231,13 +230,14 @@ arguments of the worker thread procedure."
(- (get-internal-real-time) (- (get-internal-real-time)
sent-time))) sent-time)))
(delay-logger (/ time-delay (delay-logger (/ time-delay
internal-time-units-per-second)) internal-time-units-per-second)
proc)
(let* ((start-time (get-internal-real-time)) (let* ((start-time (get-internal-real-time))
(response (response
(with-exception-handler (with-exception-handler
(lambda (exn) (lambda (exn)
(list 'worker-thread-error (list 'thread-pool-error
(/ (- (get-internal-real-time) (/ (- (get-internal-real-time)
start-time) start-time)
internal-time-units-per-second) internal-time-units-per-second)
@ -251,7 +251,7 @@ arguments of the worker thread procedure."
(call-with-values (call-with-values
(lambda () (lambda ()
(start-stack (start-stack
'worker-thread 'thread-pool
(apply proc args))) (apply proc args)))
(lambda vals (lambda vals
(cons (/ (- (get-internal-real-time) (cons (/ (- (get-internal-real-time)
@ -265,7 +265,7 @@ arguments of the worker thread procedure."
(_ #t)) (_ #t))
(simple-format (simple-format
(current-error-port) (current-error-port)
"worker-thread: exception: ~A\n" args) "thread-pool: exception: ~A\n" args)
(backtrace))))) (backtrace)))))
#:unwind? #t))) #:unwind? #t)))
(put-message reply (put-message reply
@ -276,7 +276,7 @@ arguments of the worker thread procedure."
#f) #f)
(match response (match response
(('worker-thread-error duration _) (('thread-pool-error duration _)
(when duration-logger (when duration-logger
(duration-logger duration proc)) (duration-logger duration proc))
#t) #t)
@ -306,47 +306,49 @@ arguments of the worker thread procedure."
(number->string thread-index)))) (number->string thread-index))))
(const #t)) (const #t))
(let init ((args (initializer/safe))) (let init ((args (if thread-initializer
(initializer/safe)
'())))
(with-exception-handler (with-exception-handler
(lambda (exn) (lambda (exn)
(simple-format (simple-format
(current-error-port) (current-error-port)
"worker-thread-channel: exception: ~A\n" exn)) "knots: thread-pool: internal exception: ~A\n" exn))
(lambda () (lambda ()
(parameterize ((param args)) (parameterize ((param args))
(process thread-index channel args))) (process thread-index channel args)))
#:unwind? #t) #:unwind? #t)
(when destructor (when thread-destructor
(destructor/safe args)) (destructor/safe args))
(init (initializer/safe)))))) (init (initializer/safe))))))
(iota parallelism)) (iota size))
(worker-thread-set channel (thread-pool channel
param param
thread-proc-vector))) thread-proc-vector)))
(define &worker-thread-timeout (define &thread-pool-timeout
(make-exception-type '&worker-thread-timeout (make-exception-type '&thread-pool-timeout
&error &error
'())) '()))
(define make-worker-thread-timeout-error (define make-thread-pool-timeout-error
(record-constructor &worker-thread-timeout)) (record-constructor &thread-pool-timeout))
(define worker-thread-timeout-error? (define thread-pool-timeout-error?
(record-predicate &worker-thread-timeout)) (record-predicate &thread-pool-timeout))
(define %worker-thread-default-timeout (define %thread-pool-default-timeout
(make-parameter 30)) (make-parameter 30))
(define* (call-with-worker-thread record proc #:key duration-logger (define* (call-with-thread record proc #:key duration-logger
(timeout (%worker-thread-default-timeout)) (timeout (%thread-pool-default-timeout))
(channel (worker-thread-set-channel record))) (channel (thread-pool-channel record)))
"Send PROC to the worker thread through CHANNEL. Return the result of PROC. "Send PROC to the thread pool through CHANNEL. Return the result of PROC.
If already in the worker thread, call PROC immediately." If already in the thread pool, call PROC immediately."
(let ((args ((worker-thread-set-arguments-parameter record)))) (let ((args ((thread-pool-arguments-parameter record))))
(if args (if args
(apply proc args) (apply proc args)
(let* ((reply (make-channel)) (let* ((reply (make-channel))
@ -369,10 +371,10 @@ If already in the worker thread, call PROC immediately."
(unless operation-success? (unless operation-success?
(raise-exception (raise-exception
(make-worker-thread-timeout-error))) (make-thread-pool-timeout-error)))
(match (get-message reply) (match (get-message reply)
(('worker-thread-error duration exn) (('thread-pool-error duration exn)
(when duration-logger (when duration-logger
(duration-logger duration)) (duration-logger duration))
(raise-exception exn)) (raise-exception exn))

44
tests/thread-pool.scm Normal file
View file

@ -0,0 +1,44 @@
(use-modules (tests)
(srfi srfi-71)
(fibers)
(unit-test)
(knots thread-pool))
(let ((thread-pool
(make-thread-pool 2)))
(run-fibers-for-tests
(lambda ()
(assert-equal
(call-with-thread
thread-pool
(lambda ()
4))
4))))
(let ((thread-pool
(make-thread-pool
2
#:thread-initializer (const '(2)))))
(run-fibers-for-tests
(lambda ()
(assert-equal
(call-with-thread
thread-pool
(lambda (num)
(* 2 num)))
4))))
(let ((process-job
count-jobs
count-threads
list-jobs
(create-work-queue
2
(lambda (i)
(* i 2)))))
(process-job 3))
(display "thread-pool test finished successfully\n")

32
tests/worker-threads.scm
View file

@ -1,32 +0,0 @@
(use-modules (tests)
(srfi srfi-71)
(fibers)
(unit-test)
(knots worker-threads))
(let ((worker-thread-set
(make-worker-thread-set
(const '())
#:parallelism 2)))
(run-fibers-for-tests
(lambda ()
(assert-equal
(call-with-worker-thread
worker-thread-set
(lambda ()
4))
4))))
(let ((process-job
count-jobs
count-threads
list-jobs
(create-work-queue
2
(lambda (i)
(* i 2)))))
(process-job 3))
(display "worker-threads test finished successfully\n")