From 06dcb9dfb663169ce612bca241e5438c73bfa5c6 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 13 Mar 2010 21:03:06 +0100 Subject: [PATCH 1/1] 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. --- libguile/stacks.c | 177 ++++++++++++++++++++++-------------- module/ice-9/boot-9.scm | 40 ++++----- module/system/vm/debug.scm | 179 ++++++++++++++++++++----------------- 3 files changed, 225 insertions(+), 171 deletions(-) diff --git a/libguile/stacks.c b/libguile/stacks.c index 431d6b1e2..a7ebda03a 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -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,25 +120,35 @@ 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; } } @@ -131,12 +156,39 @@ narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key) 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); @@ -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, diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 5c777f498..eca716358 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -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)) diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm index b3686c3aa..4c99469e4 100644 --- a/module/system/vm/debug.scm +++ b/module/system/vm/debug.scm @@ -96,40 +96,34 @@ 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))))))) ;;; @@ -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,44 +199,51 @@ (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." @@ -377,15 +369,36 @@ 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)) -- 2.20.1