Christopher Baines
991a5f6961
Catch failures in the Guile code for printing backtraces, and print the partial backtrace, plus the backtrace of the exception that happened.
151 lines
4.7 KiB
Scheme
151 lines
4.7 KiB
Scheme
(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
|
|
|
|
&knots-exception
|
|
make-knots-exception
|
|
knots-exception?
|
|
knots-exception-stack
|
|
|
|
print-backtrace-and-exception/knots))
|
|
|
|
(define (call-with-default-io-waiters thunk)
|
|
(parameterize
|
|
((current-read-waiter (@@ (ice-9 suspendable-ports)
|
|
default-read-waiter))
|
|
(current-write-waiter (@@ (ice-9 suspendable-ports)
|
|
default-write-waiter)))
|
|
(thunk)))
|
|
|
|
(define (wait-when-system-clock-behind)
|
|
(let ((start-of-the-year-2000 946684800))
|
|
(while (< (current-time)
|
|
start-of-the-year-2000)
|
|
(simple-format (current-error-port)
|
|
"warning: system clock potentially behind, waiting\n")
|
|
(sleep 20))))
|
|
|
|
;; Copied from (fibers web server)
|
|
(define (call-with-sigint thunk cvar)
|
|
(let ((handler #f))
|
|
(dynamic-wind
|
|
(lambda ()
|
|
(set! handler
|
|
(sigaction SIGINT (lambda (sig) (signal-condition! cvar)))))
|
|
thunk
|
|
(lambda ()
|
|
(if handler
|
|
;; restore Scheme handler, SIG_IGN or SIG_DFL.
|
|
(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?
|
|
(exception-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)))
|
|
(define (get-string port stack)
|
|
(define stack-len
|
|
(stack-length stack))
|
|
|
|
(let ((knots-stacks
|
|
(map knots-exception-stack
|
|
(filter knots-exception?
|
|
(simple-exceptions exn)))))
|
|
|
|
(let* ((stack-vec
|
|
(stack->vector stack))
|
|
(stack-vec-length
|
|
(vector-length stack-vec)))
|
|
(print-frames (list->vector
|
|
(drop
|
|
(vector->list stack-vec)
|
|
(if (< stack-vec-length 5)
|
|
0
|
|
4)))
|
|
port
|
|
#:count (stack-length stack)))
|
|
(for-each
|
|
(lambda (stack)
|
|
(let* ((stack-vec
|
|
(stack->vector stack))
|
|
(stack-vec-length
|
|
(vector-length stack-vec)))
|
|
(print-frames (list->vector
|
|
(drop
|
|
(vector->list stack-vec)
|
|
(if (< stack-vec-length 4)
|
|
0
|
|
3)))
|
|
port
|
|
#:count (stack-length stack))))
|
|
knots-stacks)
|
|
(print-exception
|
|
port
|
|
(if (null? knots-stacks)
|
|
(stack-ref stack
|
|
(if (< stack-len 4)
|
|
stack-len
|
|
4))
|
|
(let* ((stack (last knots-stacks))
|
|
(stack-len (stack-length stack)))
|
|
(stack-ref stack
|
|
(if (< stack-len 3)
|
|
stack-len
|
|
3))))
|
|
'%exception
|
|
(list exn))))
|
|
|
|
(let* ((stack
|
|
(match (fluid-ref %stacks)
|
|
((stack-tag . prompt-tag)
|
|
(make-stack #t
|
|
0 prompt-tag
|
|
0 (and prompt-tag 1)))
|
|
(_
|
|
(make-stack #t))))
|
|
(string-port
|
|
(open-output-string))
|
|
(error-string
|
|
(with-exception-handler
|
|
(lambda (exn)
|
|
(display (get-output-string string-port)
|
|
port)
|
|
(close-output-port string-port)
|
|
(display "\n\n" port)
|
|
|
|
(backtrace port)
|
|
(simple-format
|
|
port
|
|
"\nexception in print-backtrace-and-exception/knots: ~A\n"
|
|
exn)
|
|
(raise-exception exn))
|
|
(lambda ()
|
|
(get-string string-port stack)
|
|
(let ((str (get-output-string string-port)))
|
|
(close-output-port string-port)
|
|
str)))))
|
|
(display error-string port)))
|