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

Start trying to improve exceptions and backtraces

Browse source 
When using knots utilities.
This commit is contained in:
Christopher Baines 2025-02-03 15:44:51 +00:00
parent bddc6c04ad
commit 893299ba24
3 changed files with 125 additions and 40 deletions
Download patch file Download diff file Expand all files Collapse all files

80
knots/parallelism.scm
View file

@ -21,9 +21,11 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-71)
#:use-module (ice-9 match)
#:use-module (ice-9 control)
#:use-module (fibers)
#:use-module (fibers channels)
#:use-module (fibers operations)
#:use-module (knots)
#:export (fibers-batch-map
fibers-map
@ -41,19 +43,23 @@
(let ((reply (make-channel)))
(spawn-fiber
(lambda ()
(with-exception-handler
(lambda (exn)
(put-message reply (cons 'exception exn)))
(lambda ()
(call-with-values
(lambda ()
(with-throw-handler #t
thunk
(lambda _
(backtrace))))
(lambda vals
(put-message reply vals))))
#:unwind? #t))
(call-with-escape-continuation
(lambda (return)
(with-exception-handler
(lambda (exn)
(match (fluid-ref %stacks)
((stack-tag . prompt-tag)
(let ((stack (make-stack #t
0 prompt-tag
0 (and prompt-tag 1))))
(put-message reply (list 'exception exn stack)))))
(return))
(lambda ()
(call-with-values
(lambda ()
(start-stack #t (thunk)))
(lambda vals
(put-message reply vals))))))))
#:parallel? #t)
reply))
@ -62,8 +68,13 @@
reply-channels)))
(map
(match-lambda
(('exception . exn)
(raise-exception exn))
(('exception exn stack)
(let ((knots-exn
(make-knots-exception stack)))
(raise-exception
(make-exception
knots-exn
exn))))
(result
(apply values result)))
responses)))
@ -234,21 +245,22 @@
(get-message channel))))
(put-message
reply-channel
(with-exception-handler
(lambda (exn)
(cons 'exception exn))
(lambda ()
(with-throw-handler #t
(lambda ()
(call-with-values
(lambda ()
(apply proc args))
(lambda vals
(cons 'result vals))))
(lambda args
(when (apply show-backtrace? args)
(backtrace)))))
#:unwind? #t)))))
(call-with-escape-continuation
(lambda (return)
(with-exception-handler
(lambda (exn)
(match (fluid-ref %stacks)
((stack-tag . prompt-tag)
(let ((stack (make-stack #t
0 prompt-tag
0 (and prompt-tag 1))))
(return (list 'exception exn stack))))))
(lambda ()
(call-with-values
(lambda ()
(start-stack #t (apply proc args)))
(lambda vals
(cons 'result vals)))))))))))
#:parallel? #t))
(iota parallelism))
@ -257,4 +269,10 @@
(put-message channel (cons reply-channel args))
(match (get-message reply-channel)
(('result . vals) (apply values vals))
(('exception . exn) (raise-exception exn)))))))
(('exception exn stack)
(let ((knots-exn
(make-knots-exception stack)))
(raise-exception
(make-exception
knots-exn
exn)))))))))

13
knots/web-server.scm
View file

@ -35,6 +35,7 @@
#:use-module (web http)
#:use-module (web request)
#:use-module (web response)
#:use-module (knots)
#:use-module (knots timeout)
#:use-module (knots non-blocking)
#:export (run-knots-web-server
@ -203,8 +204,7 @@ on the procedure being called at any particular time."
#f)
(define (default-exception-handler exn request)
(let* ((stack (make-stack #t))
(error-string
(let* ((error-string
(call-with-output-string
(lambda (port)
(simple-format
@ -212,12 +212,9 @@ on the procedure being called at any particular time."
"exception when processing: ~A ~A\n"
(request-method request)
(uri-path (request-uri request)))
(display-backtrace stack port 4)
(print-exception
port
(stack-ref stack 4)
'%exception
(list exn))))))
(print-backtrace-and-exception/knots
exn
#:port port)))))
(display error-string
(current-error-port)))