mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
narrowing stacks to prompts; backtrace shows frames from start-stack
* 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
parent
01c0082fae
commit
06dcb9dfb6
3 changed files with 227 additions and 173 deletions
|
|
@ -24,6 +24,7 @@
|
|||
#endif
|
||||
|
||||
#include "libguile/_scm.h"
|
||||
#include "libguile/control.h"
|
||||
#include "libguile/eval.h"
|
||||
#include "libguile/debug.h"
|
||||
#include "libguile/continuations.h"
|
||||
|
|
@ -41,6 +42,8 @@
|
|||
#include "libguile/private-options.h"
|
||||
|
||||
|
||||
static SCM scm_sys_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.
|
||||
*/
|
||||
static long
|
||||
stack_depth (SCM frame, SCM *fp)
|
||||
stack_depth (SCM frame)
|
||||
{
|
||||
long n = 0;
|
||||
/* count frames, skipping boot frames */
|
||||
for (; scm_is_true (frame) && SCM_VM_FRAME_FP (frame) > fp;
|
||||
frame = scm_frame_previous (frame))
|
||||
for (; scm_is_true (frame); frame = scm_frame_previous (frame))
|
||||
++n;
|
||||
return n;
|
||||
}
|
||||
|
|
@ -95,6 +95,21 @@ stack_depth (SCM frame, SCM *fp)
|
|||
* 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
|
||||
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);
|
||||
|
||||
/* Cut inner part. */
|
||||
if (scm_is_eq (inner_key, SCM_BOOL_T))
|
||||
{
|
||||
/* Cut specified number of frames. */
|
||||
for (; inner && len; --inner)
|
||||
{
|
||||
len--;
|
||||
frame = scm_frame_previous (frame);
|
||||
}
|
||||
}
|
||||
else
|
||||
if (scm_is_true (scm_procedure_p (inner_key)))
|
||||
{
|
||||
/* Cut until the given procedure is seen. */
|
||||
for (; inner && len ; --inner)
|
||||
|
|
@ -126,11 +132,33 @@ narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
|
|||
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_FRAME (stack, frame);
|
||||
|
||||
/* Cut outer part. */
|
||||
if (scm_is_true (scm_procedure_p (outer_key)))
|
||||
{
|
||||
/* Cut until the given procedure is seen. */
|
||||
for (; outer && len ; --outer)
|
||||
{
|
||||
frame = scm_stack_ref (stack, scm_from_long (len - 1));
|
||||
|
|
@ -138,6 +166,30 @@ narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
|
|||
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);
|
||||
}
|
||||
|
|
@ -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"
|
||||
"evaluation stack is used for creating the stack frames,\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"
|
||||
"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"
|
||||
"stack frames from the top and bottom of the stack that\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"
|
||||
"@var{outer_cut_2} @dots{})}.\n\n"
|
||||
"Each @var{inner_cut_N} can be @code{#t}, an integer, or a\n"
|
||||
"procedure. @code{#t} means to cut away all frames up to but\n"
|
||||
"excluding the first user module frame. An integer means to cut\n"
|
||||
"away exactly that number of frames. A procedure means to cut\n"
|
||||
"away all frames up to but excluding the application frame whose\n"
|
||||
"procedure matches the specified one.\n\n"
|
||||
"Each @var{outer_cut_N} can be an integer or a procedure. An\n"
|
||||
"integer means to cut away that number of frames. A procedure\n"
|
||||
"means to cut away frames down to but excluding the application\n"
|
||||
"frame whose procedure matches the specified one.\n\n"
|
||||
"@var{outer_cut_2} @dots{})}.\n"
|
||||
"\n"
|
||||
"Each @var{inner_cut_N} can be @code{#t}, an integer, a prompt\n"
|
||||
"tag, or a procedure. @code{#t} means to cut away all frames up\n"
|
||||
"to but excluding the first user module frame. An integer means\n"
|
||||
"to cut away exactly that number of frames. A prompt tag means\n"
|
||||
"to cut away all frames that are inside a prompt with the given\n"
|
||||
"tag. A procedure means to cut away all frames up to but\n"
|
||||
"excluding the application frame whose procedure matches the\n"
|
||||
"specified one.\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"
|
||||
"taken as 0.")
|
||||
#define FUNC_NAME s_scm_make_stack
|
||||
|
|
@ -189,7 +250,6 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
|
|||
int maxp;
|
||||
SCM frame;
|
||||
SCM stack;
|
||||
SCM id, *id_fp;
|
||||
SCM inner_cut, outer_cut;
|
||||
|
||||
/* 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))
|
||||
frame = 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);
|
||||
else
|
||||
{
|
||||
|
|
@ -224,20 +286,16 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
|
|||
if (scm_is_false (frame))
|
||||
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
|
||||
there are more stackframes than we want to record
|
||||
(SCM_BACKTRACE_MAXDEPTH). */
|
||||
id = SCM_BOOL_F;
|
||||
maxp = 0;
|
||||
n = stack_depth (frame, id_fp);
|
||||
n = stack_depth (frame);
|
||||
|
||||
/* Make the stack object. */
|
||||
stack = scm_make_struct (scm_stack_type, SCM_INUM0, SCM_EOL);
|
||||
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);
|
||||
|
||||
/* 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,
|
||||
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) ? 0 : outer_cut);
|
||||
scm_is_integer (outer_cut) ? SCM_BOOL_T : outer_cut);
|
||||
|
||||
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}.")
|
||||
#define FUNC_NAME s_scm_stack_id
|
||||
{
|
||||
SCM frame, *id_fp;
|
||||
|
||||
if (scm_is_eq (stack, SCM_BOOL_T))
|
||||
if (scm_is_eq (stack, SCM_BOOL_T)
|
||||
/* FIXME: frame case assumes frame still live on the stack, and no
|
||||
intervening start-stack. Hmm... */
|
||||
|| SCM_VM_FRAME_P (stack))
|
||||
{
|
||||
struct scm_vm *vp = SCM_VM_DATA (scm_the_vm ());
|
||||
frame = scm_c_make_frame (scm_the_vm (), vp->fp, vp->sp, vp->ip, 0);
|
||||
/* Fetch most recent start-stack tag. */
|
||||
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))
|
||||
frame = scm_i_continuation_to_frame (stack);
|
||||
/* FIXME: implement me */
|
||||
return SCM_BOOL_F;
|
||||
else
|
||||
{
|
||||
SCM_WRONG_TYPE_ARG (SCM_ARG1, stack);
|
||||
/* not reached */
|
||||
}
|
||||
|
||||
return stack_id_with_fp (frame, &id_fp);
|
||||
}
|
||||
#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 stack, SCM index),
|
||||
"Return the @var{index}'th frame from @var{stack}.")
|
||||
|
|
@ -347,6 +387,9 @@ SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0,
|
|||
void
|
||||
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_UNDEFINED);
|
||||
scm_set_struct_vtable_name_x (scm_stack_type,
|
||||
|
|
|
|||
|
|
@ -1030,7 +1030,7 @@ If there is no handler at all, Guile prints an error and then exits."
|
|||
;;; {The interpreter stack}
|
||||
;;;
|
||||
|
||||
(define %stacks (make-fluid))
|
||||
;; %stacks defined in stacks.c
|
||||
(define (%start-stack tag thunk)
|
||||
(let ((prompt-tag (make-prompt-tag "start-stack")))
|
||||
(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 (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))
|
||||
|
||||
(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 before-signal-stack (make-fluid))
|
||||
;; FIXME: stack-saved? is broken in the presence of threads.
|
||||
(define stack-saved? #f)
|
||||
|
||||
(define (save-stack . narrowing)
|
||||
(or stack-saved?
|
||||
(cond ((not (memq 'debug (debug-options-interface)))
|
||||
(fluid-set! the-last-stack #f)
|
||||
(set! stack-saved? #t))
|
||||
(else
|
||||
(fluid-set!
|
||||
the-last-stack
|
||||
(case (stack-id #t)
|
||||
((repl-stack)
|
||||
(apply make-stack #t save-stack primitive-eval #t 0 narrowing))
|
||||
((load-stack)
|
||||
(apply make-stack #t save-stack 0 #t 0 narrowing))
|
||||
((#t)
|
||||
(apply make-stack #t save-stack 0 1 narrowing))
|
||||
(else
|
||||
(let ((id (stack-id #t)))
|
||||
(and (procedure? id)
|
||||
(apply make-stack #t save-stack id #t 0 narrowing))))))
|
||||
(set! stack-saved? #t)))))
|
||||
(if (not stack-saved?)
|
||||
(begin
|
||||
(let ((stacks (fluid-ref %stacks)))
|
||||
(fluid-set! the-last-stack
|
||||
;; (make-stack obj inner outer inner outer ...)
|
||||
;;
|
||||
;; In this case, cut away the make-stack frame, the
|
||||
;; save-stack frame, and then narrow as specified by the
|
||||
;; user, delimited by the nearest start-stack invocation,
|
||||
;; if any.
|
||||
(apply make-stack #t
|
||||
2
|
||||
(if (pair? stacks) (cdar stacks) 0)
|
||||
narrowing)))
|
||||
(set! stack-saved? #t))))
|
||||
|
||||
(define before-error-hook (make-hook))
|
||||
(define after-error-hook (make-hook))
|
||||
|
|
|
|||
|
|
@ -96,27 +96,21 @@
|
|||
x))))
|
||||
(frame-bindings frame))))))
|
||||
|
||||
(define* (collect-frames frame #:key count)
|
||||
(cond
|
||||
((not count)
|
||||
(let lp ((frame frame) (out '()))
|
||||
(if (not frame)
|
||||
out
|
||||
(lp (frame-previous frame) (cons frame out)))))
|
||||
;; should also have a from-end option, either via negative count or
|
||||
;; another kwarg
|
||||
((>= count 0)
|
||||
(let lp ((frame frame) (out '()) (count count))
|
||||
(if (or (not frame) (zero? count))
|
||||
out
|
||||
(lp (frame-previous frame) (cons frame out) (1- count)))))))
|
||||
|
||||
(define* (print-frames frames #:optional (port (current-output-port))
|
||||
#:key (start-index (1- (length frames))) (width 72)
|
||||
(full? #f))
|
||||
(let lp ((frames frames) (i start-index) (last-file ""))
|
||||
(if (pair? frames)
|
||||
(let* ((frame (car frames))
|
||||
(define* (print-frames frames
|
||||
#:optional (port (current-output-port))
|
||||
#:key (width 72) (full? #f) (forward? #f) count)
|
||||
(let* ((len (vector-length frames))
|
||||
(lower-idx (if (or (not count) (positive? count))
|
||||
0
|
||||
(max 0 (+ len count))))
|
||||
(upper-idx (if (and count (negative? count))
|
||||
(1- len)
|
||||
(1- (if count (min count len) len))))
|
||||
(inc (if forward? 1 -1)))
|
||||
(let lp ((i (if forward? lower-idx upper-idx))
|
||||
(last-file ""))
|
||||
(if (<= lower-idx i upper-idx)
|
||||
(let* ((frame (vector-ref frames i))
|
||||
(source (frame-source frame))
|
||||
(file (and source
|
||||
(or (source:file source)
|
||||
|
|
@ -129,7 +123,7 @@
|
|||
(if full?
|
||||
(print-locals frame #:width width
|
||||
#:per-line-prefix " "))
|
||||
(lp (cdr frames) (1- i) (or file last-file))))))
|
||||
(lp (+ i inc) (or file last-file)))))))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
@ -150,31 +144,22 @@
|
|||
(set! (prop vm) 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))
|
||||
(level (debugger-level db)))
|
||||
(dynamic-wind
|
||||
(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)))))
|
||||
|
||||
(define (debugger-repl db frame)
|
||||
(let ((top frame)
|
||||
(cur frame)
|
||||
(index 0)
|
||||
(define (debugger-repl db stack frames index)
|
||||
(let ((top (vector-ref frames 0))
|
||||
(cur (vector-ref frames index))
|
||||
(level (debugger-level db))
|
||||
(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)
|
||||
(let lp ((idx idx) (walk top))
|
||||
(cond
|
||||
((not walk) #f)
|
||||
((zero? idx) walk)
|
||||
(else (lp (1- idx) (frame-previous walk))))))
|
||||
(and (< idx (vector-length frames))
|
||||
(vector-ref frames idx)))
|
||||
(define (show-frame)
|
||||
;; #2 0x009600e0 in do_std_select (args=0xbfffd9e0) at threads.c:1668
|
||||
;; 1668 select (select_args->nfds,
|
||||
|
|
@ -214,30 +199,31 @@
|
|||
|
||||
(define-command ((commands backtrace bt) #:optional count
|
||||
#:key (width 72) full?)
|
||||
"Print a backtrace of all stack frames, or innermost COUNT frames."
|
||||
(print-frames (collect-frames top #:count count)
|
||||
"Print a backtrace of all stack frames, or innermost COUNT frames.
|
||||
If COUNT is negative, the last COUNT frames will be shown."
|
||||
(print-frames frames
|
||||
#:count count
|
||||
#:width width
|
||||
#:full? full?))
|
||||
|
||||
(define-command ((commands up) #:optional (count 1))
|
||||
"Select and print stack frames that called this one.
|
||||
An argument says how many frames up to go"
|
||||
(if (or (not (integer? count)) (<= count 0))
|
||||
(format #t "Invalid argument to `up': expected a positive integer for COUNT.~%")
|
||||
(let lp ((n count))
|
||||
(cond
|
||||
((zero? n) (show-frame))
|
||||
((frame-previous cur)
|
||||
=> (lambda (new)
|
||||
(set! cur new)
|
||||
(set! index (1+ index))
|
||||
(lp (1- n))))
|
||||
((= n count)
|
||||
((or (not (integer? count)) (<= count 0))
|
||||
(format #t "Invalid argument to `up': expected a positive integer for COUNT.~%"))
|
||||
((>= (+ count index) (vector-length frames))
|
||||
(cond
|
||||
((= index (1- (vector-length frames)))
|
||||
(format #t "Already at outermost frame.\n"))
|
||||
(else
|
||||
(format #t "Reached outermost frame after walking ~a frames.\n"
|
||||
(- count n))
|
||||
(show-frame))))))
|
||||
(set! index (1- (vector-length frames)))
|
||||
(set! cur (vector-ref frames index))
|
||||
(show-frame))))
|
||||
(else
|
||||
(set! index (+ count index))
|
||||
(set! cur (vector-ref frames index))
|
||||
(show-frame))))
|
||||
|
||||
(define-command ((commands down) #:optional (count 1))
|
||||
"Select and print stack frames called by this one.
|
||||
|
|
@ -245,11 +231,17 @@ An argument says how many frames down to go"
|
|||
(cond
|
||||
((or (not (integer? count)) (<= count 0))
|
||||
(format #t "Invalid argument to `down': expected a positive integer for COUNT.~%"))
|
||||
((= index 0)
|
||||
(format #t "Already at innermost frame.~%"))
|
||||
((< (- index count) 0)
|
||||
(cond
|
||||
((zero? index)
|
||||
(format #t "Already at innermost frame.\n"))
|
||||
(else
|
||||
(set! index (max (- index count) 0))
|
||||
(set! cur (frame-at-index index))
|
||||
(set! index 0)
|
||||
(set! cur (vector-ref frames index))
|
||||
(show-frame))))
|
||||
(else
|
||||
(set! index (- index count))
|
||||
(set! cur (vector-ref frames index))
|
||||
(show-frame))))
|
||||
|
||||
(define-command ((commands frame f) #:optional idx)
|
||||
|
|
@ -377,8 +369,23 @@ With an argument, select a frame by index, then show it."
|
|||
;; hm, trace via reassigning global vars. tricksy.
|
||||
;; (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)
|
||||
(let ((stack (make-stack #t 2)))
|
||||
;; Narrow the stack by three frames: make-stack, this one, and the throw
|
||||
;; handler.
|
||||
(cond
|
||||
((make-stack #t 3) =>
|
||||
(lambda (stack)
|
||||
(pmatch args
|
||||
((,subr ,msg ,args . ,rest)
|
||||
(format #t "Throw to key `~a':\n" key)
|
||||
|
|
@ -386,6 +393,12 @@ With an argument, select a frame by index, then show it."
|
|||
(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-ref stack 0)))
|
||||
(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)
|
||||
(apply throw key args))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue