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

Simplify and extend using the knots exception with stack

Browse source
This commit is contained in:
Christopher Baines 2025-02-27 12:08:41 +00:00
parent d8bc09755e
commit ed4113af51
3 changed files with 38 additions and 29 deletions
Download patch file Download diff file Expand all files Collapse all files

31
knots/parallelism.scm
View file

@ -52,7 +52,11 @@
(let ((stack (make-stack #t (let ((stack (make-stack #t
0 prompt-tag 0 prompt-tag
0 (and prompt-tag 1)))) 0 (and prompt-tag 1))))
(put-message reply (list 'exception exn stack))))) (put-message reply
(list 'exception
(make-exception
exn
(make-knots-exception stack)))))))
(return)) (return))
(lambda () (lambda ()
(call-with-values (call-with-values
@ -69,12 +73,7 @@
(map (map
(match-lambda (match-lambda
(('exception exn stack) (('exception exn stack)
(let ((knots-exn (raise-exception exn))
(make-knots-exception stack)))
(raise-exception
(make-exception
knots-exn
exn))))
(result (result
(apply values result))) (apply values result)))
responses))) responses)))
@ -118,13 +117,8 @@
(vector-ref result-vec index)) (vector-ref result-vec index))
(lambda (result) (lambda (result)
(match result (match result
(('exception exn stack) (('exception exn)
(let ((knots-exn (raise-exception exn))
(make-knots-exception stack)))
(raise-exception
(make-exception
knots-exn
exn))))
(_ (_
(vector-set! result-vec (vector-set! result-vec
index index
@ -275,10 +269,5 @@
(put-message input-channel (cons reply-channel args)) (put-message input-channel (cons reply-channel args))
(match (get-message reply-channel) (match (get-message reply-channel)
(('result . vals) (apply values vals)) (('result . vals) (apply values vals))
(('exception exn stack) (('exception exn)
(let ((knots-exn (raise-exception exn))))))
(make-knots-exception stack)))
(raise-exception
(make-exception
knots-exn
exn))))))))

18
knots/thread-pool.scm
View file

@ -253,18 +253,20 @@ arguments of the thread pool procedure."
proc) proc)
(with-exception-handler (with-exception-handler
(lambda (exn) (lambda (exn)
(when (log-exception? exn) (match (fluid-ref %stacks)
(simple-format ((stack-tag . prompt-tag)
(current-error-port) (let ((stack (make-stack #t
"thread-pool: exception running ~A\n" proc) 0 prompt-tag
(print-backtrace-and-exception/knots 0 (and prompt-tag 1))))
exn)) (raise-exception
(raise-exception exn)) (make-exception
exn
(make-knots-exception stack)))))))
(lambda () (lambda ()
(call-with-values (call-with-values
(lambda () (lambda ()
(start-stack (start-stack
'thread-pool #t
(apply proc args))) (apply proc args)))
(lambda vals (lambda vals
(cons (/ (- (get-internal-real-time) (cons (/ (- (get-internal-real-time)

18
tests/thread-pool.scm
View file

@ -2,6 +2,7 @@
(srfi srfi-71) (srfi srfi-71)
(fibers) (fibers)
(unit-test) (unit-test)
(knots)
(knots thread-pool)) (knots thread-pool))
(let ((thread-pool (let ((thread-pool
@ -41,4 +42,21 @@
(process-job 3)) (process-job 3))
(let ((thread-pool
(make-thread-pool 2)))
(run-fibers-for-tests
(lambda ()
(assert-equal
#t
(with-exception-handler
(lambda (exn)
(knots-exception? exn))
(lambda ()
(call-with-thread
thread-pool
(lambda ()
(+ 1 'a))))
#:unwind? #t)))))
(display "thread-pool test finished successfully\n") (display "thread-pool test finished successfully\n")