#endif
#include "libguile/_scm.h"
+#include "libguile/control.h"
#include "libguile/eval.h"
#include "libguile/debug.h"
#include "libguile/continuations.h"
#include "libguile/private-options.h"
+static SCM scm_sys_stacks;
+
\f
/* {Stacks}
*
\f
-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;
}
* 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)
{
frame = SCM_STACK_FRAME (stack);
/* 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)
+ /* Cut until the given procedure is seen. */
+ for (; inner && len ; --inner)
{
+ SCM proc = scm_frame_procedure (frame);
len--;
frame = scm_frame_previous (frame);
+ if (scm_is_eq (proc, inner_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 until the given procedure is seen. */
- for (; inner && len ; --inner)
+ /* Cut specified number of frames. */
+ for (; inner && len; --inner)
{
- SCM proc = scm_frame_procedure (frame);
len--;
frame = scm_frame_previous (frame);
- if (scm_is_eq (proc, inner_key))
- break;
}
}
SCM_SET_STACK_FRAME (stack, frame);
/* 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));
- len--;
- if (scm_is_eq (scm_frame_procedure (frame), outer_key))
- break;
+ /* Cut until the given procedure is seen. */
+ for (; outer && len ; --outer)
+ {
+ 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);
"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
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
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
{
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. */
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);
}
"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}.")
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,
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))
- (source (frame-source frame))
- (file (and source
- (or (source:file source)
- "current input")))
- (line (and=> source source:line)))
- (if (and file (not (equal? file last-file)))
- (format port "~&In ~a:~&" 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))))))
+(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)
+ "current input")))
+ (line (and=> source source:line)))
+ (if (and file (not (equal? file last-file)))
+ (format port "~&In ~a:~&" 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 (+ i inc) (or file last-file)))))))
;;;
(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,
(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)
- (format #t "Already at outermost frame.\n"))
- (else
- (format #t "Reached outermost frame after walking ~a frames.\n"
- (- count n))
- (show-frame))))))
-
+ (cond
+ ((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
+ (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.
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 0)
+ (set! cur (vector-ref frames index))
+ (show-frame))))
(else
- (set! index (max (- index count) 0))
- (set! cur (frame-at-index index))
+ (set! index (- index count))
+ (set! cur (vector-ref frames index))
(show-frame))))
-
+
(define-command ((commands frame f) #:optional idx)
"Show the selected frame.
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)))
- (pmatch args
- ((,subr ,msg ,args . ,rest)
- (format #t "Throw to key `~a':\n" key)
- (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-ref stack 0)))
+ ;; 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)
+ (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)
(apply throw key args))
HCoop / bpt / guile.git / commitdiff