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

72
knots.scm
View file

@ -1,11 +1,21 @@
(define-module (knots)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:use-module (ice-9 suspendable-ports)
#:use-module (fibers conditions)
#:use-module (system repl debug)
#:export (call-with-default-io-waiters
wait-when-system-clock-behind
call-with-sigint))
call-with-sigint
&knots-exception
make-knots-exception
knots-exception?
knots-exception-stack
print-backtrace-and-exception/knots))
(define (call-with-default-io-waiters thunk)
(parameterize
@ -37,3 +47,63 @@
(sigaction SIGINT (car handler) (cdr handler))
;; restore original C handler.
(sigaction SIGINT #f))))))
(define &knots-exception
(make-exception-type '&knots-exception
&exception
'(stack)))
(define make-knots-exception
(record-constructor &knots-exception))
(define knots-exception?
(record-predicate &knots-exception))
(define knots-exception-stack
(exception-accessor
&knots-exception
(record-accessor &knots-exception 'stack)))
(define* (print-backtrace-and-exception/knots
exn
#:key (port (current-error-port)))
(let* ((stack (match (fluid-ref %stacks)
((stack-tag . prompt-tag)
(make-stack #t
0 prompt-tag
0 (and prompt-tag 1)))))
(error-string
(call-with-output-string
(lambda (port)
(let ((knots-stacks
(map knots-exception-stack
(filter knots-exception?
(simple-exceptions exn)))))
(let ((stack-vec
(stack->vector stack)))
(print-frames (list->vector
(drop
(vector->list stack-vec)
6))
port
#:count (stack-length stack)))
(for-each
(lambda (stack)
(let ((stack-vec
(stack->vector stack)))
(print-frames (list->vector
(drop
(vector->list stack-vec)
3))
port
#:count (stack-length stack))))
knots-stacks)
(print-exception
port
(if (null? knots-stacks)
(stack-ref stack 1)
(stack-ref (last knots-stacks) 3))
'%exception
(list exn)))))))
(display error-string port)))

56
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 ()
(call-with-escape-continuation
(lambda (return)
(with-exception-handler
(lambda (exn)
(put-message reply (cons 'exception 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 ()
(with-throw-handler #t
thunk
(lambda _
(backtrace))))
(start-stack #t (thunk)))
(lambda vals
(put-message reply vals))))
#:unwind? #t))
(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
(call-with-escape-continuation
(lambda (return)
(with-exception-handler
(lambda (exn)
(cons 'exception exn))
(lambda ()
(with-throw-handler #t
(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 ()
(apply proc args))
(start-stack #t (apply proc args)))
(lambda vals
(cons 'result vals))))
(lambda args
(when (apply show-backtrace? args)
(backtrace)))))
#:unwind? #t)))))
(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)))