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

Improve exception reporting

Browse source
This commit is contained in:
Christopher Baines 2025-02-27 12:09:04 +00:00
parent ed4113af51
commit 21e328aebb
3 changed files with 50 additions and 58 deletions
Download patch file Download diff file Expand all files Collapse all files

32
knots/resource-pool.scm
View file

@ -129,18 +129,16 @@
(lambda () (lambda ()
(let ((new-resource (let ((new-resource
(with-exception-handler (with-exception-handler
(lambda (exn) (lambda _ #f)
(simple-format
(current-error-port)
"exception adding resource to pool ~A: ~A:\n ~A\n"
name
return-new-resource
exn)
#f)
(lambda () (lambda ()
(with-exception-handler (with-exception-handler
(lambda (exn) (lambda (exn)
(backtrace) (simple-format
(current-error-port)
"exception adding resource to pool ~A: ~A\n\n"
name
return-new-resource)
(print-backtrace-and-exception/knots exn)
(raise-exception exn)) (raise-exception exn))
(lambda () (lambda ()
(start-stack #t (return-new-resource))))) (start-stack #t (return-new-resource)))))
@ -155,18 +153,16 @@
(let loop () (let loop ()
(let ((success? (let ((success?
(with-exception-handler (with-exception-handler
(lambda (exn) (lambda _ #f)
(simple-format
(current-error-port)
"exception running resource pool destructor (~A): ~A:\n ~A\n"
name
destructor
exn)
#f)
(lambda () (lambda ()
(with-exception-handler (with-exception-handler
(lambda (exn) (lambda (exn)
(backtrace) (simple-format
(current-error-port)
"exception running resource pool destructor (~A): ~A\n"
name
destructor)
(print-backtrace-and-exception/knots exn)
(raise-exception exn)) (raise-exception exn))
(lambda () (lambda ()
(start-stack #t (destructor resource)) (start-stack #t (destructor resource))

53
knots/thread-pool.scm
View file

@ -177,20 +177,19 @@ arguments of the thread pool procedure."
(define (initializer/safe) (define (initializer/safe)
(let ((args (let ((args
(with-exception-handler
(lambda _ #f)
(lambda ()
(with-exception-handler (with-exception-handler
(lambda (exn) (lambda (exn)
(simple-format (simple-format
(current-error-port) (current-error-port)
"exception running initializer in thread pool (~A): ~A:\n ~A\n" "exception running initializer in thread pool (~A): ~A\n"
name name
thread-initializer thread-initializer)
exn) (print-backtrace-and-exception/knots exn)
#f) (raise-exception exn))
(lambda () thread-initializer))
(with-throw-handler #t
thread-initializer
(lambda args
(backtrace))))
#:unwind? #t))) #:unwind? #t)))
(if args (if args
@ -202,22 +201,21 @@ arguments of the thread pool procedure."
(define (destructor/safe args) (define (destructor/safe args)
(let ((success? (let ((success?
(with-exception-handler
(lambda _ #f)
(lambda ()
(with-exception-handler (with-exception-handler
(lambda (exn) (lambda (exn)
(simple-format (simple-format
(current-error-port) (current-error-port)
"exception running destructor in thread pool (~A): ~A:\n ~A\n" "exception running destructor in thread pool (~A): ~A\n"
name name
thread-destructor thread-destructor)
exn) (print-backtrace-and-exception/knots exn)
#f) (raise-exception exn))
(lambda ()
(with-throw-handler #t
(lambda () (lambda ()
(apply thread-destructor args) (apply thread-destructor args)
#t) #t)))
(lambda _
(backtrace))))
#:unwind? #t))) #:unwind? #t)))
(or success? (or success?
@ -464,21 +462,18 @@ If already in the thread pool, call PROC immediately."
running-job-args)))) running-job-args))))
(define (thread-process-job job-args) (define (thread-process-job job-args)
(with-exception-handler
(lambda _ #f)
(lambda ()
(with-exception-handler (with-exception-handler
(lambda (exn) (lambda (exn)
(simple-format (current-error-port) (simple-format (current-error-port)
"~A work queue, job raised exception ~A: ~A\n" "~A work queue, job raised exception ~A\n"
name job-args exn)) name job-args)
(print-backtrace-and-exception/knots exn)
(raise-exception exn))
(lambda () (lambda ()
(with-throw-handler #t (apply proc job-args))))
(lambda ()
(apply proc job-args))
(lambda (key . args)
(simple-format
(current-error-port)
"~A work queue, exception when handling job: ~A ~A\n"
name key args)
(backtrace))))
#:unwind? #t)) #:unwind? #t))
(define (start-thread thread-index) (define (start-thread thread-index)

9
tests.scm
View file

@ -12,10 +12,11 @@
(lambda (exn) (lambda (exn)
exn) exn)
(lambda () (lambda ()
(with-throw-handler #t (with-exception-handler
thunk (lambda (exn)
(lambda _ (backtrace)
(backtrace))) (raise-exception exn))
thunk)
#t) #t)
#:unwind? #t)) #:unwind? #t))
#:hz 0 #:hz 0