X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=e96f6717216a4c58f4a1c37e0887e585acbba8b3;hb=416152f084604094445a758ff399871132dff2bd;hp=13e80e8ea1963f9a4f81679b1ca12b9acded1c53;hpb=4f64f131a7bca59d0dc8be9e74d05a7645f27e67;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 13e80e8..e96f671 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -47,7 +47,6 @@ #!+sb-doc (:documentation "There is no usable debugging information available.") (:report (lambda (condition stream) - (declare (ignore condition)) (fresh-line stream) (format stream "no debug information available for ~S~%" @@ -187,13 +186,14 @@ ;;;; data structures created by the compiler. Whenever comments ;;;; preface an object or type with "compiler", they refer to the ;;;; internal compiler thing, not to the object or type with the same -;;;; name in the "DI" package. +;;;; name in the "SB-DI" package. ;;;; DEBUG-VARs ;;; These exist for caching data stored in packed binary form in ;;; compiler debug-functions. Debug-functions store these. -(defstruct (debug-var (:constructor nil)) +(defstruct (debug-var (:constructor nil) + (:copier nil)) ;; the name of the variable (symbol (required-argument) :type symbol) ;; a unique integer identification relative to other variables with the same @@ -210,28 +210,24 @@ #!+sb-doc (setf (fdocumentation 'debug-var-id 'function) - "Returns the integer that makes DEBUG-VAR's name and package unique + "Return the integer that makes DEBUG-VAR's name and package unique with respect to other DEBUG-VARs in the same function.") (defstruct (compiled-debug-var (:include debug-var) (:constructor make-compiled-debug-var - (symbol id alive-p sc-offset save-sc-offset))) + (symbol id alive-p sc-offset save-sc-offset)) + (:copier nil)) ;; Storage class and offset. (unexported). (sc-offset nil :type sb!c::sc-offset) ;; Storage class and offset when saved somewhere. (save-sc-offset nil :type (or sb!c::sc-offset null))) -(defstruct (interpreted-debug-var - (:include debug-var (alive-p t)) - (:constructor make-interpreted-debug-var (symbol ir1-var))) - ;; This is the IR1 structure that holds information about interpreted vars. - (ir1-var nil :type sb!c::lambda-var)) - ;;;; frames ;;; These represent call-frames on the stack. -(defstruct (frame (:constructor nil)) +(defstruct (frame (:constructor nil) + (:copier nil)) ;; the next frame up, or NIL when top frame (up nil :type (or frame null)) ;; the previous frame down, or NIL when the bottom frame. Before @@ -255,16 +251,16 @@ #!+sb-doc (setf (fdocumentation 'frame-up 'function) - "Returns the frame immediately above frame on the stack. When frame is + "Return the frame immediately above frame on the stack. When frame is the top of the stack, this returns nil.") #!+sb-doc (setf (fdocumentation 'frame-debug-function 'function) - "Returns the debug-function for the function whose call frame represents.") + "Return the debug-function for the function whose call frame represents.") #!+sb-doc (setf (fdocumentation 'frame-code-location 'function) - "Returns the code-location where the frame's debug-function will continue + "Return the code-location where the frame's debug-function will continue running when program execution returns to this frame. If someone interrupted this frame, the result could be an unknown code-location.") @@ -273,7 +269,8 @@ (:constructor make-compiled-frame (pointer up debug-function code-location number #!+gengc saved-state-chain - &optional escaped))) + &optional escaped)) + (:copier nil)) ;; This indicates whether someone interrupted the frame. ;; (unexported). If escaped, this is a pointer to the state that was ;; saved when we were interrupted. On the non-gengc system, this is @@ -296,15 +293,16 @@ (:include frame) (:constructor make-interpreted-frame (pointer up debug-function code-location number - real-frame closure))) - ;; This points to the compiled-frame for SB!EVAL:INTERNAL-APPLY-LOOP. + real-frame closure)) + (:copier nil)) + ;; This points to the compiled-frame for SB!BYTECODE:INTERNAL-APPLY-LOOP. (real-frame nil :type compiled-frame) ;; This is the closed over data used by the interpreter. (closure nil :type simple-vector)) (def!method print-object ((obj interpreted-frame) str) (print-unreadable-object (obj str :type t) (prin1 (debug-function-name (frame-debug-function obj)) str))) - + ;;;; DEBUG-FUNCTIONs ;;; These exist for caching data stored in packed binary form in @@ -314,18 +312,19 @@ ;;; code-locations and other objects that reference DEBUG-FUNCTIONs ;;; point to unique objects. This is due to the overhead in cached ;;; information. -(defstruct debug-function - ;; Some representation of the function arguments. See +(defstruct (debug-function (:constructor nil) + (:copier nil)) + ;; some representation of the function arguments. See ;; DEBUG-FUNCTION-LAMBDA-LIST. ;; NOTE: must parse vars before parsing arg list stuff. (%lambda-list :unparsed) - ;; Cached DEBUG-VARS information. (unexported). + ;; cached DEBUG-VARS information (unexported). ;; These are sorted by their name. (%debug-vars :unparsed :type (or simple-vector null (member :unparsed))) - ;; Cached debug-block information. This is NIL when we have tried to + ;; cached debug-block information. This is NIL when we have tried to ;; parse the packed binary info, but none is available. (blocks :unparsed :type (or simple-vector null (member :unparsed))) - ;; The actual function if available. + ;; the actual function if available (%function :unparsed :type (or null function (member :unparsed)))) (def!method print-object ((obj debug-function) stream) (print-unreadable-object (obj stream :type t) @@ -334,13 +333,14 @@ (defstruct (compiled-debug-function (:include debug-function) (:constructor %make-compiled-debug-function - (compiler-debug-fun component))) - ;; Compiler's dumped debug-function information. (unexported). + (compiler-debug-fun component)) + (:copier nil)) + ;; compiler's dumped debug-function information (unexported) (compiler-debug-fun nil :type sb!c::compiled-debug-function) - ;; Code object. (unexported). + ;; code object (unexported). component - ;; The :FUNCTION-START breakpoint (if any) used to facilitate - ;; function end breakpoints. + ;; the :FUNCTION-START breakpoint (if any) used to facilitate + ;; function end breakpoints (end-starter nil :type (or null breakpoint))) ;;; This maps SB!C::COMPILED-DEBUG-FUNCTIONs to @@ -358,39 +358,28 @@ (setf (gethash compiler-debug-fun *compiled-debug-functions*) (%make-compiled-debug-function compiler-debug-fun component)))) -(defstruct (interpreted-debug-function - (:include debug-function) - (:constructor %make-interpreted-debug-function (ir1-lambda))) - ;; This is the IR1 lambda that this debug-function represents. - (ir1-lambda nil :type sb!c::clambda)) - (defstruct (bogus-debug-function (:include debug-function) (:constructor make-bogus-debug-function (%name &aux (%lambda-list nil) (%debug-vars nil) - (blocks nil) (%function nil)))) + (blocks nil) (%function nil))) + (:copier nil)) %name) (defvar *ir1-lambda-debug-function* (make-hash-table :test 'eq)) - -(defun make-interpreted-debug-function (ir1-lambda) - (let ((home-lambda (sb!c::lambda-home ir1-lambda))) - (or (gethash home-lambda *ir1-lambda-debug-function*) - (setf (gethash home-lambda *ir1-lambda-debug-function*) - (%make-interpreted-debug-function home-lambda))))) - + ;;;; DEBUG-BLOCKs ;;; These exist for caching data stored in packed binary form in compiler -;;; debug-blocks. -(defstruct (debug-block (:constructor nil)) +;;; DEBUG-BLOCKs. +(defstruct (debug-block (:constructor nil) + (:copier nil)) ;; Code-locations where execution continues after this block. (successors nil :type list) - ;; This indicates whether the block is a special glob of code shared by - ;; various functions and tucked away elsewhere in a component. This kind of - ;; block has no start code-location. In an interpreted-debug-block, this is - ;; always nil. This slot is in all debug-blocks since it is an exported - ;; interface. + ;; This indicates whether the block is a special glob of code shared + ;; by various functions and tucked away elsewhere in a component. + ;; This kind of block has no start code-location. This slot is in + ;; all debug-blocks since it is an exported interface. (elsewhere-p nil :type boolean)) (def!method print-object ((obj debug-block) str) (print-unreadable-object (obj str :type t) @@ -408,65 +397,20 @@ (defstruct (compiled-debug-block (:include debug-block) (:constructor make-compiled-debug-block - (code-locations successors elsewhere-p))) - ;; Code-location information for the block. + (code-locations successors elsewhere-p)) + (:copier nil)) + ;; code-location information for the block (code-locations nil :type simple-vector)) -(defstruct (interpreted-debug-block (:include debug-block - (elsewhere-p nil)) - (:constructor %make-interpreted-debug-block - (ir1-block))) - ;; This is the IR1 block this debug-block represents. - (ir1-block nil :type sb!c::cblock) - ;; Code-location information for the block. - (locations :unparsed :type (or (member :unparsed) simple-vector))) - (defvar *ir1-block-debug-block* (make-hash-table :test 'eq)) - -;;; Make a DEBUG-BLOCK for the interpreter's IR1-BLOCK. If we have it -;;; in the cache, return it. If we need to make it, then first make -;;; DEBUG-BLOCKs for all the IR1-BLOCKs in IR1-BLOCK's home lambda; -;;; this makes sure all the successors of IR1-BLOCK have DEBUG-BLOCKs. -;;; We need this to fill in the resulting DEBUG-BLOCK's successors -;;; list with DEBUG-BLOCKs, not IR1-BLOCKs. After making all the -;;; possible DEBUG-BLOCKs we'll need to reference, go back over the -;;; list of new DEBUG-BLOCKs and fill in their successor slots with -;;; lists of DEBUG-BLOCKs. Then look up our argument IR1-BLOCK to find -;;; its DEBUG-BLOCK since we know we have it now. -(defun make-interpreted-debug-block (ir1-block) - (check-type ir1-block sb!c::cblock) - (let ((res (gethash ir1-block *ir1-block-debug-block*))) - (or res - (let ((lambda (sb!c::block-home-lambda ir1-block))) - (sb!c::do-blocks (block (sb!c::block-component ir1-block)) - (when (eq lambda (sb!c::block-home-lambda block)) - (push (setf (gethash block *ir1-block-debug-block*) - (%make-interpreted-debug-block block)) - res))) - (dolist (block res) - (let* ((successors nil) - (cblock (interpreted-debug-block-ir1-block block)) - (succ (sb!c::block-succ cblock)) - (valid-succ - (if (and succ - (eq (car succ) - (sb!c::component-tail - (sb!c::block-component cblock)))) - () - succ))) - (dolist (sblock valid-succ) - (let ((dblock (gethash sblock *ir1-block-debug-block*))) - (when dblock - (push dblock successors)))) - (setf (debug-block-successors block) (nreverse successors)))) - (gethash ir1-block *ir1-block-debug-block*))))) - + ;;;; breakpoints ;;; This is an internal structure that manages information about a ;;; breakpoint locations. See *COMPONENT-BREAKPOINT-OFFSETS*. (defstruct (breakpoint-data (:constructor make-breakpoint-data - (component offset))) + (component offset)) + (:copier nil)) ;; This is the component in which the breakpoint lies. component ;; This is the byte offset into the component. @@ -484,7 +428,8 @@ (breakpoint-data-offset obj)))) (defstruct (breakpoint (:constructor %make-breakpoint - (hook-function what kind %info))) + (hook-function what kind %info)) + (:copier nil)) ;; This is the function invoked when execution encounters the ;; breakpoint. It takes a frame, the breakpoint, and optionally a ;; list of values. Values are supplied for :FUNCTION-END breakpoints @@ -551,7 +496,8 @@ ;;;; CODE-LOCATIONs -(defstruct (code-location (:constructor nil)) +(defstruct (code-location (:constructor nil) + (:copier nil)) ;; This is the debug-function containing code-location. (debug-function nil :type debug-function) ;; This is initially :UNSURE. Upon first trying to access an @@ -587,7 +533,8 @@ (:constructor make-known-code-location (pc debug-function %tlf-offset %form-number %live-set kind &aux (%unknown-p nil))) - (:constructor make-compiled-code-location (pc debug-function))) + (:constructor make-compiled-code-location (pc debug-function)) + (:copier nil)) ;; This is an index into debug-function's component slot. (pc nil :type sb!c::index) ;; This is a bit-vector indexed by a variable's position in @@ -597,64 +544,21 @@ ;; (unexported) To see SB!C::LOCATION-KIND, do ;; (SB!KERNEL:TYPE-EXPAND 'SB!C::LOCATION-KIND). (kind :unparsed :type (or (member :unparsed) sb!c::location-kind))) - -(defstruct (interpreted-code-location - (:include code-location - (%unknown-p nil)) - (:constructor make-interpreted-code-location - (ir1-node debug-function))) - ;; This is an index into debug-function's component slot. - (ir1-node nil :type sb!c::node)) - -;;; DEBUG-SOURCEs - -#!-sb-fluid (declaim (inline debug-source-root-number)) + +;;;; DEBUG-SOURCEs + +;;; Return the number of top-level forms processed by the compiler +;;; before compiling this source. If this source is uncompiled, this +;;; is zero. This may be zero even if the source is compiled since the +;;; first form in the first file compiled in one compilation, for +;;; example, must have a root number of zero -- the compiler saw no +;;; other top-level forms before it. (defun debug-source-root-number (debug-source) - #!+sb-doc - "Returns the number of top-level forms processed by the compiler before - compiling this source. If this source is uncompiled, this is zero. This - may be zero even if the source is compiled since the first form in the first - file compiled in one compilation, for example, must have a root number of - zero -- the compiler saw no other top-level forms before it." (sb!c::debug-source-source-root debug-source)) - -#!+sb-doc -(setf (fdocumentation 'sb!c::debug-source-from 'function) - "Returns an indication of the type of source. The following are the possible - values: - :file from a file (obtained by COMPILE-FILE if compiled). - :lisp from Lisp (obtained by COMPILE if compiled).") - -#!+sb-doc -(setf (fdocumentation 'sb!c::debug-source-name 'function) - "Returns the actual source in some sense represented by debug-source, which - is related to DEBUG-SOURCE-FROM: - :file the pathname of the file. - :lisp a lambda-expression.") - -#!+sb-doc -(setf (fdocumentation 'sb!c::debug-source-created 'function) - "Returns the universal time someone created the source. This may be nil if - it is unavailable.") - -#!+sb-doc -(setf (fdocumentation 'sb!c::debug-source-compiled 'function) - "Returns the time someone compiled the source. This is nil if the source - is uncompiled.") - -#!+sb-doc -(setf (fdocumentation 'sb!c::debug-source-start-positions 'function) - "This function returns the file position of each top-level form as an array - if debug-source is from a :file. If DEBUG-SOURCE-FROM is :lisp, - this returns nil.") - -#!+sb-doc -(setf (fdocumentation 'sb!c::debug-source-p 'function) - "Returns whether object is a debug-source.") ;;;; frames -;;; This is used in FIND-ESCAPE-FRAME and with the bogus components +;;; This is used in FIND-ESCAPED-FRAME and with the bogus components ;;; and LRAs used for :function-end breakpoints. When a components ;;; debug-info slot is :bogus-lra, then the real-lra-slot contains the ;;; real component to continue executing, as opposed to the bogus @@ -767,7 +671,8 @@ (cond ((and lisp-path-fp c-path-fp) ;; Both still seem valid - choose the lisp frame. #+nil (when (zerop depth) - (format t "debug: both still valid ~S ~S ~S ~S~%" + (format t + "debug: both still valid ~S ~S ~S ~S~%" lisp-ocfp lisp-ra c-ocfp c-ra)) #+freebsd (if (sap> lisp-ocfp c-ocfp) @@ -811,10 +716,10 @@ (defun descriptor-sap (x) (int-sap (get-lisp-obj-address x))) +;;; Return the top frame of the control stack as it was before calling +;;; this function. (defun top-frame () - #!+sb-doc - "Returns the top frame of the control stack as it was before calling this - function." + (/show0 "entering TOP-FRAME") (multiple-value-bind (fp pc) (%caller-frame-and-pc) (possibly-an-interpreted-frame (compute-calling-frame (descriptor-sap fp) @@ -822,26 +727,26 @@ nil) nil))) +;;; Flush all of the frames above FRAME, and renumber all the frames +;;; below FRAME. (defun flush-frames-above (frame) - #!+sb-doc - "Flush all of the frames above FRAME, and renumber all the frames below - FRAME." (setf (frame-up frame) nil) (do ((number 0 (1+ number)) (frame frame (frame-%down frame))) ((not (frame-p frame))) (setf (frame-number frame) number))) -;;; We have to access the old-fp and return-pc out of frame and pass them to -;;; COMPUTE-CALLING-FRAME. +;;; Return the frame immediately below FRAME on the stack; or when +;;; FRAME is the bottom of the stack, return NIL. (defun frame-down (frame) - #!+sb-doc - "Returns the frame immediately below frame on the stack. When frame is - the bottom of the stack, this returns nil." + (/show0 "entering FRAME-DOWN") + ;; We have to access the old-fp and return-pc out of frame and pass + ;; them to COMPUTE-CALLING-FRAME. (let ((down (frame-%down frame))) (if (eq down :unparsed) (let* ((real (frame-real-frame frame)) (debug-fun (frame-debug-function real))) + (/show0 "in DOWN :UNPARSED case") (setf (frame-%down frame) (etypecase debug-fun (compiled-debug-function @@ -938,51 +843,79 @@ (#.sb!vm::lra-save-offset (setf (sap-ref-sap pointer (- (* (1+ stack-slot) 4))) value)))))) -(defvar *debugging-interpreter* nil - #!+sb-doc - "When set, the debugger foregoes making interpreted-frames, so you can - debug the functions that manifest the interpreter.") - -;;; This takes a newly computed frame, FRAME, and the frame above it -;;; on the stack, UP-FRAME, which is possibly NIL. FRAME is NIL when -;;; we hit the bottom of the control stack. When FRAME represents a -;;; call to SB!EVAL::INTERNAL-APPLY-LOOP, we make an interpreted frame -;;; to replace FRAME. The interpreted frame points to FRAME. +;;; This doesn't do anything in sbcl-0.7.0, since the functionality +;;; was lost in the switch from IR1 interpreter to bytecode interpreter. +;;; However, it might be revived someday. (See the FIXME for +;;; POSSIBLY-AN-INTERPRETED-FRAME.) +;;; +;;; (defvar *debugging-interpreter* nil +;;; #!+sb-doc +;;; "When set, the debugger foregoes making interpreted frames, so you can +;;; debug the functions that manifest the interpreter.") + +;;; Note: In CMU CL with the IR1 interpreter, this did +;;; This takes a newly computed frame, FRAME, and the frame above it +;;; on the stack, UP-FRAME, which is possibly NIL. FRAME is NIL when +;;; we hit the bottom of the control stack. When FRAME represents a +;;; call to SB!BYTECODE::INTERNAL-APPLY-LOOP, we make an interpreted frame +;;; to replace FRAME. The interpreted frame points to FRAME. +;;; But with SBCL's switch to byte-interpreter-only, this is functionality +;;; wasn't maintained, so this is just a placeholder, and when you +;;; try to "debug byte code" you end up debugging the byte interpreter +;;; instead. +;;; +;;; (It might be good to update the old CMU CL functionality so that +;;; you can really debug byte code instead of seeing a bunch of +;;; confusing byte interpreter implementation stuff, so I've left the +;;; placeholder in place. But be aware that doing so is a big messy +;;; job: grep for 'interpreted-debug-' in the sbcl-0.6.13 sources to +;;; see what you're getting into. -- WHN) (defun possibly-an-interpreted-frame (frame up-frame) - (if (or (not frame) - (not (eq (debug-function-name (frame-debug-function frame)) - 'sb!eval::internal-apply-loop)) - *debugging-interpreter* - (compiled-frame-escaped frame)) - frame - (flet ((get-var (name location) - (let ((vars (sb!di:ambiguous-debug-vars - (sb!di:frame-debug-function frame) name))) - (when (or (null vars) (> (length vars) 1)) - (error "zero or more than one ~A variable in ~ - SB!EVAL::INTERNAL-APPLY-LOOP" - (string-downcase name))) - (if (eq (debug-var-validity (car vars) location) - :valid) - (car vars))))) - (let* ((code-loc (frame-code-location frame)) - (ptr-var (get-var "FRAME-PTR" code-loc)) - (node-var (get-var "NODE" code-loc)) - (closure-var (get-var "CLOSURE" code-loc))) - (if (and ptr-var node-var closure-var) - (let* ((node (debug-var-value node-var frame)) - (d-fun (make-interpreted-debug-function - (sb!c::block-home-lambda (sb!c::node-block - node))))) - (make-interpreted-frame - (debug-var-value ptr-var frame) - up-frame - d-fun - (make-interpreted-code-location node d-fun) - (frame-number frame) - frame - (debug-var-value closure-var frame))) - frame))))) + + ;; new SBCL code, not ambitious enough to do anything tricky like + ;; hiding the byte interpreter when debugging + (declare (ignore up-frame)) + (/show "doing trivial POSSIBLY-AN-INTERPRETED-FRAME") + frame + + ;; old CMU CL code to hide IR1 interpreter when debugging: + ;; + ;;(if (or (not frame) + ;; (not (eq (debug-function-name (frame-debug-function + ;; frame)) + ;; 'sb!bytecode::internal-apply-loop)) + ;; *debugging-interpreter* + ;; (compiled-frame-escaped frame)) + ;; frame + ;; (flet ((get-var (name location) + ;; (let ((vars (sb!di:ambiguous-debug-vars + ;; (sb!di:frame-debug-function frame) name))) + ;; (when (or (null vars) (> (length vars) 1)) + ;; (error "zero or more than one ~A variable in ~ + ;; SB!BYTECODE::INTERNAL-APPLY-LOOP" + ;; (string-downcase name))) + ;; (if (eq (debug-var-validity (car vars) location) + ;; :valid) + ;; (car vars))))) + ;; (let* ((code-loc (frame-code-location frame)) + ;; (ptr-var (get-var "FRAME-PTR" code-loc)) + ;; (node-var (get-var "NODE" code-loc)) + ;; (closure-var (get-var "CLOSURE" code-loc))) + ;; (if (and ptr-var node-var closure-var) + ;; (let* ((node (debug-var-value node-var frame)) + ;; (d-fun (make-interpreted-debug-function + ;; (sb!c::block-home-lambda (sb!c::node-block + ;; node))))) + ;; (make-interpreted-frame + ;; (debug-var-value ptr-var frame) + ;; up-frame + ;; d-fun + ;; (make-interpreted-code-location node d-fun) + ;; (frame-number frame) + ;; frame + ;; (debug-var-value closure-var frame))) + ;; frame)))) + ) ;;; This returns a frame for the one existing in time immediately ;;; prior to the frame referenced by current-fp. This is current-fp's @@ -1045,79 +978,70 @@ #!+x86 (defun compute-calling-frame (caller ra up-frame) (declare (type system-area-pointer caller ra)) -; (format t "ccf: ~A ~A ~A~%" caller ra up-frame) + (/show0 "entering COMPUTE-CALLING-FRAME") (when (cstack-pointer-valid-p caller) -; (format t "ccf2~%") + (/show0 "in WHEN") ;; First check for an escaped frame. (multiple-value-bind (code pc-offset escaped) (find-escaped-frame caller) - (cond (code - ;; If it's escaped it may be a function end breakpoint trap. -; (format t "ccf2: escaped ~S ~S~%" code pc-offset) - (when (and (code-component-p code) - (eq (%code-debug-info code) :bogus-lra)) - ;; If :bogus-lra grab the real lra. - (setq pc-offset (code-header-ref - code (1+ real-lra-slot))) - (setq code (code-header-ref code real-lra-slot)) -; (format t "ccf3 :bogus-lra ~S ~S~%" code pc-offset) - (assert code))) - (t - ;; Not escaped - (multiple-value-setq (pc-offset code) - (compute-lra-data-from-pc ra)) -; (format t "ccf4 ~S ~S~%" code pc-offset) - (unless code - (setf code :foreign-function - pc-offset 0 - escaped nil)))) - - (let ((d-fun (case code - (:undefined-function - (make-bogus-debug-function - "undefined function")) - (:foreign-function - (make-bogus-debug-function - "foreign function call land")) - ((nil) - (make-bogus-debug-function - "bogus stack frame")) - (t - (debug-function-from-pc code pc-offset))))) - (make-compiled-frame caller up-frame d-fun - (code-location-from-pc d-fun pc-offset - escaped) - (if up-frame (1+ (frame-number up-frame)) 0) - escaped))))) + (/show0 "at COND") + (cond (code + (/show0 "in CODE clause") + ;; If it's escaped it may be a function end breakpoint trap. + (when (and (code-component-p code) + (eq (%code-debug-info code) :bogus-lra)) + ;; If :bogus-lra grab the real lra. + (setq pc-offset (code-header-ref + code (1+ real-lra-slot))) + (setq code (code-header-ref code real-lra-slot)) + (aver code))) + (t + (/show0 "in T clause") + ;; not escaped + (multiple-value-setq (pc-offset code) + (compute-lra-data-from-pc ra)) + (unless code + (setf code :foreign-function + pc-offset 0 + escaped nil)))) + + (let ((d-fun (case code + (:undefined-function + (make-bogus-debug-function + "undefined function")) + (:foreign-function + (make-bogus-debug-function + "foreign function call land")) + ((nil) + (make-bogus-debug-function + "bogus stack frame")) + (t + (debug-function-from-pc code pc-offset))))) + (/show0 "returning MAKE-COMPILED-FRAME from COMPUTE-CALLING-FRAME") + (make-compiled-frame caller up-frame d-fun + (code-location-from-pc d-fun pc-offset + escaped) + (if up-frame (1+ (frame-number up-frame)) 0) + escaped))))) -#!-(or gengc x86) -;;; FIXME: The original CMU CL code had support for this case, but it -;;; must have been fairly stale even in CMU CL, since it had -;;; references to the MIPS package, and there have been enough -;;; relevant changes in SBCL (particularly using -;;; POSIX/SIGACTION0-style signal context instead of BSD-style -;;; sigcontext) that this code is unmaintainable (since as of -;;; sbcl-0.6.7, and for the foreseeable future, we can't test it, -;;; since we only support X86 and its gencgc). -;;; -;;; If we restore this case, the best approach would be to go back to -;;; the original CMU CL code and start from there. -(eval-when (:compile-toplevel :load-toplevel :execute) - (error "hopelessly stale")) #!+x86 (defun find-escaped-frame (frame-pointer) (declare (type system-area-pointer frame-pointer)) - (dotimes (index sb!impl::*free-interrupt-context-index* (values nil 0 nil)) + (/show0 "entering FIND-ESCAPED-FRAME") + (dotimes (index *free-interrupt-context-index* (values nil 0 nil)) (sb!alien:with-alien - ((lisp-interrupt-contexts (array (* os-context-t) nil) - :extern)) + ((lisp-interrupt-contexts (array (* os-context-t) nil) :extern)) + (/show0 "at head of WITH-ALIEN") (let ((context (sb!alien:deref lisp-interrupt-contexts index))) + (/show0 "got CONTEXT") (when (= (sap-int frame-pointer) (sb!vm:context-register context sb!vm::cfp-offset)) (without-gcing + (/show0 "in WITHOUT-GCING") (let* ((component-ptr (component-ptr-from-pc (sb!vm:context-pc context))) (code (unless (sap= component-ptr (int-sap #x0)) (component-from-component-ptr component-ptr)))) + (/show0 "got CODE") (when (null code) (return (values code 0 context))) (let* ((code-header-len (* (get-header-data code) @@ -1127,6 +1051,7 @@ (- (get-lisp-obj-address code) sb!vm:other-pointer-type) code-header-len))) + (/show "got PC-OFFSET") (unless (<= 0 pc-offset (* (code-header-ref code sb!vm:code-code-size-slot) sb!vm:word-bytes)) @@ -1136,9 +1061,54 @@ ;; FIXME: Should this be WARN or ERROR or what? (format t "** pc-offset ~S not in code obj ~S?~%" pc-offset code)) + (/show0 "returning from FIND-ESCAPED-FRAME") (return (values code pc-offset context)))))))))) +#!-x86 +(defun find-escaped-frame (frame-pointer) + (declare (type system-area-pointer frame-pointer)) + (dotimes (index *free-interrupt-context-index* (values nil 0 nil)) + (sb!alien:with-alien + ((lisp-interrupt-contexts (array (* os-context-t) nil) :extern)) + (let ((scp (sb!alien:deref lisp-interrupt-contexts index))) + (when (= (sap-int frame-pointer) + (sb!vm:context-register scp sb!vm::cfp-offset)) + (without-gcing + (let ((code (code-object-from-bits + (sb!vm:context-register scp sb!vm::code-offset)))) + (when (symbolp code) + (return (values code 0 scp))) + (let* ((code-header-len (* (get-header-data code) + sb!vm:word-bytes)) + (pc-offset + (- (sap-int (sb!vm:context-pc scp)) + (- (get-lisp-obj-address code) + sb!vm:other-pointer-type) + code-header-len))) + ;; Check to see whether we were executing in a branch + ;; delay slot. + #!+(or pmax sgi) ; pmax only (and broken anyway) + (when (logbitp 31 (sb!alien:slot scp '%mips::sc-cause)) + (incf pc-offset sb!vm:word-bytes)) + (unless (<= 0 pc-offset + (* (code-header-ref code sb!vm:code-code-size-slot) + sb!vm:word-bytes)) + ;; We were in an assembly routine. Therefore, use the + ;; LRA as the pc. + (setf pc-offset + (- (sb!vm:context-register scp sb!vm::lra-offset) + (get-lisp-obj-address code) + code-header-len))) + (return + (if (eq (%code-debug-info code) :bogus-lra) + (let ((real-lra (code-header-ref code + real-lra-slot))) + (values (lra-code-header real-lra) + (get-header-data real-lra) + nil)) + (values code pc-offset scp))))))))))) + ;;; Find the code object corresponding to the object represented by ;;; bits and return it. We assume bogus functions correspond to the ;;; undefined-function. @@ -1239,13 +1209,12 @@ what))))) (make-compiled-code-location pc debug-fun))) +;;; Return an alist mapping catch tags to CODE-LOCATIONs. These are +;;; CODE-LOCATIONs at which execution would continue with frame as the +;;; top frame if someone threw to the corresponding tag. (defun frame-catches (frame) - #!+sb-doc - "Returns an a-list mapping catch tags to code-locations. These are - code-locations at which execution would continue with frame as the top - frame if someone threw to the corresponding tag." (let ((catch - #!-gengc (descriptor-sap sb!impl::*current-catch-block*) + #!-gengc (descriptor-sap *current-catch-block*) #!+gengc (mutator-current-catch-block)) (res nil) (fp (frame-pointer (frame-real-frame frame)))) @@ -1316,14 +1285,14 @@ ;;;; operations on DEBUG-FUNCTIONs +;;; Execute the forms in a context with block-var bound to each +;;; debug-block in debug-function successively. Result is an optional +;;; form to execute for return values, and DO-DEBUG-FUNCTION-BLOCKS +;;; returns nil if there is no result form. This signals a +;;; no-debug-blocks condition when the debug-function lacks +;;; debug-block information. (defmacro do-debug-function-blocks ((block-var debug-function &optional result) &body body) - #!+sb-doc - "Executes the forms in a context with block-var bound to each debug-block in - debug-function successively. Result is an optional form to execute for - return values, and DO-DEBUG-FUNCTION-BLOCKS returns nil if there is no - result form. This signals a no-debug-blocks condition when the - debug-function lacks debug-block information." (let ((blocks (gensym)) (i (gensym))) `(let ((,blocks (debug-function-debug-blocks ,debug-function))) @@ -1332,14 +1301,13 @@ (let ((,block-var (svref ,blocks ,i))) ,@body))))) +;;; Execute body in a context with var bound to each debug-var in +;;; debug-function. This returns the value of executing result (defaults to +;;; nil). This may iterate over only some of debug-function's variables or none +;;; depending on debug policy; for example, possibly the compilation only +;;; preserved argument information. (defmacro do-debug-function-variables ((var debug-function &optional result) &body body) - #!+sb-doc - "Executes body in a context with var bound to each debug-var in - debug-function. This returns the value of executing result (defaults to - nil). This may iterate over only some of debug-function's variables or none - depending on debug policy; for example, possibly the compilation only - preserved argument information." (let ((vars (gensym)) (i (gensym))) `(let ((,vars (debug-function-debug-vars ,debug-function))) @@ -1350,11 +1318,10 @@ ,@body)) ,result)))) +;;; Return the Common Lisp function associated with the debug-function. This +;;; returns nil if the function is unavailable or is non-existent as a user +;;; callable function object. (defun debug-function-function (debug-function) - #!+sb-doc - "Returns the Common Lisp function associated with the debug-function. This - returns nil if the function is unavailable or is non-existent as a user - callable function object." (let ((cached-value (debug-function-%function debug-function))) (if (eq cached-value :unparsed) (setf (debug-function-%function debug-function) @@ -1374,48 +1341,34 @@ (compiled-debug-function-compiler-debug-fun (function-debug-function entry)))) (return entry))))) - (interpreted-debug-function - (sb!c::lambda-eval-info-function - (sb!c::leaf-info - (interpreted-debug-function-ir1-lambda debug-function)))) (bogus-debug-function nil))) cached-value))) +;;; Return the name of the function represented by debug-function. This may +;;; be a string or a cons; do not assume it is a symbol. (defun debug-function-name (debug-function) - #!+sb-doc - "Returns the name of the function represented by debug-function. This may - be a string or a cons; do not assume it is a symbol." (etypecase debug-function (compiled-debug-function (sb!c::compiled-debug-function-name (compiled-debug-function-compiler-debug-fun debug-function))) - (interpreted-debug-function - (sb!c::lambda-name (interpreted-debug-function-ir1-lambda - debug-function))) (bogus-debug-function (bogus-debug-function-%name debug-function)))) +;;; Return a debug-function that represents debug information for function. (defun function-debug-function (fun) - #!+sb-doc - "Returns a debug-function that represents debug information for function." - (case (get-type fun) + (ecase (get-type fun) (#.sb!vm:closure-header-type (function-debug-function (%closure-function fun))) (#.sb!vm:funcallable-instance-header-type - (cond ((sb!eval:interpreted-function-p fun) - (make-interpreted-debug-function - (or (sb!eval::interpreted-function-definition fun) - (sb!eval::convert-interpreted-fun fun)))) - (t - (function-debug-function (funcallable-instance-function fun))))) + (function-debug-function (funcallable-instance-function fun))) ((#.sb!vm:function-header-type #.sb!vm:closure-function-header-type) (let* ((name (%function-name fun)) (component (function-code-header fun)) (res (find-if - #'(lambda (x) - (and (sb!c::compiled-debug-function-p x) - (eq (sb!c::compiled-debug-function-name x) name) - (eq (sb!c::compiled-debug-function-kind x) nil))) + (lambda (x) + (and (sb!c::compiled-debug-function-p x) + (eq (sb!c::compiled-debug-function-name x) name) + (eq (sb!c::compiled-debug-function-kind x) nil))) (get-debug-info-function-map (%code-debug-info component))))) (if res @@ -1433,35 +1386,29 @@ (get-header-data component)) sb!vm:word-bytes))))))) +;;; Return the kind of the function, which is one of :OPTIONAL, +;;; :EXTERNAL, TOP-level, :CLEANUP, or NIL. (defun debug-function-kind (debug-function) - #!+sb-doc - "Returns the kind of the function which is one of :OPTIONAL, :EXTERNAL, - :TOP-level, :CLEANUP, or NIL." ;; FIXME: This "is one of" information should become part of the function ;; declamation, not just a doc string (etypecase debug-function (compiled-debug-function (sb!c::compiled-debug-function-kind (compiled-debug-function-compiler-debug-fun debug-function))) - (interpreted-debug-function - (sb!c::lambda-kind (interpreted-debug-function-ir1-lambda - debug-function))) (bogus-debug-function nil))) +;;; Is there any variable information for DEBUG-FUNCTION? (defun debug-var-info-available (debug-function) - #!+sb-doc - "Is there any variable information for DEBUG-FUNCTION?" (not (not (debug-function-debug-vars debug-function)))) +;;; Return a list of debug-vars in debug-function having the same name +;;; and package as symbol. If symbol is uninterned, then this returns +;;; a list of debug-vars without package names and with the same name +;;; as symbol. The result of this function is limited to the +;;; availability of variable information in debug-function; for +;;; example, possibly DEBUG-FUNCTION only knows about its arguments. (defun debug-function-symbol-variables (debug-function symbol) - #!+sb-doc - "Returns a list of debug-vars in debug-function having the same name - and package as symbol. If symbol is uninterned, then this returns a list of - debug-vars without package names and with the same name as symbol. The - result of this function is limited to the availability of variable - information in debug-function; for example, possibly debug-function only - knows about its arguments." (let ((vars (ambiguous-debug-vars debug-function (symbol-name symbol))) (package (and (symbol-package symbol) (package-name (symbol-package symbol))))) @@ -1474,11 +1421,12 @@ (stringp (debug-var-package-name var)))) vars))) +;;; Return a list of debug-vars in debug-function whose names contain +;;; name-prefix-string as an intial substring. The result of this +;;; function is limited to the availability of variable information in +;;; debug-function; for example, possibly debug-function only knows +;;; about its arguments. (defun ambiguous-debug-vars (debug-function name-prefix-string) - "Returns a list of debug-vars in debug-function whose names contain - name-prefix-string as an intial substring. The result of this function is - limited to the availability of variable information in debug-function; for - example, possibly debug-function only knows about its arguments." (declare (simple-string name-prefix-string)) (let ((variables (debug-function-debug-vars debug-function))) (declare (type (or null simple-vector) variables)) @@ -1519,95 +1467,32 @@ (string= x y :end1 name-len :end2 name-len)))) :end (or end (length variables))))) +;;; Return a list representing the lambda-list for DEBUG-FUNCTION. The +;;; list has the following structure: +;;; (required-var1 required-var2 +;;; ... +;;; (:optional var3 suppliedp-var4) +;;; (:optional var5) +;;; ... +;;; (:rest var6) (:rest var7) +;;; ... +;;; (:keyword keyword-symbol var8 suppliedp-var9) +;;; (:keyword keyword-symbol var10) +;;; ... +;;; ) +;;; Each VARi is a DEBUG-VAR; however it may be the symbol :DELETED if +;;; it is unreferenced in DEBUG-FUNCTION. This signals a +;;; LAMBDA-LIST-UNAVAILABLE condition when there is no argument list +;;; information. (defun debug-function-lambda-list (debug-function) - #!+sb-doc - "Returns a list representing the lambda-list for debug-function. The list - has the following structure: - (required-var1 required-var2 - ... - (:optional var3 suppliedp-var4) - (:optional var5) - ... - (:rest var6) (:rest var7) - ... - (:keyword keyword-symbol var8 suppliedp-var9) - (:keyword keyword-symbol var10) - ... - ) - Each VARi is a DEBUG-VAR; however it may be the symbol :deleted it - is unreferenced in debug-function. This signals a lambda-list-unavailable - condition when there is no argument list information." (etypecase debug-function (compiled-debug-function (compiled-debug-function-lambda-list debug-function)) - (interpreted-debug-function - (interpreted-debug-function-lambda-list debug-function)) (bogus-debug-function nil))) -;;; The hard part is when the lambda-list is unparsed. If it is -;;; unparsed, and all the arguments are required, this is still pretty -;;; easy; just whip the appropriate DEBUG-VARs into a list. Otherwise, -;;; we have to pick out the funny arguments including any suppliedp -;;; variables. In this situation, the ir1-lambda is an external entry -;;; point that takes arguments users really pass in. It looks at those -;;; and computes defaults and suppliedp variables, ultimately passing -;;; everything defined as a a parameter to the real function as final -;;; arguments. If this has to compute the lambda list, it caches it in -;;; debug-function. -(defun interpreted-debug-function-lambda-list (debug-function) - (let ((lambda-list (debug-function-%lambda-list debug-function)) - (debug-vars (debug-function-debug-vars debug-function)) - (ir1-lambda (interpreted-debug-function-ir1-lambda debug-function)) - (res nil)) - (if (eq lambda-list :unparsed) - (flet ((frob (v debug-vars) - (if (sb!c::lambda-var-refs v) - (find v debug-vars - :key #'interpreted-debug-var-ir1-var) - :deleted))) - (let ((xep-args (sb!c::lambda-optional-dispatch ir1-lambda))) - (if (and xep-args - (eq (sb!c::optional-dispatch-main-entry xep-args) - ir1-lambda)) - ;; There are rest, optional, keyword, and suppliedp vars. - (let ((final-args (sb!c::lambda-vars ir1-lambda))) - (dolist (xep-arg (sb!c::optional-dispatch-arglist xep-args)) - (let ((info (sb!c::lambda-var-arg-info xep-arg)) - (final-arg (pop final-args))) - (cond (info - (case (sb!c::arg-info-kind info) - (:required - (push (frob final-arg debug-vars) res)) - (:keyword - (push (list :keyword - (sb!c::arg-info-keyword info) - (frob final-arg debug-vars)) - res)) - (:rest - (push (list :rest (frob final-arg debug-vars)) - res)) - (:optional - (push (list :optional - (frob final-arg debug-vars)) - res))) - (when (sb!c::arg-info-supplied-p info) - (nconc - (car res) - (list (frob (pop final-args) debug-vars))))) - (t - (push (frob final-arg debug-vars) res))))) - (setf (debug-function-%lambda-list debug-function) - (nreverse res))) - ;; All required args, so return them in a list. - (dolist (v (sb!c::lambda-vars ir1-lambda) - (setf (debug-function-%lambda-list debug-function) - (nreverse res))) - (push (frob v debug-vars) res))))) - ;; Everything's unparsed and cached, so return it. - lambda-list))) - -;;; If this has to compute the lambda list, it caches it in debug-function. +;;; Note: If this has to compute the lambda list, it caches it in +;;; DEBUG-FUNCTION. (defun compiled-debug-function-lambda-list (debug-function) (let ((lambda-list (debug-function-%lambda-list debug-function))) (cond ((eq lambda-list :unparsed) @@ -1682,11 +1567,11 @@ res)) (sb!c::more-arg ;; Just ignore the fact that the next two args are - ;; the more arg context and count, and act like they + ;; the &MORE arg context and count, and act like they ;; are regular arguments. nil) (t - ;; keyword arg + ;; &KEY arg (push (list :keyword ele (compiled-debug-function-lambda-list-var @@ -1777,16 +1662,14 @@ (debug-signal 'no-debug-blocks :debug-function debug-function))))) -;;; This returns a simple-vector of debug-blocks or nil. NIL indicates +;;; This returns a SIMPLE-VECTOR of DEBUG-BLOCKs or NIL. NIL indicates ;;; there was no basic block information. (defun parse-debug-blocks (debug-function) (etypecase debug-function (compiled-debug-function (parse-compiled-debug-blocks debug-function)) (bogus-debug-function - (debug-signal 'no-debug-blocks :debug-function debug-function)) - (interpreted-debug-function - (parse-interpreted-debug-blocks debug-function)))) + (debug-signal 'no-debug-blocks :debug-function debug-function)))) ;;; This does some of the work of PARSE-DEBUG-BLOCKS. (defun parse-compiled-debug-blocks (debug-function) @@ -1851,21 +1734,10 @@ (setf (debug-block-successors block) succs))) res))))) -;;; This does some of the work of PARSE-DEBUG-BLOCKS. -(defun parse-interpreted-debug-blocks (debug-function) - (let ((ir1-lambda (interpreted-debug-function-ir1-lambda debug-function))) - (with-parsing-buffer (buffer) - (sb!c::do-blocks (block (sb!c::block-component - (sb!c::node-block (sb!c::lambda-bind - ir1-lambda)))) - (when (eq ir1-lambda (sb!c::block-home-lambda block)) - (vector-push-extend (make-interpreted-debug-block block) buffer))) - (result buffer)))) - -;;; The argument is a debug internals structure. This returns nil if +;;; The argument is a debug internals structure. This returns NIL if ;;; there is no variable information. It returns an empty ;;; simple-vector if there were no locals in the function. Otherwise -;;; it returns a simple-vector of DEBUG-VARs. +;;; it returns a SIMPLE-VECTOR of DEBUG-VARs. (defun debug-function-debug-vars (debug-function) (let ((vars (debug-function-%debug-vars debug-function))) (if (eq vars :unparsed) @@ -1873,58 +1745,12 @@ (etypecase debug-function (compiled-debug-function (parse-compiled-debug-vars debug-function)) - (bogus-debug-function nil) - (interpreted-debug-function - (parse-interpreted-debug-vars debug-function)))) + (bogus-debug-function nil))) vars))) -;;; This grabs all the variables from DEBUG-FUN's ir1-lambda, from the -;;; IR1 lambda vars, and all of its LET's. Each LET is an IR1 lambda. -;;; For each variable, we make an INTERPRETED-DEBUG-VAR. We then SORT -;;; all the variables by name. Then we go through, and for any -;;; duplicated names we distinguish the INTERPRETED-DEBUG-VARs by -;;; setting their id slots to a distinct number. -(defun parse-interpreted-debug-vars (debug-fun) - (let* ((ir1-lambda (interpreted-debug-function-ir1-lambda debug-fun)) - (vars (flet ((frob (ir1-lambda buf) - (dolist (v (sb!c::lambda-vars ir1-lambda)) - (vector-push-extend - (let* ((id (sb!c::leaf-name v))) - (make-interpreted-debug-var id v)) - buf)))) - (with-parsing-buffer (buf) - (frob ir1-lambda buf) - (dolist (let-lambda (sb!c::lambda-lets ir1-lambda)) - (frob let-lambda buf)) - (result buf))))) - (declare (simple-vector vars)) - (sort vars #'string< :key #'debug-var-symbol-name) - (let ((len (length vars))) - (when (> len 1) - (let ((i 0) - (j 1)) - (block PUNT - (loop - (let* ((var-i (svref vars i)) - (var-j (svref vars j)) - (name (debug-var-symbol-name var-i))) - (when (string= name (debug-var-symbol-name var-j)) - (let ((count 1)) - (loop - (setf (debug-var-id var-j) count) - (when (= (incf j) len) (return-from PUNT)) - (setf var-j (svref vars j)) - (when (string/= name (debug-var-symbol-name var-j)) - (return)) - (incf count)))) - (setf i j) - (incf j) - (when (= j len) (return)))))))) - vars)) - -;;; Vars is the parsed variables for a minimal debug function. We need to -;;; assign names of the form ARG-NNN. We must pad with leading zeros, since -;;; the arguments must be in alphabetical order. +;;; VARS is the parsed variables for a minimal debug function. We need +;;; to assign names of the form ARG-NNN. We must pad with leading +;;; zeros, since the arguments must be in alphabetical order. (defun assign-minimal-var-names (vars) (declare (simple-vector vars)) (let* ((len (length vars)) @@ -1933,8 +1759,8 @@ (setf (compiled-debug-var-symbol (svref vars i)) (intern (format nil "ARG-~V,'0D" width i) ;; KLUDGE: It's somewhat nasty to have a bare - ;; package name string here. It would probably be - ;; better to have #.(FIND-PACKAGE "SB!DEBUG") + ;; package name string here. It would be + ;; nicer to have #.(FIND-PACKAGE "SB!DEBUG") ;; instead, since then at least it would transform ;; correctly under package renaming and stuff. ;; However, genesis can't handle dumped packages.. @@ -1946,13 +1772,15 @@ ;; would work fine) If this is possible, it would ;; probably be a good thing, since minimizing the ;; amount of stuff in cold init is basically good. - "SB-DEBUG"))))) + (or (find-package "SB-DEBUG") + (find-package "SB!DEBUG"))))))) ;;; Parse the packed representation of DEBUG-VARs from ;;; DEBUG-FUNCTION's SB!C::COMPILED-DEBUG-FUNCTION, returning a vector ;;; of DEBUG-VARs, or NIL if there was no information to parse. (defun parse-compiled-debug-vars (debug-function) - (let* ((cdebug-fun (compiled-debug-function-compiler-debug-fun debug-function)) + (let* ((cdebug-fun (compiled-debug-function-compiler-debug-fun + debug-function)) (packed-vars (sb!c::compiled-debug-function-variables cdebug-fun)) (args-minimal (eq (sb!c::compiled-debug-function-arguments cdebug-fun) :minimal))) @@ -1968,7 +1796,8 @@ (let* ((flags (geti)) (minimal (logtest sb!c::compiled-debug-var-minimal-p flags)) (deleted (logtest sb!c::compiled-debug-var-deleted-p flags)) - (live (logtest sb!c::compiled-debug-var-environment-live flags)) + (live (logtest sb!c::compiled-debug-var-environment-live + flags)) (save (logtest sb!c::compiled-debug-var-save-loc-p flags)) (symbol (if minimal nil (geti))) (id (if (logtest sb!c::compiled-debug-var-id-p flags) @@ -1976,7 +1805,7 @@ 0)) (sc-offset (if deleted 0 (geti))) (save-sc-offset (if save (geti) nil))) - (assert (not (and args-minimal (not minimal)))) + (aver (not (and args-minimal (not minimal)))) (vector-push-extend (make-compiled-debug-var symbol id live @@ -2119,11 +1948,9 @@ (etypecase basic-code-location (compiled-code-location (compute-compiled-code-location-debug-block basic-code-location)) - (interpreted-code-location - (setf (code-location-%debug-block basic-code-location) - (make-interpreted-debug-block - (sb!c::node-block - (interpreted-code-location-ir1-node basic-code-location)))))) + ;; (There used to be more cases back before sbcl-0.7.0, when + ;; we did special tricks to debug the IR1 interpreter.) + ) block))) ;;; Store and return BASIC-CODE-LOCATION's debug-block. We determines @@ -2174,9 +2001,8 @@ 0))) (return (svref blocks (1- i))))))))) +;;; Return the CODE-LOCATION's DEBUG-SOURCE. (defun code-location-debug-source (code-location) - #!+sb-doc - "Returns the code-location's debug-source." (etypecase code-location (compiled-code-location (let* ((info (compiled-debug-function-debug-info @@ -2195,21 +2021,15 @@ ((null src) (car prev)) (when (< offset (sb!c::debug-source-source-root (car src))) (return (car prev))))))) - (interpreted-code-location - (first - (let ((sb!c::*lexenv* (make-null-lexenv))) - (sb!c::debug-source-for-info - (sb!c::component-source-info - (sb!c::block-component - (sb!c::node-block - (interpreted-code-location-ir1-node code-location)))))))))) - + ;; (There used to be more cases back before sbcl-0.7.0, when we + ;; did special tricks to debug the IR1 interpreter.) + )) + +;;; Returns the number of top-level forms before the one containing +;;; CODE-LOCATION as seen by the compiler in some compilation unit. (A +;;; compilation unit is not necessarily a single file, see the section +;;; on debug-sources.) (defun code-location-top-level-form-offset (code-location) - #!+sb-doc - "Returns the number of top-level forms before the one containing - code-location as seen by the compiler in some compilation unit. A - compilation unit is not necessarily a single file, see the section on - debug-sources." (when (code-location-unknown-p code-location) (error 'unknown-code-location :code-location code-location)) (let ((tlf-offset (code-location-%tlf-offset code-location))) @@ -2221,18 +2041,16 @@ ;; debug info the compiler should have dumped. (error "internal error: unknown code location")) (code-location-%tlf-offset code-location)) - (interpreted-code-location - (setf (code-location-%tlf-offset code-location) - (sb!c::source-path-tlf-number - (sb!c::node-source-path - (interpreted-code-location-ir1-node code-location))))))) + ;; (There used to be more cases back before sbcl-0.7.0,, + ;; when we did special tricks to debug the IR1 + ;; interpreter.) + )) (t tlf-offset)))) +;;; Return the number of the form corresponding to CODE-LOCATION. The +;;; form number is derived by a walking the subforms of a top-level +;;; form in depth-first order. (defun code-location-form-number (code-location) - #!+sb-doc - "Returns the number of the form corresponding to code-location. The form - number is derived by a walking the subforms of a top-level form in - depth-first order." (when (code-location-unknown-p code-location) (error 'unknown-code-location :code-location code-location)) (let ((form-num (code-location-%form-number code-location))) @@ -2244,19 +2062,17 @@ ;; debug info the compiler should have dumped. (error "internal error: unknown code location")) (code-location-%form-number code-location)) - (interpreted-code-location - (setf (code-location-%form-number code-location) - (sb!c::source-path-form-number - (sb!c::node-source-path - (interpreted-code-location-ir1-node code-location))))))) + ;; (There used to be more cases back before sbcl-0.7.0,, + ;; when we did special tricks to debug the IR1 + ;; interpreter.) + )) (t form-num)))) +;;; Return the kind of CODE-LOCATION, one of: +;;; :INTERPRETED, :UNKNOWN-RETURN, :KNOWN-RETURN, :INTERNAL-ERROR, +;;; :NON-LOCAL-EXIT, :BLOCK-START, :CALL-SITE, :SINGLE-VALUE-RETURN, +;;; :NON-LOCAL-ENTRY (defun code-location-kind (code-location) - #!+sb-doc - "Return the kind of CODE-LOCATION, one of: - :interpreted, :unknown-return, :known-return, :internal-error, - :non-local-exit, :block-start, :call-site, :single-value-return, - :non-local-entry" (when (code-location-unknown-p code-location) (error 'unknown-code-location :code-location code-location)) (etypecase code-location @@ -2269,8 +2085,10 @@ (error "internal error: unknown code location")) (t (compiled-code-location-kind code-location))))) - (interpreted-code-location - :interpreted))) + ;; (There used to be more cases back before sbcl-0.7.0,, + ;; when we did special tricks to debug the IR1 + ;; interpreter.) + )) ;;; This returns CODE-LOCATION's live-set if it is available. If ;;; there is no debug-block information, this returns NIL. @@ -2298,15 +2116,14 @@ (and (eq (code-location-debug-function obj1) (code-location-debug-function obj2)) (sub-compiled-code-location= obj1 obj2))) - (interpreted-code-location - nil))) - (interpreted-code-location - (etypecase obj2 - (compiled-code-location - nil) - (interpreted-code-location - (eq (interpreted-code-location-ir1-node obj1) - (interpreted-code-location-ir1-node obj2))))))) + ;; (There used to be more cases back before sbcl-0.7.0,, + ;; when we did special tricks to debug the IR1 + ;; interpreter.) + )) + ;; (There used to be more cases back before sbcl-0.7.0,, + ;; when we did special tricks to debug the IR1 + ;; interpreter.) + )) (defun sub-compiled-code-location= (obj1 obj2) (= (compiled-code-location-pc obj1) (compiled-code-location-pc obj2))) @@ -2341,23 +2158,21 @@ ;;;; operations on DEBUG-BLOCKs -(defmacro do-debug-block-locations ((code-var debug-block &optional return) +;;; Execute FORMS in a context with CODE-VAR bound to each +;;; CODE-LOCATION in DEBUG-BLOCK, and return the value of RESULT. +(defmacro do-debug-block-locations ((code-var debug-block &optional result) &body body) - #!+sb-doc - "Executes forms in a context with code-var bound to each code-location in - debug-block. This returns the value of executing result (defaults to nil)." (let ((code-locations (gensym)) (i (gensym))) `(let ((,code-locations (debug-block-code-locations ,debug-block))) (declare (simple-vector ,code-locations)) - (dotimes (,i (length ,code-locations) ,return) + (dotimes (,i (length ,code-locations) ,result) (let ((,code-var (svref ,code-locations ,i))) ,@body))))) +;;; Return the name of the function represented by DEBUG-FUNCTION. +;;; This may be a string or a cons; do not assume it is a symbol. (defun debug-block-function-name (debug-block) - #!+sb-doc - "Returns the name of the function represented by debug-function. This may - be a string or a cons; do not assume it is a symbol." (etypecase debug-block (compiled-debug-block (let ((code-locs (compiled-debug-block-code-locations debug-block))) @@ -2366,32 +2181,17 @@ "??? Can't get name of debug-block's function." (debug-function-name (code-location-debug-function (svref code-locs 0)))))) - (interpreted-debug-block - (sb!c::lambda-name (sb!c::block-home-lambda - (interpreted-debug-block-ir1-block debug-block)))))) + ;; (There used to be more cases back before sbcl-0.7.0, when we + ;; did special tricks to debug the IR1 interpreter.) + )) (defun debug-block-code-locations (debug-block) (etypecase debug-block (compiled-debug-block (compiled-debug-block-code-locations debug-block)) - (interpreted-debug-block - (interpreted-debug-block-code-locations debug-block)))) - -(defun interpreted-debug-block-code-locations (debug-block) - (let ((code-locs (interpreted-debug-block-locations debug-block))) - (if (eq code-locs :unparsed) - (with-parsing-buffer (buf) - (sb!c::do-nodes (node cont (interpreted-debug-block-ir1-block - debug-block)) - (vector-push-extend (make-interpreted-code-location - node - (make-interpreted-debug-function - (sb!c::block-home-lambda (sb!c::node-block - node)))) - buf)) - (setf (interpreted-debug-block-locations debug-block) - (result buf))) - code-locs))) + ;; (There used to be more cases back before sbcl-0.7.0, when we + ;; did special tricks to debug the IR1 interpreter.) + )) ;;;; operations on debug variables @@ -2404,48 +2204,47 @@ (defun debug-var-package-name (debug-var) (package-name (symbol-package (debug-var-symbol debug-var)))) +;;; Return the value stored for DEBUG-VAR in frame, or if the value is +;;; not :VALID, then signal an INVALID-VALUE error. (defun debug-var-valid-value (debug-var frame) - #!+sb-doc - "Returns the value stored for DEBUG-VAR in frame. If the value is not - :valid, then this signals an invalid-value error." (unless (eq (debug-var-validity debug-var (frame-code-location frame)) :valid) (error 'invalid-value :debug-var debug-var :frame frame)) (debug-var-value debug-var frame)) +;;; Returns the value stored for DEBUG-VAR in frame. The value may be +;;; invalid. This is SETFable. (defun debug-var-value (debug-var frame) - #!+sb-doc - "Returns the value stored for DEBUG-VAR in frame. The value may be - invalid. This is SETF'able." (etypecase debug-var (compiled-debug-var - (check-type frame compiled-frame) + (aver (typep frame 'compiled-frame)) (let ((res (access-compiled-debug-var-slot debug-var frame))) (if (indirect-value-cell-p res) - (sb!c:value-cell-ref res) + (value-cell-ref res) res))) - (interpreted-debug-var - (check-type frame interpreted-frame) - (sb!eval::leaf-value-lambda-var - (interpreted-code-location-ir1-node (frame-code-location frame)) - (interpreted-debug-var-ir1-var debug-var) - (frame-pointer frame) - (interpreted-frame-closure frame))))) + ;; (This function used to be more interesting, with more type + ;; cases here, before the IR1 interpreter went away. It might + ;; become more interesting again if we ever try to generalize the + ;; CMU CL POSSIBLY-AN-INTERPRETED-FRAME thing to elide + ;; internal-to-the-byte-interpreter debug frames the way that CMU + ;; CL elided internal-to-the-IR1-interpreter debug frames.) + )) ;;; This returns what is stored for the variable represented by ;;; DEBUG-VAR relative to the FRAME. This may be an indirect value ;;; cell if the variable is both closed over and set. (defun access-compiled-debug-var-slot (debug-var frame) + (declare (optimize (speed 1))) (let ((escaped (compiled-frame-escaped frame))) (if escaped - (sub-access-debug-var-slot - (frame-pointer frame) - (compiled-debug-var-sc-offset debug-var) - escaped) - (sub-access-debug-var-slot - (frame-pointer frame) - (or (compiled-debug-var-save-sc-offset debug-var) - (compiled-debug-var-sc-offset debug-var)))))) + (sub-access-debug-var-slot + (frame-pointer frame) + (compiled-debug-var-sc-offset debug-var) + escaped) + (sub-access-debug-var-slot + (frame-pointer frame) + (or (compiled-debug-var-save-sc-offset debug-var) + (compiled-debug-var-sc-offset debug-var)))))) ;;; a helper function for working with possibly-invalid values: ;;; Do (MAKE-LISP-OBJ VAL) only if the value looks valid. @@ -2455,7 +2254,7 @@ ;;; those variables are invalid.) (defun make-valid-lisp-obj (val) (/show0 "entering MAKE-VALID-LISP-OBJ, VAL=..") - #!+sb-show (%primitive print (sb!impl::hexstr val)) + #!+sb-show (/hexstr val) (if (or ;; fixnum (zerop (logand val 3)) @@ -2480,27 +2279,161 @@ (make-lisp-obj val) :invalid-object)) -;;; CMU CL had -;;; (DEFUN SUB-ACCESS-DEBUG-VAR-SLOT (FP SC-OFFSET &OPTIONAL ESCAPED) ..) -;;; code for this case. #!-x86 -(eval-when (:compile-toplevel :load-toplevel :execute) - (error "hopelessly stale")) +(defun sub-access-debug-var-slot (fp sc-offset &optional escaped) + (macrolet ((with-escaped-value ((var) &body forms) + `(if escaped + (let ((,var (sb!vm:context-register + escaped + (sb!c:sc-offset-offset sc-offset)))) + ,@forms) + :invalid-value-for-unescaped-register-storage)) + (escaped-float-value (format) + `(if escaped + (sb!vm:context-float-register + escaped + (sb!c:sc-offset-offset sc-offset) + ',format) + :invalid-value-for-unescaped-register-storage)) + (with-nfp ((var) &body body) + `(let ((,var (if escaped + (sb!sys:int-sap + (sb!vm:context-register escaped + sb!vm::nfp-offset)) + #!-alpha + (sb!sys:sap-ref-sap fp (* sb!vm::nfp-save-offset + sb!vm:word-bytes)) + #!+alpha + (sb!vm::make-number-stack-pointer + (sb!sys:sap-ref-32 fp (* sb!vm::nfp-save-offset + sb!vm:word-bytes)))))) + ,@body))) + (ecase (sb!c:sc-offset-scn sc-offset) + ((#.sb!vm:any-reg-sc-number + #.sb!vm:descriptor-reg-sc-number + #!+rt #.sb!vm:word-pointer-reg-sc-number) + (sb!sys:without-gcing + (with-escaped-value (val) (sb!kernel:make-lisp-obj val)))) + + (#.sb!vm:base-char-reg-sc-number + (with-escaped-value (val) + (code-char val))) + (#.sb!vm:sap-reg-sc-number + (with-escaped-value (val) + (sb!sys:int-sap val))) + (#.sb!vm:signed-reg-sc-number + (with-escaped-value (val) + (if (logbitp (1- sb!vm:word-bits) val) + (logior val (ash -1 sb!vm:word-bits)) + val))) + (#.sb!vm:unsigned-reg-sc-number + (with-escaped-value (val) + val)) + (#.sb!vm:non-descriptor-reg-sc-number + (error "Local non-descriptor register access?")) + (#.sb!vm:interior-reg-sc-number + (error "Local interior register access?")) + (#.sb!vm:single-reg-sc-number + (escaped-float-value single-float)) + (#.sb!vm:double-reg-sc-number + (escaped-float-value double-float)) + #!+long-float + (#.sb!vm:long-reg-sc-number + (escaped-float-value long-float)) + (#.sb!vm:complex-single-reg-sc-number + (if escaped + (complex + (sb!vm:context-float-register + escaped (sb!c:sc-offset-offset sc-offset) 'single-float) + (sb!vm:context-float-register + escaped (1+ (sb!c:sc-offset-offset sc-offset)) 'single-float)) + :invalid-value-for-unescaped-register-storage)) + (#.sb!vm:complex-double-reg-sc-number + (if escaped + (complex + (sb!vm:context-float-register + escaped (sb!c:sc-offset-offset sc-offset) 'double-float) + (sb!vm:context-float-register + escaped (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 2 #-sparc 1) + 'double-float)) + :invalid-value-for-unescaped-register-storage)) + #!+long-float + (#.sb!vm:complex-long-reg-sc-number + (if escaped + (complex + (sb!vm:context-float-register + escaped (sb!c:sc-offset-offset sc-offset) 'long-float) + (sb!vm:context-float-register + escaped (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4) + 'long-float)) + :invalid-value-for-unescaped-register-storage)) + (#.sb!vm:single-stack-sc-number + (with-nfp (nfp) + (sb!sys:sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:word-bytes)))) + (#.sb!vm:double-stack-sc-number + (with-nfp (nfp) + (sb!sys:sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:word-bytes)))) + #!+long-float + (#.sb!vm:long-stack-sc-number + (with-nfp (nfp) + (sb!sys:sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:word-bytes)))) + (#.sb!vm:complex-single-stack-sc-number + (with-nfp (nfp) + (complex + (sb!sys:sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:word-bytes)) + (sb!sys:sap-ref-single nfp (* (1+ (sb!c:sc-offset-offset sc-offset)) + sb!vm:word-bytes))))) + (#.sb!vm:complex-double-stack-sc-number + (with-nfp (nfp) + (complex + (sb!sys:sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:word-bytes)) + (sb!sys:sap-ref-double nfp (* (+ (sb!c:sc-offset-offset sc-offset) 2) + sb!vm:word-bytes))))) + #!+long-float + (#.sb!vm:complex-long-stack-sc-number + (with-nfp (nfp) + (complex + (sb!sys:sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:word-bytes)) + (sb!sys:sap-ref-long nfp (* (+ (sb!c:sc-offset-offset sc-offset) + #!+sparc 4) + sb!vm:word-bytes))))) + (#.sb!vm:control-stack-sc-number + (sb!kernel:stack-ref fp (sb!c:sc-offset-offset sc-offset))) + (#.sb!vm:base-char-stack-sc-number + (with-nfp (nfp) + (code-char (sb!sys:sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:word-bytes))))) + (#.sb!vm:unsigned-stack-sc-number + (with-nfp (nfp) + (sb!sys:sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:word-bytes)))) + (#.sb!vm:signed-stack-sc-number + (with-nfp (nfp) + (sb!sys:signed-sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:word-bytes)))) + (#.sb!vm:sap-stack-sc-number + (with-nfp (nfp) + (sb!sys:sap-ref-sap nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:word-bytes))))))) #!+x86 (defun sub-access-debug-var-slot (fp sc-offset &optional escaped) (declare (type system-area-pointer fp)) (/show0 "entering SUB-ACCESS-DEBUG-VAR-SLOT, FP,SC-OFFSET,ESCAPED=..") - #!+sb-show (%primitive print (sb!impl::hexstr fp)) - #!+sb-show (%primitive print (sb!impl::hexstr sc-offset)) - #!+sb-show (%primitive print (sb!impl::hexstr escaped)) + (/hexstr fp) (/hexstr sc-offset) (/hexstr escaped) (macrolet ((with-escaped-value ((var) &body forms) `(if escaped (let ((,var (sb!vm:context-register escaped (sb!c:sc-offset-offset sc-offset)))) (/show0 "in escaped case, ,VAR value=..") - #!+sb-show (%primitive print (sb!impl::hexstr ,var)) + (/hexstr ,var) ,@forms) :invalid-value-for-unescaped-register-storage)) (escaped-float-value (format) @@ -2522,7 +2455,7 @@ (without-gcing (with-escaped-value (val) (/show0 "VAL=..") - #!+sb-show (%primitive print (sb!impl::hexstr val)) + (/hexstr val) (make-valid-lisp-obj val)))) (#.sb!vm:base-char-reg-sc-number (/show0 "case of BASE-CHAR-REG-SC-NUMBER") @@ -2621,25 +2554,22 @@ ;;; This stores value as the value of DEBUG-VAR in FRAME. In the ;;; COMPILED-DEBUG-VAR case, access the current value to determine if ;;; it is an indirect value cell. This occurs when the variable is -;;; both closed over and set. For INTERPRETED-DEBUG-VARs just call -;;; SB!EVAL::SET-LEAF-VALUE-LAMBDA-VAR with the right interpreter -;;; objects. +;;; both closed over and set. (defun %set-debug-var-value (debug-var frame value) (etypecase debug-var (compiled-debug-var - (check-type frame compiled-frame) + (aver (typep frame 'compiled-frame)) (let ((current-value (access-compiled-debug-var-slot debug-var frame))) (if (indirect-value-cell-p current-value) - (sb!c:value-cell-set current-value value) + (value-cell-set current-value value) (set-compiled-debug-var-slot debug-var frame value)))) - (interpreted-debug-var - (check-type frame interpreted-frame) - (sb!eval::set-leaf-value-lambda-var - (interpreted-code-location-ir1-node (frame-code-location frame)) - (interpreted-debug-var-ir1-var debug-var) - (frame-pointer frame) - (interpreted-frame-closure frame) - value))) + ;; (This function used to be more interesting, with more type + ;; cases here, before the IR1 interpreter went away. It might + ;; become more interesting again if we ever try to generalize the + ;; CMU CL POSSIBLY-AN-INTERPRETED-FRAME thing to elide + ;; internal-to-the-byte-interpreter debug frames the way that CMU + ;; CL elided internal-to-the-IR1-interpreter debug frames.) + ) value) ;;; This stores value for the variable represented by debug-var @@ -2682,13 +2612,13 @@ sb!vm::nfp-offset)) #!-alpha (sap-ref-sap fp - (* sb!vm::nfp-save-offset - sb!vm:word-bytes)) + (* sb!vm::nfp-save-offset + sb!vm:word-bytes)) #!+alpha - (%alpha::make-number-stack-pointer + (sb!vm::make-number-stack-pointer (sap-ref-32 fp - (* sb!vm::nfp-save-offset - sb!vm:word-bytes)))))) + (* sb!vm::nfp-save-offset + sb!vm:word-bytes)))))) ,@body))) (ecase (sb!c:sc-offset-scn sc-offset) ((#.sb!vm:any-reg-sc-number @@ -2919,33 +2849,28 @@ (and (= (get-lowtag x) sb!vm:other-pointer-type) (= (get-type x) sb!vm:value-cell-header-type))) +;;; Return three values reflecting the validity of DEBUG-VAR's value +;;; at BASIC-CODE-LOCATION: +;;; :VALID The value is known to be available. +;;; :INVALID The value is known to be unavailable. +;;; :UNKNOWN The value's availability is unknown. +;;; ;;; If the variable is always alive, then it is valid. If the ;;; code-location is unknown, then the variable's validity is ;;; :unknown. Once we've called CODE-LOCATION-UNKNOWN-P, we know the ;;; live-set information has been cached in the code-location. (defun debug-var-validity (debug-var basic-code-location) - #!+sb-doc - "Returns three values reflecting the validity of DEBUG-VAR's value - at BASIC-CODE-LOCATION: - :VALID The value is known to be available. - :INVALID The value is known to be unavailable. - :UNKNOWN The value's availability is unknown." (etypecase debug-var (compiled-debug-var (compiled-debug-var-validity debug-var basic-code-location)) - (interpreted-debug-var - (check-type basic-code-location interpreted-code-location) - (let ((validp (rassoc (interpreted-debug-var-ir1-var debug-var) - (sb!c::lexenv-variables - (sb!c::node-lexenv - (interpreted-code-location-ir1-node - basic-code-location)))))) - (if validp :valid :invalid))))) + ;; (There used to be more cases back before sbcl-0.7.0, when + ;; we did special tricks to debug the IR1 interpreter.) + )) ;;; This is the method for DEBUG-VAR-VALIDITY for COMPILED-DEBUG-VARs. ;;; For safety, make sure basic-code-location is what we think. (defun compiled-debug-var-validity (debug-var basic-code-location) - (check-type basic-code-location compiled-code-location) + (declare (type compiled-code-location basic-code-location)) (cond ((debug-var-alive-p debug-var) (let ((debug-fun (code-location-debug-function basic-code-location))) (if (>= (compiled-code-location-pc basic-code-location) @@ -2957,14 +2882,16 @@ (t (let ((pos (position debug-var (debug-function-debug-vars - (code-location-debug-function basic-code-location))))) + (code-location-debug-function + basic-code-location))))) (unless pos (error 'unknown-debug-var :debug-var debug-var :debug-function (code-location-debug-function basic-code-location))) ;; There must be live-set info since basic-code-location is known. - (if (zerop (sbit (compiled-code-location-live-set basic-code-location) + (if (zerop (sbit (compiled-code-location-live-set + basic-code-location) pos)) :invalid :valid))))) @@ -2988,21 +2915,21 @@ ;;; Given the DEFUN, 3 gets you the LET, 1 gets you the bindings, 0 ;;; gets the first binding, and 1 gets the AREF form. -;;; Temporary buffer used to build form-number => source-path translation in -;;; FORM-NUMBER-TRANSLATIONS. +;;; temporary buffer used to build form-number => source-path translation in +;;; FORM-NUMBER-TRANSLATIONS (defvar *form-number-temp* (make-array 10 :fill-pointer 0 :adjustable t)) -;;; Table used to detect CAR circularities in FORM-NUMBER-TRANSLATIONS. +;;; table used to detect CAR circularities in FORM-NUMBER-TRANSLATIONS (defvar *form-number-circularity-table* (make-hash-table :test 'eq)) +;;; This returns a table mapping form numbers to source-paths. A source-path +;;; indicates a descent into the top-level-form form, going directly to the +;;; subform corressponding to the form number. +;;; ;;; The vector elements are in the same format as the compiler's -;;; NODE-SOUCE-PATH; that is, the first element is the form number and the last -;;; is the top-level-form number. +;;; NODE-SOURCE-PATH; that is, the first element is the form number and +;;; the last is the top-level-form number. (defun form-number-translations (form tlf-number) - #!+sb-doc - "This returns a table mapping form numbers to source-paths. A source-path - indicates a descent into the top-level-form form, going directly to the - subform corressponding to the form number." (clrhash *form-number-circularity-table*) (setf (fill-pointer *form-number-temp*) 0) (sub-translate-form-numbers form (list tlf-number)) @@ -3030,13 +2957,13 @@ (frob) (setq trail (cdr trail))))))) +;;; FORM is a top-level form, and path is a source-path into it. This +;;; returns the form indicated by the source-path. Context is the +;;; number of enclosing forms to return instead of directly returning +;;; the source-path form. When context is non-zero, the form returned +;;; contains a marker, #:****HERE****, immediately before the form +;;; indicated by path. (defun source-path-context (form path context) - #!+sb-doc - "Form is a top-level form, and path is a source-path into it. This returns - the form indicated by the source-path. Context is the number of enclosing - forms to return instead of directly returning the source-path form. When - context is non-zero, the form returned contains a marker, #:****HERE****, - immediately before the form indicated by path." (declare (type unsigned-byte context)) ;; Get to the form indicated by path or the enclosing form indicated ;; by context and path. @@ -3066,19 +2993,18 @@ (cons res (nthcdr (1+ n) form)))))))) (frob form path context)))) -;;;; PREPROCESS-FOR-EVAL and EVAL-IN-FRAME +;;;; PREPROCESS-FOR-EVAL -;;; Create a SYMBOL-MACROLET for each variable valid at the location which -;;; accesses that variable from the frame argument. +;;; Return a function of one argument that evaluates form in the +;;; lexical context of the BASIC-CODE-LOCATION LOC, or signal a +;;; NO-DEBUG-VARS condition when the LOC's DEBUG-FUNCTION has no +;;; DEBUG-VAR information available. +;;; +;;; The returned function takes the frame to get values from as its +;;; argument, and it returns the values of FORM. The returned function +;;; can signal the following conditions: INVALID-VALUE, +;;; AMBIGUOUS-VARIABLE-NAME, and FRAME-FUNCTION-MISMATCH. (defun preprocess-for-eval (form loc) - #!+sb-doc - "Return a function of one argument that evaluates form in the lexical - context of the basic-code-location loc. PREPROCESS-FOR-EVAL signals a - no-debug-vars condition when the loc's debug-function has no - debug-var information available. The returned function takes the frame - to get values from as its argument, and it returns the values of form. - The returned function signals the following conditions: invalid-value, - ambiguous-variable-name, and frame-function-mismatch" (declare (type code-location loc)) (let ((n-frame (gensym)) (fun (code-location-debug-function loc))) @@ -3119,12 +3045,6 @@ (debug-signal 'frame-function-mismatch :code-location loc :form form :frame frame)) (funcall res frame)))))) - -;;; Evaluate FORM in the lexical context of FRAME's current code -;;; location, returning the results of the evaluation. -(defun eval-in-frame (frame form) - (declare (type frame frame)) - (funcall (preprocess-for-eval form (frame-code-location frame)) frame)) ;;;; breakpoints @@ -3166,11 +3086,9 @@ (when (code-location-unknown-p what) (error "cannot make a breakpoint at an unknown code location: ~S" what)) - (assert (eq kind :code-location)) + (aver (eq kind :code-location)) (let ((bpt (%make-breakpoint hook-function what kind info))) (etypecase what - (interpreted-code-location - (error "Breakpoints in interpreted code are currently unsupported.")) (compiled-code-location ;; This slot is filled in due to calling CODE-LOCATION-UNKNOWN-P. (when (eq (compiled-code-location-kind what) :unknown-return) @@ -3178,7 +3096,11 @@ :unknown-return-partner info))) (setf (breakpoint-unknown-return-partner bpt) other-bpt) - (setf (breakpoint-unknown-return-partner other-bpt) bpt))))) + (setf (breakpoint-unknown-return-partner other-bpt) bpt)))) + ;; (There used to be more cases back before sbcl-0.7.0,, + ;; when we did special tricks to debug the IR1 + ;; interpreter.) + ) bpt)) (compiled-debug-function (ecase kind @@ -3201,10 +3123,7 @@ (setf (breakpoint-start-helper bpt) starter) (push bpt (breakpoint-%info starter)) (setf (breakpoint-cookie-fun bpt) function-end-cookie) - bpt)))) - (interpreted-debug-function - (error ":function-end breakpoints are currently unsupported ~ - for interpreted-debug-functions.")))) + bpt)))))) ;;; These are unique objects created upon entry into a function by a ;;; :FUNCTION-END breakpoint's starter hook. These are only created @@ -3214,10 +3133,11 @@ (defstruct (function-end-cookie (:print-object (lambda (obj str) (print-unreadable-object (obj str :type t)))) - (:constructor make-function-end-cookie (bogus-lra debug-fun))) - ;; This is a pointer to the bogus-lra created for :function-end bpts. + (:constructor make-function-end-cookie (bogus-lra debug-fun)) + (:copier nil)) + ;; a pointer to the bogus-lra created for :FUNCTION-END breakpoints bogus-lra - ;; This is the debug-function associated with the cookie. + ;; the debug-function associated with the cookie debug-fun) ;;; This maps bogus-lra-components to cookies, so that @@ -3302,20 +3222,21 @@ (:code-location (let ((loc (breakpoint-what breakpoint))) (etypecase loc - (interpreted-code-location - (error "Breakpoints in interpreted code are currently unsupported.")) (compiled-code-location (activate-compiled-code-location-breakpoint breakpoint) (let ((other (breakpoint-unknown-return-partner breakpoint))) (when other - (activate-compiled-code-location-breakpoint other))))))) + (activate-compiled-code-location-breakpoint other)))) + ;; (There used to be more cases back before sbcl-0.7.0, when + ;; we did special tricks to debug the IR1 interpreter.) + ))) (:function-start (etypecase (breakpoint-what breakpoint) (compiled-debug-function (activate-compiled-function-start-breakpoint breakpoint)) - (interpreted-debug-function - (error "I don't know how you made this, but they're unsupported: ~S" - (breakpoint-what breakpoint))))) + ;; (There used to be more cases back before sbcl-0.7.0, when + ;; we did special tricks to debug the IR1 interpreter.) + )) (:function-end (etypecase (breakpoint-what breakpoint) (compiled-debug-function @@ -3324,9 +3245,9 @@ ;; may already be active by some other :FUNCTION-END breakpoint (activate-compiled-function-start-breakpoint starter))) (setf (breakpoint-status breakpoint) :active)) - (interpreted-debug-function - (error "I don't know how you made this, but they're unsupported: ~S" - (breakpoint-what breakpoint))))))) + ;; (There used to be more cases back before sbcl-0.7.0, when + ;; we did special tricks to debug the IR1 interpreter.) + )))) breakpoint) (defun activate-compiled-code-location-breakpoint (breakpoint) @@ -3372,21 +3293,20 @@ ;;;; DEACTIVATE-BREAKPOINT +;;; Stop the system from invoking the breakpoint's hook-function. (defun deactivate-breakpoint (breakpoint) - #!+sb-doc - "This stops the system from invoking the breakpoint's hook-function." (when (eq (breakpoint-status breakpoint) :active) (without-interrupts (let ((loc (breakpoint-what breakpoint))) (etypecase loc - ((or interpreted-code-location interpreted-debug-function) - (error - "Breakpoints in interpreted code are currently unsupported.")) ((or compiled-code-location compiled-debug-function) (deactivate-compiled-breakpoint breakpoint) (let ((other (breakpoint-unknown-return-partner breakpoint))) (when other - (deactivate-compiled-breakpoint other)))))))) + (deactivate-compiled-breakpoint other)))) + ;; (There used to be more cases back before sbcl-0.7.0, when + ;; we did special tricks to debug the IR1 interpreter.) + )))) breakpoint) (defun deactivate-compiled-breakpoint (breakpoint) @@ -3413,10 +3333,9 @@ ;;;; BREAKPOINT-INFO +;;; Return the user-maintained info associated with breakpoint. This +;;; is SETF'able. (defun breakpoint-info (breakpoint) - #!+sb-doc - "This returns the user-maintained info associated with breakpoint. This - is SETF'able." (breakpoint-%info breakpoint)) (defun %set-breakpoint-info (breakpoint value) (setf (breakpoint-%info breakpoint) value) @@ -3427,17 +3346,14 @@ ;;;; BREAKPOINT-ACTIVE-P and DELETE-BREAKPOINT (defun breakpoint-active-p (breakpoint) - #!+sb-doc - "This returns whether breakpoint is currently active." (ecase (breakpoint-status breakpoint) (:active t) ((:inactive :deleted) nil))) +;;; Free system storage and remove computational overhead associated +;;; with breakpoint. After calling this, breakpoint is completely +;;; impotent and can never become active again. (defun delete-breakpoint (breakpoint) - #!+sb-doc - "This frees system storage and removes computational overhead associated with - breakpoint. After calling this, breakpoint is completely impotent and can - never become active again." (let ((status (breakpoint-status breakpoint))) (unless (eq status :deleted) (when (eq status :active) @@ -3565,8 +3481,10 @@ ;; so we just leave it up to the C code. (breakpoint-do-displaced-inst signal-context (breakpoint-data-instruction data)) - ; Under HPUX we can't sigreturn so bp-do-disp-i has to return. - #!-(or hpux irix x86) + ;; Some platforms have no usable sigreturn() call. If your + ;; implementation of arch_do_displaced_inst() doesn't sigreturn(), + ;; add it to this list. + #!-(or hpux irix x86 alpha) (error "BREAKPOINT-DO-DISPLACED-INST returned?")))) (defun invoke-breakpoint-hooks (breakpoints component offset) @@ -3593,7 +3511,7 @@ offset)) (let ((breakpoints (breakpoint-data-breakpoints data))) (when breakpoints - (assert (eq (breakpoint-kind (car breakpoints)) :function-end)) + (aver (eq (breakpoint-kind (car breakpoints)) :function-end)) (handle-function-end-breakpoint-aux breakpoints data context))))) ;;; Either HANDLE-BREAKPOINT calls this for :FUNCTION-END breakpoints @@ -3639,23 +3557,17 @@ ;;;; MAKE-BOGUS-LRA (used for :FUNCTION-END breakpoints) -(defconstant - bogus-lra-constants +(defconstant bogus-lra-constants #!-x86 2 #!+x86 3) -(defconstant - known-return-p-slot +(defconstant known-return-p-slot (+ sb!vm:code-constants-offset #!-x86 1 #!+x86 2)) -;;; FIXME: This is also defined in debug-vm.lisp. Which definition -;;; takes precedence? (One definition uses ALLOCATE-CODE-OBJECT, and -;;; the other has been hacked for X86 GENCGC to use -;;; ALLOCATE-DYNAMIC-CODE-OBJECT..) +;;; Make a bogus LRA object that signals a breakpoint trap when +;;; returned to. If the breakpoint trap handler returns, REAL-LRA is +;;; returned to. Three values are returned: the bogus LRA object, the +;;; code component it is part of, and the PC offset for the trap +;;; instruction. (defun make-bogus-lra (real-lra &optional known-return-p) - #!+sb-doc - "Make a bogus LRA object that signals a breakpoint trap when returned to. If - the breakpoint trap handler returns, REAL-LRA is returned to. Three values - are returned: the bogus LRA object, the code component it is part of, and - the PC offset for the trap instruction." (without-gcing (let* ((src-start (foreign-symbol-address "function_end_breakpoint_guts")) (src-end (foreign-symbol-address "function_end_breakpoint_end")) @@ -3698,15 +3610,14 @@ ;;;; miscellaneous -;;; This appears here because it cannot go with the debug-function +;;; This appears here because it cannot go with the DEBUG-FUNCTION ;;; interface since DO-DEBUG-BLOCK-LOCATIONS isn't defined until after -;;; the debug-function routines. +;;; the DEBUG-FUNCTION routines. +;;; Return a code-location before the body of a function and after all +;;; the arguments are in place; or if that location can't be +;;; determined due to a lack of debug information, return NIL. (defun debug-function-start-location (debug-fun) - #!+sb-doc - "This returns a code-location before the body of a function and after all - the arguments are in place. If this cannot determine that location due to - a lack of debug information, it returns nil." (etypecase debug-fun (compiled-debug-function (code-location-from-pc debug-fun @@ -3714,14 +3625,9 @@ (compiled-debug-function-compiler-debug-fun debug-fun)) nil)) - (interpreted-debug-function - ;; Return the first location if there are any, otherwise NIL. - (handler-case (do-debug-function-blocks (block debug-fun nil) - (do-debug-block-locations (loc block nil) - (return-from debug-function-start-location loc))) - (no-debug-blocks (condx) - (declare (ignore condx)) - nil))))) + ;; (There used to be more cases back before sbcl-0.7.0, when + ;; we did special tricks to debug the IR1 interpreter.) + )) (defun print-code-locations (function) (let ((debug-fun (function-debug-function function)))