mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-16 00:30:21 +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

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}
;;;
(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))

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

@ -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))