mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

narrowing stacks to prompts; backtrace shows frames from start-stack

Browse source 
* libguile/stacks.c (scm_sys_stacks): New global variable, moved here
  from boot-9.scm.
  (scm_init_stacks): Define scm_sys_stacks to %stacks.
  (stack_depth): Remove narrowing by frame pointer.
  (find_prompt): New helper.
  (narrow_stack): Clean up a bit, and allow narrowing by prompt tag.
  (scm_make_stack): Update docs, and use scm_stack_id to get the stack
  id.
  (scm_stack_id): The current stack id may be fetched as the cdar of
  %stacks.
  (stack_id_with_fp): Remove helper.

* module/ice-9/boot-9.scm (%start-stack): Fix indentation.
  (%stacks): Remove definition, it's in stacks.c now.
  (default-pre-unwind-handler): Narrow by another frame.
  (save-stack): Remove special handling for certain stack ids, as it is
  often possible that the function isn't on the stack -- in the
  interpreter, or after a tail call. Better to narrow by prompt ids.

* module/system/vm/debug.scm (print-frames): Change to operate on a
  vector of frames.
  (run-debugger): Change to receive a vector of frames. The debugger
  also has the full stack, so it can re-narrow (or widen) to get the
  whole stack, if the user wants.
  (stack->vector): New helper.
  (debug-pre-unwind-handler): Narrow by more frames, and to the most
  recent start-stack invocation. Adapt to run-debugger change.
This commit is contained in:
Andy Wingo 2010-03-13 21:03:06 +01:00
parent 01c0082fae
commit 06dcb9dfb6
3 changed files with 227 additions and 173 deletions
Download patch file Download diff file Expand all files Collapse all files

181
libguile/stacks.c
View file

@ -24,6 +24,7 @@
#endif #endif
#include "libguile/_scm.h" #include "libguile/_scm.h"
#include "libguile/control.h"
#include "libguile/eval.h" #include "libguile/eval.h"
#include "libguile/debug.h" #include "libguile/debug.h"
#include "libguile/continuations.h" #include "libguile/continuations.h"
@ -41,6 +42,8 @@
#include "libguile/private-options.h" #include "libguile/private-options.h"
static SCM scm_sys_stacks;
/* {Stacks} /* {Stacks}
* *
@ -59,17 +62,14 @@
static SCM stack_id_with_fp (SCM frame, SCM **fp);
/* Count number of debug info frames on a stack, beginning with FRAME. /* Count number of debug info frames on a stack, beginning with FRAME.
*/ */
static long static long
stack_depth (SCM frame, SCM *fp) stack_depth (SCM frame)
{ {
long n = 0; long n = 0;
/* count frames, skipping boot frames */ /* count frames, skipping boot frames */
for (; scm_is_true (frame) && SCM_VM_FRAME_FP (frame) > fp; for (; scm_is_true (frame); frame = scm_frame_previous (frame))
frame = scm_frame_previous (frame))
++n; ++n;
return n; return n;
} }
@ -95,6 +95,21 @@ stack_depth (SCM frame, SCM *fp)
* encountered. * encountered.
*/ */
static SCM
find_prompt (SCM key)
{
SCM winds;
for (winds = scm_i_dynwinds (); scm_is_pair (winds); winds = scm_cdr (winds))
{
SCM elt = scm_car (winds);
if (SCM_PROMPT_P (elt) && SCM_PROMPT_TAG (elt) == key)
return elt;
}
scm_misc_error ("make-stack", "Prompt tag not found while narrowing stack",
scm_list_1 (key));
return SCM_BOOL_F; /* not reached */
}
static void static void
narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key) narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
{ {
@ -105,16 +120,7 @@ narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
frame = SCM_STACK_FRAME (stack); frame = SCM_STACK_FRAME (stack);
/* Cut inner part. */ /* Cut inner part. */
if (scm_is_eq (inner_key, SCM_BOOL_T)) if (scm_is_true (scm_procedure_p (inner_key)))
{
/* Cut specified number of frames. */
for (; inner && len; --inner)
{
len--;
frame = scm_frame_previous (frame);
}
}
else
{ {
/* Cut until the given procedure is seen. */ /* Cut until the given procedure is seen. */
for (; inner && len ; --inner) for (; inner && len ; --inner)
@ -126,17 +132,63 @@ narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
break; break;
} }
} }
else if (scm_is_symbol (inner_key))
{
/* Cut until the given prompt tag is seen. FIXME, assumes prompt tags are
symbols. */
SCM prompt = find_prompt (inner_key);
for (; len; len--, frame = scm_frame_previous (frame))
if (SCM_PROMPT_REGISTERS (prompt)->fp
== SCM_VM_FRAME_FP (frame) - SCM_VM_FRAME_OFFSET (frame))
break;
}
else
{
/* Cut specified number of frames. */
for (; inner && len; --inner)
{
len--;
frame = scm_frame_previous (frame);
}
}
SCM_SET_STACK_LENGTH (stack, len); SCM_SET_STACK_LENGTH (stack, len);
SCM_SET_STACK_FRAME (stack, frame); SCM_SET_STACK_FRAME (stack, frame);
/* Cut outer part. */ /* Cut outer part. */
for (; outer && len ; --outer) if (scm_is_true (scm_procedure_p (outer_key)))
{ {
frame = scm_stack_ref (stack, scm_from_long (len - 1)); /* Cut until the given procedure is seen. */
len--; for (; outer && len ; --outer)
if (scm_is_eq (scm_frame_procedure (frame), outer_key)) {
break; frame = scm_stack_ref (stack, scm_from_long (len - 1));
len--;
if (scm_is_eq (scm_frame_procedure (frame), outer_key))
break;
}
}
else if (scm_is_symbol (outer_key))
{
/* Cut until the given prompt tag is seen. FIXME, assumes prompt tags are
symbols. */
SCM prompt = find_prompt (outer_key);
while (len)
{
frame = scm_stack_ref (stack, scm_from_long (len - 1));
len--;
if (SCM_PROMPT_REGISTERS (prompt)->fp
== SCM_VM_FRAME_FP (frame) - SCM_VM_FRAME_OFFSET (frame))
break;
}
}
else
{
/* Cut specified number of frames. */
for (; outer && len ; --outer)
{
frame = scm_stack_ref (stack, scm_from_long (len - 1));
len--;
}
} }
SCM_SET_STACK_LENGTH (stack, len); SCM_SET_STACK_LENGTH (stack, len);
@ -163,24 +215,33 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
"Create a new stack. If @var{obj} is @code{#t}, the current\n" "Create a new stack. If @var{obj} is @code{#t}, the current\n"
"evaluation stack is used for creating the stack frames,\n" "evaluation stack is used for creating the stack frames,\n"
"otherwise the frames are taken from @var{obj} (which must be\n" "otherwise the frames are taken from @var{obj} (which must be\n"
"either a debug object or a continuation).\n\n" "a continuation or a frame object).\n"
"\n"
"@var{args} should be a list containing any combination of\n" "@var{args} should be a list containing any combination of\n"
"integer, procedure and @code{#t} values.\n\n" "integer, procedure, prompt tag and @code{#t} values.\n"
"\n"
"These values specify various ways of cutting away uninteresting\n" "These values specify various ways of cutting away uninteresting\n"
"stack frames from the top and bottom of the stack that\n" "stack frames from the top and bottom of the stack that\n"
"@code{make-stack} returns. They come in pairs like this:\n" "@code{make-stack} returns. They come in pairs like this:\n"
"@code{(@var{inner_cut_1} @var{outer_cut_1} @var{inner_cut_2}\n" "@code{(@var{inner_cut_1} @var{outer_cut_1} @var{inner_cut_2}\n"
"@var{outer_cut_2} @dots{})}.\n\n" "@var{outer_cut_2} @dots{})}.\n"
"Each @var{inner_cut_N} can be @code{#t}, an integer, or a\n" "\n"
"procedure. @code{#t} means to cut away all frames up to but\n" "Each @var{inner_cut_N} can be @code{#t}, an integer, a prompt\n"
"excluding the first user module frame. An integer means to cut\n" "tag, or a procedure. @code{#t} means to cut away all frames up\n"
"away exactly that number of frames. A procedure means to cut\n" "to but excluding the first user module frame. An integer means\n"
"away all frames up to but excluding the application frame whose\n" "to cut away exactly that number of frames. A prompt tag means\n"
"procedure matches the specified one.\n\n" "to cut away all frames that are inside a prompt with the given\n"
"Each @var{outer_cut_N} can be an integer or a procedure. An\n" "tag. A procedure means to cut away all frames up to but\n"
"integer means to cut away that number of frames. A procedure\n" "excluding the application frame whose procedure matches the\n"
"means to cut away frames down to but excluding the application\n" "specified one.\n"
"frame whose procedure matches the specified one.\n\n" "\n"
"Each @var{outer_cut_N} can be an integer, a prompt tag, or a\n"
"procedure. An integer means to cut away that number of frames.\n"
"A prompt tag means to cut away all frames that are outside a\n"
"prompt with the given tag. A procedure means to cut away\n"
"frames down to but excluding the application frame whose\n"
"procedure matches the specified one.\n"
"\n"
"If the @var{outer_cut_N} of the last pair is missing, it is\n" "If the @var{outer_cut_N} of the last pair is missing, it is\n"
"taken as 0.") "taken as 0.")
#define FUNC_NAME s_scm_make_stack #define FUNC_NAME s_scm_make_stack
@ -189,7 +250,6 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
int maxp; int maxp;
SCM frame; SCM frame;
SCM stack; SCM stack;
SCM id, *id_fp;
SCM inner_cut, outer_cut; SCM inner_cut, outer_cut;
/* Extract a pointer to the innermost frame of whatever object /* Extract a pointer to the innermost frame of whatever object
@ -209,6 +269,8 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
else if (SCM_VM_FRAME_P (obj)) else if (SCM_VM_FRAME_P (obj))
frame = obj; frame = obj;
else if (SCM_CONTINUATIONP (obj)) else if (SCM_CONTINUATIONP (obj))
/* FIXME: Narrowing to prompt tags should narrow with respect to the prompts
that were in place when the continuation was captured. */
frame = scm_i_continuation_to_frame (obj); frame = scm_i_continuation_to_frame (obj);
else else
{ {
@ -224,20 +286,16 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
if (scm_is_false (frame)) if (scm_is_false (frame))
return SCM_BOOL_F; return SCM_BOOL_F;
/* Get ID of the stack corresponding to the given frame. */
id = stack_id_with_fp (frame, &id_fp);
/* Count number of frames. Also get stack id tag and check whether /* Count number of frames. Also get stack id tag and check whether
there are more stackframes than we want to record there are more stackframes than we want to record
(SCM_BACKTRACE_MAXDEPTH). */ (SCM_BACKTRACE_MAXDEPTH). */
id = SCM_BOOL_F;
maxp = 0; maxp = 0;
n = stack_depth (frame, id_fp); n = stack_depth (frame);
/* Make the stack object. */ /* Make the stack object. */
stack = scm_make_struct (scm_stack_type, SCM_INUM0, SCM_EOL); stack = scm_make_struct (scm_stack_type, SCM_INUM0, SCM_EOL);
SCM_SET_STACK_LENGTH (stack, n); SCM_SET_STACK_LENGTH (stack, n);
SCM_SET_STACK_ID (stack, id); SCM_SET_STACK_ID (stack, scm_stack_id (obj));
SCM_SET_STACK_FRAME (stack, frame); SCM_SET_STACK_FRAME (stack, frame);
/* Narrow the stack according to the arguments given to scm_make_stack. */ /* Narrow the stack according to the arguments given to scm_make_stack. */
@ -258,9 +316,9 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
narrow_stack (stack, narrow_stack (stack,
scm_is_integer (inner_cut) ? scm_to_int (inner_cut) : n, scm_is_integer (inner_cut) ? scm_to_int (inner_cut) : n,
scm_is_integer (inner_cut) ? 0 : inner_cut, scm_is_integer (inner_cut) ? SCM_BOOL_T : inner_cut,
scm_is_integer (outer_cut) ? scm_to_int (outer_cut) : n, scm_is_integer (outer_cut) ? scm_to_int (outer_cut) : n,
scm_is_integer (outer_cut) ? 0 : outer_cut); scm_is_integer (outer_cut) ? SCM_BOOL_T : outer_cut);
n = SCM_STACK_LENGTH (stack); n = SCM_STACK_LENGTH (stack);
} }
@ -277,44 +335,26 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
"Return the identifier given to @var{stack} by @code{start-stack}.") "Return the identifier given to @var{stack} by @code{start-stack}.")
#define FUNC_NAME s_scm_stack_id #define FUNC_NAME s_scm_stack_id
{ {
SCM frame, *id_fp; if (scm_is_eq (stack, SCM_BOOL_T)
/* FIXME: frame case assumes frame still live on the stack, and no
if (scm_is_eq (stack, SCM_BOOL_T)) intervening start-stack. Hmm... */
|| SCM_VM_FRAME_P (stack))
{ {
struct scm_vm *vp = SCM_VM_DATA (scm_the_vm ()); /* Fetch most recent start-stack tag. */
frame = scm_c_make_frame (scm_the_vm (), vp->fp, vp->sp, vp->ip, 0); SCM stacks = scm_fluid_ref (scm_sys_stacks);
return scm_is_pair (stacks) ? scm_caar (stacks) : SCM_BOOL_F;
} }
else if (SCM_VM_FRAME_P (stack))
frame = stack;
else if (SCM_CONTINUATIONP (stack)) else if (SCM_CONTINUATIONP (stack))
frame = scm_i_continuation_to_frame (stack); /* FIXME: implement me */
return SCM_BOOL_F;
else else
{ {
SCM_WRONG_TYPE_ARG (SCM_ARG1, stack); SCM_WRONG_TYPE_ARG (SCM_ARG1, stack);
/* not reached */ /* not reached */
} }
return stack_id_with_fp (frame, &id_fp);
} }
#undef FUNC_NAME #undef FUNC_NAME
static SCM
stack_id_with_fp (SCM frame, SCM **fp)
{
SCM holder = SCM_VM_FRAME_STACK_HOLDER (frame);
if (SCM_VM_CONT_P (holder))
{
*fp = NULL;
return SCM_BOOL_F;
}
else
{
*fp = NULL;
return SCM_BOOL_F;
}
}
SCM_DEFINE (scm_stack_ref, "stack-ref", 2, 0, 0, SCM_DEFINE (scm_stack_ref, "stack-ref", 2, 0, 0,
(SCM stack, SCM index), (SCM stack, SCM index),
"Return the @var{index}'th frame from @var{stack}.") "Return the @var{index}'th frame from @var{stack}.")
@ -347,6 +387,9 @@ SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0,
void void
scm_init_stacks () scm_init_stacks ()
{ {
scm_sys_stacks = scm_make_fluid ();
scm_c_define ("%stacks", scm_sys_stacks);
scm_stack_type = scm_make_vtable (scm_from_locale_string (SCM_STACK_LAYOUT), scm_stack_type = scm_make_vtable (scm_from_locale_string (SCM_STACK_LAYOUT),
SCM_UNDEFINED); SCM_UNDEFINED);
scm_set_struct_vtable_name_x (scm_stack_type, scm_set_struct_vtable_name_x (scm_stack_type,

40
module/ice-9/boot-9.scm
View file

@ -1030,7 +1030,7 @@ If there is no handler at all, Guile prints an error and then exits."
;;; {The interpreter stack} ;;; {The interpreter stack}
;;; ;;;
(define %stacks (make-fluid)) ;; %stacks defined in stacks.c
(define (%start-stack tag thunk) (define (%start-stack tag thunk)
(let ((prompt-tag (make-prompt-tag "start-stack"))) (let ((prompt-tag (make-prompt-tag "start-stack")))
(call-with-prompt (call-with-prompt
@ -2742,7 +2742,8 @@ module '(ice-9 q) '(make-q q-length))}."
(define (set-repl-prompt! v) (set! scm-repl-prompt v)) (define (set-repl-prompt! v) (set! scm-repl-prompt v))
(define (default-pre-unwind-handler key . args) (define (default-pre-unwind-handler key . args)
(save-stack 1) ;; Narrow by two more frames: this one, and the throw handler.
(save-stack 2)
(apply throw key args)) (apply throw key args))
(begin-deprecated (begin-deprecated
@ -2839,28 +2840,25 @@ module '(ice-9 q) '(make-q q-length))}."
;;(define the-last-stack (make-fluid)) Defined by scm_init_backtrace () ;;(define the-last-stack (make-fluid)) Defined by scm_init_backtrace ()
(define before-signal-stack (make-fluid)) (define before-signal-stack (make-fluid))
;; FIXME: stack-saved? is broken in the presence of threads.
(define stack-saved? #f) (define stack-saved? #f)
(define (save-stack . narrowing) (define (save-stack . narrowing)
(or stack-saved? (if (not stack-saved?)
(cond ((not (memq 'debug (debug-options-interface))) (begin
(fluid-set! the-last-stack #f) (let ((stacks (fluid-ref %stacks)))
(set! stack-saved? #t)) (fluid-set! the-last-stack
(else ;; (make-stack obj inner outer inner outer ...)
(fluid-set! ;;
the-last-stack ;; In this case, cut away the make-stack frame, the
(case (stack-id #t) ;; save-stack frame, and then narrow as specified by the
((repl-stack) ;; user, delimited by the nearest start-stack invocation,
(apply make-stack #t save-stack primitive-eval #t 0 narrowing)) ;; if any.
((load-stack) (apply make-stack #t
(apply make-stack #t save-stack 0 #t 0 narrowing)) 2
((#t) (if (pair? stacks) (cdar stacks) 0)
(apply make-stack #t save-stack 0 1 narrowing)) narrowing)))
(else (set! stack-saved? #t))))
(let ((id (stack-id #t)))
(and (procedure? id)
(apply make-stack #t save-stack id #t 0 narrowing))))))
(set! stack-saved? #t)))))
(define before-error-hook (make-hook)) (define before-error-hook (make-hook))
(define after-error-hook (make-hook)) (define after-error-hook (make-hook))

179
module/system/vm/debug.scm
View file

@ -96,40 +96,34 @@
x)))) x))))
(frame-bindings frame)))))) (frame-bindings frame))))))
(define* (collect-frames frame #:key count) (define* (print-frames frames
(cond #:optional (port (current-output-port))
((not count) #:key (width 72) (full? #f) (forward? #f) count)
(let lp ((frame frame) (out '())) (let* ((len (vector-length frames))
(if (not frame) (lower-idx (if (or (not count) (positive? count))
out 0
(lp (frame-previous frame) (cons frame out))))) (max 0 (+ len count))))
;; should also have a from-end option, either via negative count or (upper-idx (if (and count (negative? count))
;; another kwarg (1- len)
((>= count 0) (1- (if count (min count len) len))))
(let lp ((frame frame) (out '()) (count count)) (inc (if forward? 1 -1)))
(if (or (not frame) (zero? count)) (let lp ((i (if forward? lower-idx upper-idx))
out (last-file ""))
(lp (frame-previous frame) (cons frame out) (1- count))))))) (if (<= lower-idx i upper-idx)
(let* ((frame (vector-ref frames i))
(define* (print-frames frames #:optional (port (current-output-port)) (source (frame-source frame))
#:key (start-index (1- (length frames))) (width 72) (file (and source
(full? #f)) (or (source:file source)
(let lp ((frames frames) (i start-index) (last-file "")) "current input")))
(if (pair? frames) (line (and=> source source:line)))
(let* ((frame (car frames)) (if (and file (not (equal? file last-file)))
(source (frame-source frame)) (format port "~&In ~a:~&" file))
(file (and source (format port "~:[~*~6_~;~5d:~]~3d ~v:@y~%" line line
(or (source:file source) i width (frame-call-representation frame))
"current input"))) (if full?
(line (and=> source source:line))) (print-locals frame #:width width
(if (and file (not (equal? file last-file))) #:per-line-prefix " "))
(format port "~&In ~a:~&" file)) (lp (+ i inc) (or file last-file)))))))
(format port "~:[~*~6_~;~5d:~]~3d ~v:@y~%" line line
i width (frame-call-representation frame))
(if full?
(print-locals frame #:width width
#:per-line-prefix " "))
(lp (cdr frames) (1- i) (or file last-file))))))
;;; ;;;
@ -150,31 +144,22 @@
(set! (prop vm) debugger) (set! (prop vm) debugger)
debugger))))) debugger)))))
(define* (run-debugger frame #:optional (vm (the-vm))) (define* (run-debugger stack frames i #:optional (vm (the-vm)))
(let* ((db (vm-debugger vm)) (let* ((db (vm-debugger vm))
(level (debugger-level db))) (level (debugger-level db)))
(dynamic-wind (dynamic-wind
(lambda () (set! (debugger-level db) (1+ level))) (lambda () (set! (debugger-level db) (1+ level)))
(lambda () (debugger-repl db frame)) (lambda () (debugger-repl db stack frames i))
(lambda () (set! (debugger-level db) level))))) (lambda () (set! (debugger-level db) level)))))
(define (debugger-repl db frame) (define (debugger-repl db stack frames index)
(let ((top frame) (let ((top (vector-ref frames 0))
(cur frame) (cur (vector-ref frames index))
(index 0)
(level (debugger-level db)) (level (debugger-level db))
(last #f)) (last #f))
(define (frame-index frame)
(let lp ((idx 0) (walk top))
(if (= (frame-return-address frame) (frame-return-address walk))
idx
(lp (1+ idx) (frame-previous walk)))))
(define (frame-at-index idx) (define (frame-at-index idx)
(let lp ((idx idx) (walk top)) (and (< idx (vector-length frames))
(cond (vector-ref frames idx)))
((not walk) #f)
((zero? idx) walk)
(else (lp (1- idx) (frame-previous walk))))))
(define (show-frame) (define (show-frame)
;; #2 0x009600e0 in do_std_select (args=0xbfffd9e0) at threads.c:1668 ;; #2 0x009600e0 in do_std_select (args=0xbfffd9e0) at threads.c:1668
;; 1668 select (select_args->nfds, ;; 1668 select (select_args->nfds,
@ -214,44 +199,51 @@
(define-command ((commands backtrace bt) #:optional count (define-command ((commands backtrace bt) #:optional count
#:key (width 72) full?) #:key (width 72) full?)
"Print a backtrace of all stack frames, or innermost COUNT frames." "Print a backtrace of all stack frames, or innermost COUNT frames.
(print-frames (collect-frames top #:count count) If COUNT is negative, the last COUNT frames will be shown."
(print-frames frames
#:count count
#:width width #:width width
#:full? full?)) #:full? full?))
(define-command ((commands up) #:optional (count 1)) (define-command ((commands up) #:optional (count 1))
"Select and print stack frames that called this one. "Select and print stack frames that called this one.
An argument says how many frames up to go" An argument says how many frames up to go"
(if (or (not (integer? count)) (<= count 0)) (cond
(format #t "Invalid argument to `up': expected a positive integer for COUNT.~%") ((or (not (integer? count)) (<= count 0))
(let lp ((n count)) (format #t "Invalid argument to `up': expected a positive integer for COUNT.~%"))
(cond ((>= (+ count index) (vector-length frames))
((zero? n) (show-frame)) (cond
((frame-previous cur) ((= index (1- (vector-length frames)))
=> (lambda (new) (format #t "Already at outermost frame.\n"))
(set! cur new) (else
(set! index (1+ index)) (set! index (1- (vector-length frames)))
(lp (1- n)))) (set! cur (vector-ref frames index))
((= n count) (show-frame))))
(format #t "Already at outermost frame.\n")) (else
(else (set! index (+ count index))
(format #t "Reached outermost frame after walking ~a frames.\n" (set! cur (vector-ref frames index))
(- count n)) (show-frame))))
(show-frame))))))
(define-command ((commands down) #:optional (count 1)) (define-command ((commands down) #:optional (count 1))
"Select and print stack frames called by this one. "Select and print stack frames called by this one.
An argument says how many frames down to go" An argument says how many frames down to go"
(cond (cond
((or (not (integer? count)) (<= count 0)) ((or (not (integer? count)) (<= count 0))
(format #t "Invalid argument to `down': expected a positive integer for COUNT.~%")) (format #t "Invalid argument to `down': expected a positive integer for COUNT.~%"))
((= index 0) ((< (- index count) 0)
(format #t "Already at innermost frame.~%")) (cond
((zero? index)
(format #t "Already at innermost frame.\n"))
(else
(set! index 0)
(set! cur (vector-ref frames index))
(show-frame))))
(else (else
(set! index (max (- index count) 0)) (set! index (- index count))
(set! cur (frame-at-index index)) (set! cur (vector-ref frames index))
(show-frame)))) (show-frame))))
(define-command ((commands frame f) #:optional idx) (define-command ((commands frame f) #:optional idx)
"Show the selected frame. "Show the selected frame.
With an argument, select a frame by index, then show it." With an argument, select a frame by index, then show it."
@ -377,15 +369,36 @@ With an argument, select a frame by index, then show it."
;; hm, trace via reassigning global vars. tricksy. ;; hm, trace via reassigning global vars. tricksy.
;; (state associated with vm ?) ;; (state associated with vm ?)
(define (stack->vector stack)
(let* ((len (stack-length stack))
(v (make-vector len)))
(if (positive? len)
(let lp ((i 0) (frame (stack-ref stack 0)))
(if (< i len)
(begin
(vector-set! v i frame)
(lp (1+ i) (frame-previous frame))))))
v))
(define (debug-pre-unwind-handler key . args) (define (debug-pre-unwind-handler key . args)
(let ((stack (make-stack #t 2))) ;; Narrow the stack by three frames: make-stack, this one, and the throw
(pmatch args ;; handler.
((,subr ,msg ,args . ,rest) (cond
(format #t "Throw to key `~a':\n" key) ((make-stack #t 3) =>
(display-error stack (current-output-port) subr msg args rest)) (lambda (stack)
(else (pmatch args
(format #t "Throw to key `~a' with args `~s'." key args))) ((,subr ,msg ,args . ,rest)
(format #t "Entering the debugger. Type `bt' for a backtrace or `c' to continue.\n") (format #t "Throw to key `~a':\n" key)
(run-debugger (stack-ref stack 0))) (display-error stack (current-output-port) subr msg args rest))
(else
(format #t "Throw to key `~a' with args `~s'." key args)))
(format #t "Entering the debugger. Type `bt' for a backtrace or `c' to continue.\n")
(run-debugger stack
(stack->vector
;; by default, narrow to the most recent start-stack
(make-stack (stack-ref stack 0) 0
(and (pair? (fluid-ref %stacks))
(cdar (fluid-ref %stacks)))))
0))))
(save-stack debug-pre-unwind-handler) (save-stack debug-pre-unwind-handler)
(apply throw key args)) (apply throw key args))