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 ()
(let ((new-resource
(with-exception-handler
(lambda (exn)
(simple-format
(current-error-port)
"exception adding resource to pool ~A: ~A:\n ~A\n"
name
return-new-resource
exn)
#f)
(lambda _ #f)
(lambda ()
(with-exception-handler
(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))
(lambda ()
(start-stack #t (return-new-resource)))))
@ -155,18 +153,16 @@
(let loop ()
(let ((success?
(with-exception-handler
(lambda (exn)
(simple-format
(current-error-port)
"exception running resource pool destructor (~A): ~A:\n ~A\n"
name
destructor
exn)
#f)
(lambda _ #f)
(lambda ()
(with-exception-handler
(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))
(lambda ()
(start-stack #t (destructor resource))

67
knots/thread-pool.scm
View file

@ -178,19 +178,18 @@ arguments of the thread pool procedure."
(define (initializer/safe)
(let ((args
(with-exception-handler
(lambda (exn)
(simple-format
(current-error-port)
"exception running initializer in thread pool (~A): ~A:\n ~A\n"
name
thread-initializer
exn)
#f)
(lambda _ #f)
(lambda ()
(with-throw-handler #t
thread-initializer
(lambda args
(backtrace))))
(with-exception-handler
(lambda (exn)
(simple-format
(current-error-port)
"exception running initializer in thread pool (~A): ~A\n"
name
thread-initializer)
(print-backtrace-and-exception/knots exn)
(raise-exception exn))
thread-initializer))
#:unwind? #t)))
(if args
@ -203,21 +202,20 @@ arguments of the thread pool procedure."
(define (destructor/safe args)
(let ((success?
(with-exception-handler
(lambda (exn)
(simple-format
(current-error-port)
"exception running destructor in thread pool (~A): ~A:\n ~A\n"
name
thread-destructor
exn)
#f)
(lambda _ #f)
(lambda ()
(with-throw-handler #t
(with-exception-handler
(lambda (exn)
(simple-format
(current-error-port)
"exception running destructor in thread pool (~A): ~A\n"
name
thread-destructor)
(print-backtrace-and-exception/knots exn)
(raise-exception exn))
(lambda ()
(apply thread-destructor args)
#t)
(lambda _
(backtrace))))
#t)))
#:unwind? #t)))
(or success?
@ -465,20 +463,17 @@ If already in the thread pool, call PROC immediately."
(define (thread-process-job job-args)
(with-exception-handler
(lambda (exn)
(simple-format (current-error-port)
"~A work queue, job raised exception ~A: ~A\n"
name job-args exn))
(lambda _ #f)
(lambda ()
(with-throw-handler #t
(with-exception-handler
(lambda (exn)
(simple-format (current-error-port)
"~A work queue, job raised exception ~A\n"
name job-args)
(print-backtrace-and-exception/knots exn)
(raise-exception exn))
(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))))
(apply proc job-args))))
#:unwind? #t))
(define (start-thread thread-index)

9
tests.scm
View file

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