X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=e96f6717216a4c58f4a1c37e0887e585acbba8b3;hb=416152f084604094445a758ff399871132dff2bd;hp=ea6149bdde346fad8c333769331294ff2ea5af2a;hpb=95f5ac2fa70b3f14d052e20f4250166f219dcc39;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index ea6149b..e96f671 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -210,7 +210,7 @@ #!+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 @@ -223,13 +223,6 @@ ;; 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)) - (:copier nil)) - ;; 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. @@ -258,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.") @@ -302,14 +295,14 @@ (pointer up debug-function code-location number real-frame closure)) (:copier nil)) - ;; This points to the compiled-frame for SB!EVAL:INTERNAL-APPLY-LOOP. + ;; 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 @@ -319,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 (:copier nil)) - ;; 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) @@ -341,12 +335,12 @@ (:constructor %make-compiled-debug-function (compiler-debug-fun component)) (:copier nil)) - ;; Compiler's dumped debug-function information. (unexported). + ;; 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 @@ -364,13 +358,6 @@ (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)) - (:copier nil)) - ;; 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 @@ -380,13 +367,7 @@ %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 @@ -395,11 +376,10 @@ (: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) @@ -422,56 +402,8 @@ ;; 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)) - (:copier nil)) - ;; 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) - (declare (type sb!c::cblock ir1-block)) - (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 @@ -612,61 +544,17 @@ ;; (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)) - (:copier nil)) - ;; 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 @@ -828,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) @@ -839,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 @@ -955,53 +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) - #!+sb-interpreter (not (eq (debug-function-name (frame-debug-function - frame)) - 'sb!eval::internal-apply-loop)) - #!-sb-interpreter t - *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 @@ -1064,67 +978,70 @@ #!+x86 (defun compute-calling-frame (caller ra up-frame) (declare (type system-area-pointer caller ra)) + (/show0 "entering COMPUTE-CALLING-FRAME") (when (cstack-pointer-valid-p caller) + (/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. - (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 - ;; 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))))) - (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))))) #!+x86 (defun find-escaped-frame (frame-pointer) (declare (type system-area-pointer frame-pointer)) - - ;; FIXME: These conditionals are a hack to get the system to - ;; bootstrap itself despite a byte interpreter/compiler bug. Without - ;; it, the byte interpreter blows up when trying to cross-compile - ;; this function, hitting #:UNINITIALIZED-EVAL-STACK-ELEMENT while - ;; executing (SB-XC:MACRO-FUNCTION 'SB!EXT:WITH-ALIEN). - #+sb-xc (values nil 0 nil) #-sb-xc ; REMOVEME + (/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) @@ -1134,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)) @@ -1143,6 +1061,7 @@ ;; 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)))))))))) @@ -1290,11 +1209,10 @@ 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 *current-catch-block*) #!+gengc (mutator-current-catch-block)) @@ -1423,10 +1341,6 @@ (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))) @@ -1437,33 +1351,24 @@ (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) - (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-interpreter - ((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 @@ -1490,9 +1395,6 @@ (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))) @@ -1583,78 +1485,14 @@ ;;; LAMBDA-LIST-UNAVAILABLE condition when there is no argument list ;;; information. (defun debug-function-lambda-list (debug-function) - #!+sb-doc (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-key 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) @@ -1824,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) @@ -1898,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) @@ -1920,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)) @@ -1980,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.. @@ -1993,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))) @@ -2015,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) @@ -2166,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 @@ -2221,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 @@ -2242,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))) @@ -2268,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))) @@ -2291,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 @@ -2316,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. @@ -2345,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))) @@ -2388,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))) @@ -2413,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 @@ -2451,34 +2204,31 @@ (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 (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))) - #!+sb-interpreter - (interpreted-debug-var - (aver (typep 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 @@ -2804,26 +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 (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)))) - #!+sb-interpreter - (interpreted-debug-var - (aver (typep 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 @@ -3103,28 +2849,23 @@ (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 - (aver (typep 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. @@ -3252,16 +2993,17 @@ (cons res (nthcdr (1+ n) form)))))))) (frob form path context)))) -;;;; PREPROCESS-FOR-EVAL and EVAL-IN-FRAME +;;;; PREPROCESS-FOR-EVAL ;;; 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. +;;; 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) (declare (type code-location loc)) (let ((n-frame (gensym)) @@ -3303,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 @@ -3353,8 +3089,6 @@ (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) @@ -3362,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 @@ -3385,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 @@ -3487,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 @@ -3509,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) @@ -3557,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) @@ -3598,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) @@ -3612,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) @@ -3826,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")) @@ -3885,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 @@ -3901,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)))