;;; PC thing might not be right.
;;;
;;; This code uses specials as a means of signallin, since there is still no
;;; clean and efficient way of signalling conditions.
;;;
;;;**********************************************************************
;;;
;;; Internal Stuff
;;;
;;;**********************************************************************
;;;Operations on function objects:
;;; (debug-function-arglist function) => lambda-list
;;; (debug-function-name function) => symbol or lambda list
;;; (debug-function-nargs) => integer
;;; (debug-function-has-rest-arg-p function) => {T,nil}
;;; (debug-function-local-count function) => number of locals used
;;; (debug-function-types function) => list of properties
;;;----------------------------------------------------------------------
;;;Pointers
;;; (cstack-pointer-valid-p pointer) => {T,nil}
;;; (bstack-pointer-valid-p pointer) => {t,nil}
;;; (pointer+ pointer offset) => pointer
;;; (pointer- next previous) => integer
;;;----------------------------------------------------------------------
;;;Pointer operations that signal
;;; (read-bstack pointer offset) => object
;;; (read-cstack pointer offset) => object
;;; (write-bstack pointer offset object) => ?
;;; (write-cstack pointer offset object) => ?
;;;Specials called:
;;; *debug-invalid-cs-pointer* (pointer)
;;; *debug-invalid-bs-pointer* (pointer)
;;; *debug-object-not-symbol*
;;;----------------------------------------------------------------------
;;;Stack-referencing operations
;;; (get-function pointer) => function object
;;; (get-previous-open pointer) => pointer
;;; (get-previous-active pointer) => pointer
;;; (guess-previous-frame-pointer pointer) => pointer
;;; (get-saved-binding pointer) => pointer
;;; (get-saved-pc pointer) => byte number in function object
;;;----------------------------------------------------------------------
;;;More interesting pointer things
;;; (frame-pointer-catch-p frame-pointer) => {t,nil}
;;; (frame-pointer-types frame-pointer next-frame) => list of properties
;;; (frame-pointer-active-p frame-pointer next-frame) => {T, nil}
;;; (frame-pointer-arguments frame-pointer next-pointer)
;;; => list of args
;;; (frame-pointer-print-prefix frame-pointer next-pointer)
;;; (frame-pointer-call frame-pointer next-pointer)
;;; => (<function-name> ...)
;;;**********************************************************************
;;;
;;; User-visible stuff, more or less
;;;
;;;**********************************************************************
;;;Debug-Filter:
;;;Creation
;;; (make-debug-filter options) => Debug-filter
;;; (copy-debug-filter filter) => Debug-filter
;;; (filter-hide-all) => Debug-filter
;;; (filter-show-all) => Debug-filter
;;;Specials
;;; *debug-filter*, *debug-hidden-functions*
;;;Alterations
;;; (debug-hide {function(s),package(s),type(s)} things)
;;; (debug-show {function(s),package(s),type(s)} things)
;;;Operations
;;; (frame-pointer-interesting-p frame-pointer next-pointer) => {T,nil}
;;;----------------------------------------------------------------------
;;;Debug-stacks
;;; (parse-stack &optional previous-stack) => stack
;;; (stack-valid-p stack) => {t,nil} (a guess)
;;; (stack-seq stack) => vector of frames
;;; (stack-level stack) => integer
;;; (stack-guess-previous-frame-pointer frame-pointer stack) => frame-pointer
;;; (stack-previous-guess stack) => frame-pointer
;;; (stack-cache-generation stack) => number
;;; (stack-invalidate-cache stack) => number
;;; (stack-frame-n stack n) => frame
;;;Calls *debug-no-such-frame* (number)
;;; (stack-bottom-frame stack) => frame
;;; (stack-bottom-pointer stack) => pointer
;;; (stack-top-pointer stack) => pointer
;;;----------------------------------------------------------------------
;;;Frames
;;; (debug-frame-p frame) => {t,nil}
;;; (frame-pointer frame) => control stack pointer
;;; (frame-number frame) => integer
;;; (frame-stack frame) => stack
;;; (frame-cache-generation frame) => integer
;;; (frame-interesting-p frame) => {T,nil}
;;; (frame-next-pointer frame) => pointer
;;; (frame-active-p frame) => {t,nil}
;;; (frame-function frame) => function object
;;;----------------------------------------------------------------------
;;;Frame movement
;;; (frame-real-next frame) => frame
;;; (frame-real-previous frame) => frame
;;; (frame-next frame) => frame
;;; (frame-next-active frame) => frame
;;; (frame-previous frame) => frame
;;; (frame-previous-active frame) => frame
;;; (frame-search function frame) => frame
;;; (frame-reverse-search function frame) => frame
;;;Calls *debug-bottom-of-stack*, *debug-top-of-stack*
;;;----------------------------------------------------------------------
;;;Things to do with your frame
;;; (frame-call frame) => (function arg1 ...) (cached)
;;; (frame-special symbol frame) => lisp object
;;;Calls *debug-unbound-special* (symbol)
;;; (frame-pc frame) => integer
;;; (frame-arg number frame) => lisp object
;;;Calls *debug-no-such-arg* (number frame)
;;; (frame-local-count frame) => integer
;;; (frame-local number frame) => lisp object
;;;Calls *debug-no-such-local* (number frame)
;;;Side-effecting:
;;; (frame-return values frame)
;;; returns or calls *debug-return-from-top-level*, *debug-frame-not-active*
;;; (frame)
;;;----------------------------------------------------------------------
(proclaim '(special *debug-invalid-cs-pointer* *debug-invalid-bs-pointer*
*debug-object-not-symbol* *debug-no-such-frame*
*debug-bottom-of-stack* *debug-top-of-stack*
*debug-unbound-special* *debug-unbound-lexical*
*debug-no-such-arg* *debug-no-such-local*
*debug-return-from-top-level* *debug-frame-not-active*))
;;;
;;; Function objects
;;;
(Defmacro debug-function-case (lexical-closure compiled-closure lambda
compiled)
`(cond ((listp fun)
(case (Car fun)
(%lexical-closure% ,lexical-closure)
(%compiled-closure% ,compiled-closure)
(lambda ,lambda)
(t (error "Unknown function type- ~A" fun))))
(t (unless (compiled-function-p fun)
(error "Unknown function type- ~A" fun))
,compiled)))
(defun debug-function-arglist (fun)
(debug-function-case (nth 1 (nth 1 fun))
(%primitive header-ref (nth 2 fun)
%function-arg-names-slot)
(nth 1 fun)
(%primitive header-ref fun %function-arg-names-slot)))
(defun debug-function-name (fun)
(debug-function-case (nth 1 fun)
(%primitive header-ref (nth 2 fun) %function-name-slot)
fun
(%primitive header-ref fun %function-name-slot)))
(defun debug-function-lambda-nargs (list)
(let ((res 0))
(dolist (arg list)
(case arg
(&optional)
((&rest &key &aux) (return-from debug-function-lambda-nargs res))
(t (incf res))))
res))
;;; Returns the number of arguments found on the stack, minus the rest arg.
(defun debug-function-nargs (fun)
(debug-function-case (debug-function-lambda-nargs
(debug-function-arglist fun))
(ldb %function-max-args-byte
(%primitive header-ref (nth 2 fun)
%function-max-args-slot))
(debug-function-lambda-nargs
(debug-function-arglist fun))
(ldb %function-max-args-byte
(%primitive header-ref fun
%function-max-args-slot))))
;;; If the function is compiled and has a rest arg, when the frame is activated
;;; the rest args get peeled off into a list and the list is smacked back in
;;; the right place. To get the original call, we must invert this process.
(defun debug-function-has-rest-arg-p (fun)
(and (compiled-function-p fun)
(plusp (ldb %function-rest-arg-byte
(%primitive header-ref fun %function-rest-arg-slot)))))
(Defun debug-function-local-count (fun)
"Returns the number of locals used by the function."
(cond ((compiled-function-p fun)
(ldb %function-locals-byte
(%primitive header-ref fun %function-locals-slot)))
(t 0)))
(Defun macro-lambda-p (lambda)
(and (listp lambda)
(eq (car lambda) '%compiled-closure%)
(setq lambda (nth 2 lambda)))
(cond ((compiled-function-p lambda)
(macro-function (debug-function-name lambda)))
(t (equal (debug-function-arglist lambda) '(**macroarg**)))))
;;; Names a macro or a special form.
(defun debug-function-types (fun)
(debug-function-case (if (macro-lambda-p fun)
'(lexical-closure uncompiled closure macro)
'(lexical-closure uncompiled closure))
(cond ((macro-lambda-p fun)
'(compiled-closure compiled closure macro))
((fexprp fun)
'(compiled-closure compiled closure fexpr))
(t '(compiled-closure compiled closure)))
(if (macro-lambda-p fun)
'(uncompiled-lambda uncompiled macro)
'(uncompiled-lambda uncompiled))
(cond ((macro-lambda-p fun)
'(compiled-macro-lambda compiled macro
compiled-macro))
((fexprp fun)
'(special-form fexpr compiled))
(t '(compiled-lambda compiled)))))
;;;
;;; Operations on integerized stack pointers
;;;
(Defun pointer+ (pointer offset)
(+ pointer (* offset %stack-increment)))
(defun pointer- (next previous)
(truncate (- next previous) %stack-increment))
(defconstant %debug-cstack-bottom (pointer+ #x2000000 1))
(defconstant %debug-bstack-bottom #x4000000)
(defun cstack-pointer-valid-p (pointer)
(and (fixnump pointer)
(<= %debug-cstack-bottom pointer)
(< pointer (%sp-make-fixnum (%primitive current-stack-pointer)))
(let ((type (%primitive get-type
(%sp-read-control-stack
(%sp-make-misc pointer)))))
(or (= type %call-header-type)
(= type %catch-header-type)))))
(defun bstack-pointer-valid-p (pointer)
(and (fixnump pointer)
(<= %debug-bstack-bottom pointer)
(< pointer (%sp-make-fixnum (%primitive current-binding-pointer)))))
(Defun check-cstack-pointer (pointer offset)
(or (and (cstack-pointer-valid-p pointer)
(fixnump offset)
(not (minusp offset)))
(funcall *debug-invalid-cs-pointer* pointer)))
(defun check-bstack-pointer (pointer offset)
(or (and (bstack-pointer-valid-p pointer)
(fixnump offset)
(or (zerop offset) (= 1 offset)))
(funcall *debug-invalid-bs-pointer* pointer)))
;;;
;;; Operations on pointers that signal
;;;
(Defun read-bstack (pointer offset)
"Read binding stack at pointer + integer offset."
(check-bstack-pointer pointer offset)
(%sp-read-binding-stack (%sp-make-misc (pointer+ pointer offset))))
(Defun write-bstack (pointer offset value)
"Write value onto binding stack at pointer + integer offset."
(check-bstack-pointer pointer offset)
(cond ((or (zerop offset)
(symbolp value))
(%primitive write-binding-stack
(%sp-make-misc (pointer+ pointer offset)) value))
(t (funcall *debug-object-not-symbol* value))))
(defun read-cstack (pointer offset)
"Read control stack at pointer + integer offset."
(check-cstack-pointer pointer offset)
(%sp-read-control-stack (%sp-make-misc (pointer+ pointer offset))))
(defun write-cstack (pointer offset value)
"Write value onto control stack at pointer + integer offset."
(check-cstack-pointer pointer offset)
(%sp-write-control-stack (%sp-make-misc (pointer+ pointer offset))
value))
;;;
;;; Frame-referencing things
;;;
(defun get-function (pointer)
(read-cstack pointer %frame-func-slot))
(defun get-previous-open (pointer)
(%sp-make-fixnum (read-cstack pointer %frame-prev-open-slot)))
(defun get-previous-active (pointer)
(%sp-make-fixnum (read-cstack pointer %frame-prev-active-slot)))
;;; Not sure if this is really necessary but it could be the only truly
;;; robust code you'll see.
(Defun guess-previous-frame-pointer (pointer)
(cond ((frame-pointer-catch-p pointer)
(let ((res (read-cstack pointer (1+ %frame-arg-start-slot))))
(if (null res) 0 (%sp-make-fixnum res))))
(t (max (get-previous-open pointer) (get-previous-active pointer)))))
(Defun get-saved-binding (pointer)
(%sp-make-fixnum (read-cstack pointer %frame-prev-binding-slot)))
(defun get-saved-pc (pointer)
(let ((thing (%sp-make-fixnum (read-cstack pointer %frame-pc-slot))))
(+ (* 2 (- (ldb (byte 16 0) thing) 4))
(ldb (byte 4 16) thing))))
;;;
;;; Operations on frame-pointers
;;;
;;; from {open,active,catch,one-value,multiple-values}
(defun frame-pointer-catch-p (Frame-pointer)
(= %catch-header-type
(%primitive get-type (read-cstack frame-pointer %frame-header-slot))))
(Defun frame-pointer-values-type (frame-pointer)
(let ((header (read-cstack frame-pointer %frame-header-slot)))
(cond ((ldb-test %frame-header-values-byte (%sp-make-fixnum header))
'multiple-values)
(T 'one-value))))
(Defun frame-pointer-types (frame-pointer next-frame)
(let* ((header (read-cstack frame-pointer %frame-header-slot))
(valuesp (ldb-test %frame-header-values-byte
(%sp-make-fixnum header))))
(cond ((frame-pointer-active-p frame-pointer next-frame)
(if valuesp '(active multiple-values)
'(active one-value)))
((= %catch-header-type (%primitive get-type header))
'(catch))
(valuesp '(open multiple-values))
(t '(open one-value)))))
(defun frame-pointer-active-p (frame-pointer next-frame)
(eq (get-previous-active next-frame) frame-pointer))
;;; Reads the supplied arguments off the stack, spreading the rest arg.
;;; We also spread if the function is a fexpr.
;;; We do the thing with the locals, rather than taking the argument
;;; count, because we may have a wrong-no-args frame.
(defun frame-pointer-arguments (frame-pointer next-pointer)
(let ((number (pointer- next-pointer frame-pointer)))
(do ((offset (cond ((frame-pointer-active-p frame-pointer next-pointer)
(- number
(1+ (debug-function-local-count
(get-function frame-pointer)))))
((frame-pointer-catch-p frame-pointer)
%frame-arg-start-slot)
(t number))
(1- offset))
(list nil (cons (read-cstack frame-pointer offset) list)))
((< offset %frame-arg-start-slot)
(let ((object (get-function frame-pointer)))
(cond ((not (and (frame-pointer-active-p frame-pointer next-pointer)
(or (debug-function-has-rest-arg-p object)
(and (compiled-function-p object)
(fexprp object)))))
list)
((null (Cdr list)) (car list))
(t (do ((list list (cdr list)))
((null (cddr list))
(setf (cdr list) (cadr list))))
list)))))))
(defun frame-pointer-print-prefix (frame-pointer next-pointer)
(terpri)
(cond ((frame-pointer-active-p frame-pointer next-pointer))
((frame-pointer-catch-p frame-pointer)
(princ "C"))
(t (princ "*"))))
(defun frame-pointer-call (Frame-pointer next-pointer)
(cons (debug-function-name (get-function frame-pointer))
(frame-pointer-arguments frame-pointer next-pointer)))
;;;
;;; Bug-Filter
;;;
(defparameter *debug-hidden-functions*
'(debug *eval %eval evalhook eval-as-prog eval-as-progn signal trace-call
step-command-loop internal-break-loop cerror-body error-body
%sp-internal-apply %sp-internal-error cerror block
default-condition-handler default-undefined-function-handler
default-unbound-variable-handler)
"The initial list of hidden functions for the debug-filter.
Use debug-hide and debug-show to modify the real filter on *debug-filter*.")
(defparameter *debug-hidden-frame-types*
'(catch open)
"The initial list of hidden frame types. Initially disables winning printing
of open frames.")
(defstruct (debug-filter (:conc-name nil))
(debug-hidden-functions *debug-hidden-functions*)
(debug-shown-functions nil)
(debug-hidden-packages nil)
(debug-shown-packages nil)
(debug-hidden-function-types nil)
(debug-shown-function-types nil)
(debug-hidden-frame-types *debug-hidden-frame-types*)
(debug-shown-frame-types nil))
(defvar *debug-filter* (make-debug-filter)
"Holds the filter object for debug and partially backtrace. Hidden
functions, function and frame types are not shown. Calls within
hidden packages are not shown (but calls into them are). Alter with
debug-hide and debug-show.")
(defun copy-debug-filter (f)
(cond ((null f) nil)
(t (make-debug-filter
:debug-hidden-functions (debug-hidden-functions f)
:debug-shown-functions (debug-shown-functions f)
:debug-hidden-packages (debug-hidden-packages f)
:debug-shown-packages (debug-shown-packages f)
:debug-hidden-function-types (debug-hidden-function-types f)
:debug-shown-function-types (debug-shown-function-types f)
:debug-hidden-frame-types (debug-hidden-frame-types f)
:debug-shown-frame-types (debug-shown-frame-types f)))))
(defun debug-filter-hide-all ()
(make-debug-filter
:debug-hidden-functions '(T)
:debug-hidden-packages '(T)
:debug-hidden-function-types '(T)
:debug-hidden-frame-types '(T)))
(defun debug-filter-show-all ()
(make-debug-filter
:debug-hidden-functions nil
:debug-hidden-frame-types nil))
(defmacro debug-print-list (hidden-p name where)
`(if ,(if hidden-p `(not (member t (,where filter)))
`(,where filter))
(format stream
,(concatenate 'string "~%" name
": ~:[<none>~;~:*~{~<~%~21,1T~1,72:; "
"~A~>~↑,~}.~]")
(,where filter))))
(defun describe-bug-filter (&optional (filter *debug-filter*)
(stream *standard-output*))
(declare (ignore ignore))
(princ "A debug filter." stream)
(debug-print-list T "Hidden functions" debug-hidden-functions)
(debug-print-list nil "Shown functions" debug-shown-functions)
(debug-print-list T "Hidden function types" debug-hidden-function-types)
(debug-print-list nil "Shown function types" debug-shown-function-types)
(debug-print-list T "Hidden frame types" debug-hidden-frame-types)
(debug-print-list nil "Shown frame types" debug-shown-frame-types)
(debug-print-list T "Hidden packages" debug-hidden-packages)
(debug-print-list nil "Shown packages" debug-shown-packages))
(eval-when (compile)
(defmacro check-debug-filter ()
'(or (debug-filter-p *debug-filter*)
(setq *debug-filter* (make-debug-filter)))))
;;; Hide and show
;;; Win gets added to, lose gets subtracted from.
(defmacro debug-filter-add (win lose things)
`(let ((losing (,lose *debug-filter*)))
(setf (,lose *debug-filter*)
(set-difference losing ,things))
(setf (,win *debug-filteR*)
(nconc (set-difference ,things losing) (,win *debug-filteR*)))))
(defmacro debug-hide (what-kind &optional which)
"Makes the specified things invisible in the debugger.
Kinds (not evaled) are (function(s) package(s) frame(s)/type(s)).
Which-ones is evaluated.
With no second argument, just returns the hidden ones."
`(debug-do-hide ',what-kind ,which))
(defun debug-do-hide (what-kind which)
"Does the work of debug-hide."
(check-debug-filter)
(if (and which
(inside-debugger-p))
(stack-invalidate-cache (frame-stack *debug-current-frame*)))
(let ((which (if (listp which) which (list which))))
(case what-kind
((frames types frame type)
(debug-filter-add debug-hidden-frame-types
debug-shown-frame-types which)
(debug-hidden-frame-types *debug-filteR*))
((function-types function-type)
(debug-filter-add debug-hidden-function-types
debug-shown-function-types which)
(debug-hidden-function-types *debug-filter*))
((functions function)
(debug-filter-add debug-hidden-functions
debug-shown-functions which)
(debug-hidden-functions *debug-filteR*))
((package packages)
(debug-filter-add debug-hidden-packages debug-shown-packages which)
(debug-hidden-packages *debug-filteR*))
(t (error "~A - unknown option to HIDE." what-kind)))))
(defmacro debug-show (what-kind which)
"Makes the specified things visible again in the debugger.
Kinds (not evaled) are (function(s) package(s) frames(s)/type(s)).
Types are (lambda compiled interpreted open active catch).
Which-ones is evaluated.
With no args, just displays the current filter.
With no third argument, just returns the hidden ones."
`(debug-do-show ',what-kind ,which))
(defun debug-do-show (what which)
"Does the work of debug-show."
(check-debug-filter)
(if (and which
(inside-debugger-p))
(stack-invalidate-cache (frame-stack *debug-current-frame*)))
(let ((which (if (listp which) which (list which))))
(case what
((frames types frame type)
(debug-filter-add debug-shown-frame-types
debug-hidden-frame-types which))
((function-types function-type)
(debug-filter-add debug-shown-function-types
debug-hidden-function-types which))
((functions function)
(debug-filter-add debug-shown-functions
debug-hidden-functions which))
((package packages)
(debug-filter-add debug-shown-packages debug-hidden-packages which))
(t (error "~A - unknown option to SHOW." what)))))
(defun frame-pointer-interesting-p (frame-pointer next-frame)
(let* ((frame-types (frame-pointer-types frame-pointer next-frame))
(function-object (get-function frame-pointer))
(function-types (Debug-function-types function-object))
(name (debug-function-name function-object))
(package (cond ((not (symbolp name)) nil)
((null (symbol-package name)) nil)
(t (package-name (symbol-package name))))))
(macrolet ((shown (show hide thing listp)
`(and (not (member T (,hide *debug-filter*)))
,(if listp
`(dolist (elt ,thing)
(if (member elt (,show *debug-filter*))
(return t)))
`(member ,thing (,show *debug-filter*)))))
(hidden (hide thing listp)
(if listp
`(dolist (elt ,thing)
(if (member elt (,hide *debug-filter*))
(return T)))
`(member ,thing (,hide *debug-filter*)))))
(or (shown debug-shown-function-types
debug-hidden-function-types function-types T)
(shown debug-shown-frame-types
debug-hidden-frame-types frame-types T)
(shown debug-shown-functions debug-hidden-functions name nil)
(shown debug-shown-packages debug-hidden-packages package nil)
(and (not (hidden debug-hidden-function-types function-types T))
(not (hidden debug-hidden-frame-types frame-types T))
(not (hidden debug-hidden-functions name nil))
(or (not (hidden debug-hidden-packages package nil))
(not (hidden debug-hidden-packages
(package-name
(symbol-package
(debug-function-name
(get-function
(get-previous-active frame-pointer)))))
nil))))))))
;;;
;;; Frame representation
;;;
(defstruct (debug-frame (:conc-name nil)
(:print-function print-debug-frame))
frame-number
frame-stack ;Convenience (may be used more later).
frame-pointer
(Frame-cache-generation 0)
(frame-cached-next nil)
(frame-cached-previous nil))
(defun print-debug-frame (frame stream ignore)
(declare (ignore ignore))
(format stream "#<DEBUG-FRAME #~D ~S>"
(frame-number frame)
(frame-pointer frame)))
(Defun frame-interesting-p (frame)
(frame-pointer-interesting-p (frame-pointer frame)
(FRame-next-pointer frame)))
;;;
;;; Debug-stack
;;;
;;; An object of the Debug-stack data type represents a section of the
;;; control stack, starting with the frame before that invoking
;;; parse-stack.
(defstruct (debug-stack (:conc-name nil)
(:print-function print-debug-stack))
(stack-seq (make-array 128 :initial-element nil :fill-pointer 0))
(stack-cache-generation 0)
(stack-level 0)
stack-previous-guess
stack-top-pointer
(stack-bottom-pointer (pointer+ #x2000000 1)))
(defun print-debug-stack (stack stream ignore)
(declare (ignore ignore))
(format stream "#<DEBUG-STACK ~S>" (stack-top-pointer stack)))
(Defun stack-guess-previous-frame-pointer (frame-pointer stack)
(let ((frame-guess (guess-previous-frame-pointer frame-pointer))
(stack-guess (stack-previous-guess stack)))
(cond ((> frame-guess stack-guess)
frame-guess)
(t (setf (stack-previous-guess stack) frame-guess)
stack-guess))))
(defun parse-stack (&optional stack (frames-back 1))
(let* ((bottom-pointer (if stack (stack-top-pointer stack)
#x2000000))
(this (%sp-make-fixnum (%primitive active-call-frame)))
(this (let ((res (guess-previous-frame-pointer this)))
(dotimes (i frames-back)
(setq res (guess-previous-frame-pointer res)))
res))
(guess (let ((res (%primitive active-catch-frame)))
(do ((res (if (null res) 0 (%sp-make-fixnum res))
(guess-previous-frame-pointer res)))
((< res this) res))))
(stack (make-debug-stack :stack-bottom-pointer bottom-pointer
:stack-top-pointer this
:stack-previous-guess guess
:stack-level
(if stack (1+ (stack-level stack)) 0)))
(previous (stack-guess-previous-frame-pointer this stack))
(frame (make-debug-frame :frame-number 0
:frame-stack stack
:frame-pointer previous)))
(vector-push frame (stack-seq stack))
stack))
(Defun stack-valid-p (stack)
(cstack-pointer-valid-p (frame-pointer (stack-frame-n stack 0))))
(defun stack-invalidate-cache (stack)
(incf (stack-cache-generation stack)))
(defun stack-frame-n (stack n)
(let* ((seq (stack-seq stack))
(len (length seq))
(bottom (Stack-bottom-pointer stack))
(*debug-bottom-of-stack*
#'(lambda () (funcall *debug-no-such-frame* n))))
(cond ((< n len) (elt seq n))
((do ((frame (elt seq (1- len)) (frame-real-previous frame)))
((= n (frame-number frame)) frame)
(cond ((<= (frame-pointer frame) bottom)
(return nil)))))
(t (funcall *debug-no-such-frame* n)))))
;;; This is a lose, but I don't feel like making it real at the moment.
(Defun stack-bottom-frame (stack)
(let ((*debug-no-such-frame*
#'(lambda (ignore)
(declare (ignore ignore))
(return-from stack-bottom-frame
(let ((seq (Stack-seq stack)))
(elt seq (1- (length seq))))))))
(stack-frame-n stack most-positive-fixnum)))
;;;;
;;; Debug-frames
;;;
;;; So we don't have to worry about the end case.
(defun frame-next-pointer (frame)
(if (zerop (Frame-number frame))
(stack-top-pointer (frame-stack frame))
(frame-pointer (frame-real-next frame))))
(Defun frame-active-p (frame)
(frame-pointer-active-p (Frame-pointer frame) (frame-next-pointer frame)))
(Defun frame-function (Frame)
(get-function (Frame-pointer frame)))
;;;
;;; Frame movement
;;;
(defun frame-real-next (frame)
(if (zerop (frame-number frame))
(funcall *debug-top-of-stack*)
(stack-frame-n (Frame-stack frame) (1- (frame-number frame)))))
(Defun frame-real-previous (frame)
(let* ((n (1+ (frame-number frame)))
(stack (frame-stack frame))
(seq (stack-seq stack)))
(cond ((< n (length seq)) (elt seq n))
(t (let ((pointer (stack-guess-previous-frame-pointer
(frame-pointer frame)
(frame-stack frame))))
(cond ((<= pointer (stack-bottom-pointer stack))
(funcall *debug-bottom-of-stack*))
(t (let ((frame (make-debug-frame
:frame-number n
:frame-stack stack
:frame-pointer pointer)))
(vector-push-extend frame seq 50)
frame))))))))
(defun frame-next (frame)
(cond ((and (= (frame-cache-generation frame)
(stack-cache-generation (frame-stack frame)))
(frame-cached-next frame)))
(t (setf (frame-cached-previous frame) nil)
(setf (frame-cache-generation frame)
(stack-cache-generation (frame-stack frame)))
(setf (frame-cached-next frame) nil) ;In case error.
(setf (frame-cached-next frame)
(do ((frame (frame-real-next frame)
(frame-real-next frame)))
((frame-interesting-p frame) frame))))))
(Defun frame-next-active (frame)
(do ((frame (frame-real-next frame) (frame-real-next frame)))
((frame-active-p frame) frame)))
(defun frame-previous (frame)
(cond ((and (= (frame-cache-generation frame)
(stack-cache-generation (frame-stack frame)))
(frame-cached-previous frame)))
(t (setf (frame-cached-next frame) nil)
(setf (frame-cache-generation frame)
(stack-cache-generation (frame-stack frame)))
(setf (frame-cached-previous frame) nil) ;In case error.
(setf (frame-cached-previous frame)
(do ((frame (frame-real-previous frame)
(frame-real-previous frame)))
((frame-interesting-p frame) frame))))))
(defun frame-previous-active (Frame)
(do ((frame (frame-real-next frame) (frame-real-previous frame)))
((frame-active-p frame) frame)))
(defun frame-search (function-obj frame)
(do ((frame (frame-real-previous frame) (frame-real-previous frame)))
((eq function-obj (frame-function frame)) frame)))
(defun frame-reverse-search (function-obj frame)
(do ((frame (frame-real-next frame) (frame-real-next frame)))
((eq function-obj (Frame-function frame)) frame)))
;;;
;;; More frame operations
;;;
(defun frame-call (frame)
(let ((pointer (Frame-pointer frame)))
(cons (debug-function-name (get-function pointer))
(frame-pointer-arguments pointer (frame-next-pointer frame)))))
(defun frame-special (symbol frame)
"Returns the value of the special in the current or specified frame's
context."
(do ((top-ptr (%sp-make-fixnum (%sp-current-binding-pointer)))
(ptr (get-saved-binding (frame-pointer frame))
(pointer+ ptr 2)))
((= ptr top-ptr) (%sp-get-value symbol))
(if (eq symbol (read-bstack ptr 1))
(let ((value (read-bstack ptr 0)))
(if (and (zerop (%sp-type value))
(zerop (%sp-make-fixnum value)))
(funcall *debug-unbound-special* symbol)
(return value))))
))
(Defun frame-pc (Frame)
(if (not (Frame-active-p frame))
(funcall *debug-frame-not-active* frame)
(get-saved-pc (frame-pointer (frame-next-active frame)))))
(Defun frame-arg (number frame)
(let* ((function (get-function (frame-pointer frame))))
(cond ((and (not (listp function))
(not (compiled-function-p function))
(let ((pointer (pointer+ (frame-pointer frame)
(+ number %frame-arg-start-slot))))
(cond ((>= pointer (frame-pointer (frame-real-next frame)))
(funcall *debug-no-such-arg* number frame))
(t (read-cstack pointer 0))))))
(t (let* ((nargs (debug-function-nargs function))
(rest (if (debug-function-has-rest-arg-p function)
(read-cstack (frame-pointer frame)
(+ nargs %frame-arg-start-slot))
nil)))
(cond ((and (fixnump number)
(< -1 number nargs))
(read-cstack (frame-pointer frame)
(+ number %frame-arg-start-slot)))
((and (<= nargs number)
(< number (+ (length rest) nargs)))
(nth (- number nargs) rest))
(t (funcall *debug-no-such-arg* number frame))))))))
(defun frame-local-count (frame)
(debug-function-local-count (get-function (frame-pointer frame))))
(defun frame-local (number frame)
(let ((locals (frame-local-count frame)))
(cond ((and (fixnump number)
(< -1 number locals))
(read-cstack (frame-pointer frame)
(+ number %frame-arg-start-slot
(debug-function-nargs (get-function
(frame-pointer frame))))))
(t (funcall *debug-no-such-local* number frame)))))
;;; Simulates a return from the specified stack frame.
;;; values is a list of values to return.
;;;
(Defun frame-return (values frame)
"Returns the values (if possible) of the expression from the current or
specified (active) frame."
(cond ((not (frame-pointer-active-p (frame-pointer frame)
(frame-next-pointer frame)))
(funcall *debug-frame-not-active* frame))
((or (zerop (get-previous-active (frame-pointer frame)))
(eq '%top-level (debug-function-name (frame-function frame))))
(funcall *debug-return-from-top-level*))
(t (let ((my-frame (%sp-make-fixnum (%primitive active-call-frame)))
(his-frame (frame-pointer frame)))
;; copy saved pointers from his frame into my frame.
;; then return value.
(write-cstack my-frame %frame-prev-active-slot
(read-cstack his-frame %frame-prev-active-slot))
(write-cstack my-frame %frame-prev-open-slot
(read-cstack his-frame %frame-prev-open-slot))
(write-cstack my-frame %frame-prev-binding-slot
(read-cstack his-frame %frame-prev-binding-slot))
(write-cstack my-frame %frame-PC-slot
(read-cstack his-frame %frame-PC-slot))
(values-list values)))))