X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=071a476058eb2e0be6c081e288622f9fd6d4649b;hb=8b89077f2d8c3aec140ded650d95d7869f6a7f28;hp=281128ef06c63f0f2a907bcc51125b577c2d0622;hpb=7e1f6a02db322634078e6cec7bf92bcd060db0fe;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 281128e..071a476 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -47,22 +47,21 @@ #!+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~%" (no-debug-info-code-component condition))))) -(define-condition no-debug-function-returns (debug-condition) - ((debug-function :reader no-debug-function-returns-debug-function - :initarg :debug-function)) +(define-condition no-debug-fun-returns (debug-condition) + ((debug-fun :reader no-debug-fun-returns-debug-fun + :initarg :debug-fun)) #!+sb-doc (:documentation - "The system could not return values from a frame with DEBUG-FUNCTION since + "The system could not return values from a frame with DEBUG-FUN since it lacked information about returning values.") (:report (lambda (condition stream) - (let ((fun (debug-function-function - (no-debug-function-returns-debug-function condition)))) + (let ((fun (debug-fun-fun + (no-debug-fun-returns-debug-fun condition)))) (format stream "~&Cannot return values from ~:[frame~;~:*~S~] since ~ the debug information lacks details about returning ~ @@ -70,33 +69,33 @@ fun))))) (define-condition no-debug-blocks (debug-condition) - ((debug-function :reader no-debug-blocks-debug-function - :initarg :debug-function)) + ((debug-fun :reader no-debug-blocks-debug-fun + :initarg :debug-fun)) #!+sb-doc - (:documentation "The debug-function has no debug-block information.") + (:documentation "The debug-fun has no debug-block information.") (:report (lambda (condition stream) (format stream "~&~S has no debug-block information." - (no-debug-blocks-debug-function condition))))) + (no-debug-blocks-debug-fun condition))))) (define-condition no-debug-vars (debug-condition) - ((debug-function :reader no-debug-vars-debug-function - :initarg :debug-function)) + ((debug-fun :reader no-debug-vars-debug-fun + :initarg :debug-fun)) #!+sb-doc - (:documentation "The debug-function has no DEBUG-VAR information.") + (:documentation "The DEBUG-FUN has no DEBUG-VAR information.") (:report (lambda (condition stream) (format stream "~&~S has no debug variable information." - (no-debug-vars-debug-function condition))))) + (no-debug-vars-debug-fun condition))))) (define-condition lambda-list-unavailable (debug-condition) - ((debug-function :reader lambda-list-unavailable-debug-function - :initarg :debug-function)) + ((debug-fun :reader lambda-list-unavailable-debug-fun + :initarg :debug-fun)) #!+sb-doc (:documentation - "The debug-function has no lambda-list since argument DEBUG-VARs are + "The DEBUG-FUN has no lambda list since argument DEBUG-VARs are unavailable.") (:report (lambda (condition stream) (format stream "~&~S has no lambda-list information available." - (lambda-list-unavailable-debug-function condition))))) + (lambda-list-unavailable-debug-fun condition))))) (define-condition invalid-value (debug-condition) ((debug-var :reader invalid-value-debug-var :initarg :debug-var) @@ -106,13 +105,13 @@ (invalid-value-debug-var condition) (invalid-value-frame condition))))) -(define-condition ambiguous-variable-name (debug-condition) - ((name :reader ambiguous-variable-name-name :initarg :name) - (frame :reader ambiguous-variable-name-frame :initarg :frame)) +(define-condition ambiguous-var-name (debug-condition) + ((name :reader ambiguous-var-name-name :initarg :name) + (frame :reader ambiguous-var-name-frame :initarg :frame)) (:report (lambda (condition stream) (format stream "~&~S names more than one valid variable in ~S." - (ambiguous-variable-name-name condition) - (ambiguous-variable-name-frame condition))))) + (ambiguous-var-name-name condition) + (ambiguous-var-name-frame condition))))) ;;;; errors and DEBUG-SIGNAL @@ -145,12 +144,12 @@ (define-condition unknown-debug-var (debug-error) ((debug-var :reader unknown-debug-var-debug-var :initarg :debug-var) - (debug-function :reader unknown-debug-var-debug-function - :initarg :debug-function)) + (debug-fun :reader unknown-debug-var-debug-fun + :initarg :debug-fun)) (:report (lambda (condition stream) (format stream "~&~S is not in ~S." (unknown-debug-var-debug-var condition) - (unknown-debug-var-debug-function condition))))) + (unknown-debug-var-debug-fun condition))))) (define-condition invalid-control-stack-pointer (debug-error) () @@ -159,18 +158,18 @@ (fresh-line stream) (write-string "invalid control stack pointer" stream)))) -(define-condition frame-function-mismatch (debug-error) - ((code-location :reader frame-function-mismatch-code-location +(define-condition frame-fun-mismatch (debug-error) + ((code-location :reader frame-fun-mismatch-code-location :initarg :code-location) - (frame :reader frame-function-mismatch-frame :initarg :frame) - (form :reader frame-function-mismatch-form :initarg :form)) + (frame :reader frame-fun-mismatch-frame :initarg :frame) + (form :reader frame-fun-mismatch-form :initarg :form)) (:report (lambda (condition stream) (format stream "~&Form was preprocessed for ~S,~% but called on ~S:~% ~S" - (frame-function-mismatch-code-location condition) - (frame-function-mismatch-frame condition) - (frame-function-mismatch-form condition))))) + (frame-fun-mismatch-code-location condition) + (frame-fun-mismatch-frame condition) + (frame-fun-mismatch-form condition))))) ;;; This signals debug-conditions. If they go unhandled, then signal ;;; an UNHANDLED-DEBUG-CONDITION error. @@ -187,51 +186,48 @@ ;;;; 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)) +;;; compiler DEBUG-FUNs. +(defstruct (debug-var (:constructor nil) + (:copier nil)) ;; the name of the variable - (symbol (required-argument) :type symbol) + (symbol (missing-arg) :type symbol) ;; a unique integer identification relative to other variables with the same ;; symbol - (id 0 :type sb!c::index) + (id 0 :type index) ;; Does the variable always have a valid value? (alive-p nil :type boolean)) (def!method print-object ((debug-var debug-var) stream) (print-unreadable-object (debug-var stream :type t :identity t) (format stream - "~S ~D" + "~S ~W" (debug-var-symbol debug-var) (debug-var-id debug-var)))) #!+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))) - ;; 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)) + (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))) ;;;; frames -;;; These represent call-frames on the stack. -(defstruct (frame (:constructor nil)) +;;; These represent call frames on the stack. +(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 @@ -239,238 +235,152 @@ ;; to the control stack for the given frame. This lets us get the ;; next frame down and the return-pc for that frame. (%down :unparsed :type (or frame (member nil :unparsed))) - ;; the debug-function for the function whose call this frame - ;; represents - (debug-function nil :type debug-function) - ;; the code-location to continue upon return to frame + ;; the DEBUG-FUN for the function whose call this frame represents + (debug-fun nil :type debug-fun) + ;; the CODE-LOCATION where the frame's DEBUG-FUN will continue + ;; running when program execution returns to this frame. If someone + ;; interrupted this frame, the result could be an unknown + ;; CODE-LOCATION. (code-location nil :type code-location) ;; an a-list of catch-tags to code-locations (%catches :unparsed :type (or list (member :unparsed))) - ;; pointer to frame on control stack. (unexported) When this frame - ;; is an interpreted-frame, this pointer is an index into the - ;; interpreter's stack. + ;; pointer to frame on control stack (unexported) pointer ;; This is the frame's number for prompt printing. Top is zero. (number 0 :type index)) -#!+sb-doc -(setf (fdocumentation 'frame-up 'function) - "Returns 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.") - -#!+sb-doc -(setf (fdocumentation 'frame-code-location 'function) - "Returns 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.") - (defstruct (compiled-frame (:include frame) (:constructor make-compiled-frame - (pointer up debug-function code-location number - #!+gengc saved-state-chain - &optional escaped))) + (pointer up debug-fun code-location number + &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 - ;; a pointer to an os_context_t, i.e. the third argument to an - ;; SA_SIGACTION-style signal handler. On the gengc system, this is a - ;; state pointer from SAVED-STATE-CHAIN. - escaped - ;; a list of SAPs to saved states. Each time we unwind past an - ;; exception, we pop the next entry off this list. When we get to - ;; the end of the list, there is nothing else on the stack. - #!+gengc (saved-state-chain nil :type list)) + ;; saved when we were interrupted, an os_context_t, i.e. the third + ;; argument to an SA_SIGACTION-style signal handler. + escaped) (def!method print-object ((obj compiled-frame) str) (print-unreadable-object (obj str :type t) (format str "~S~:[~;, interrupted~]" - (debug-function-name (frame-debug-function obj)) + (debug-fun-name (frame-debug-fun obj)) (compiled-frame-escaped obj)))) - -(defstruct (interpreted-frame - (: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 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 + +;;;; DEBUG-FUNs ;;; These exist for caching data stored in packed binary form in -;;; compiler debug-functions. *COMPILED-DEBUG-FUNCTIONS* maps a -;;; SB!C::DEBUG-FUNCTION to a DEBUG-FUNCTION. There should only be one -;;; DEBUG-FUNCTION in existence for any function; that is, all -;;; 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 - ;; DEBUG-FUNCTION-LAMBDA-LIST. +;;; compiler DEBUG-FUNs. *COMPILED-DEBUG-FUNS* maps a SB!C::DEBUG-FUN +;;; to a DEBUG-FUN. There should only be one DEBUG-FUN in existence +;;; for any function; that is, all CODE-LOCATIONs and other objects +;;; that reference DEBUG-FUNs point to unique objects. This is +;;; due to the overhead in cached information. +(defstruct (debug-fun (:constructor nil) + (:copier nil)) + ;; some representation of the function arguments. See + ;; DEBUG-FUN-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) +(def!method print-object ((obj debug-fun) stream) (print-unreadable-object (obj stream :type t) - (prin1 (debug-function-name obj) stream))) - -(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 nil :type sb!c::compiled-debug-function) - ;; Code object. (unexported). + (prin1 (debug-fun-name obj) stream))) + +(defstruct (compiled-debug-fun + (:include debug-fun) + (:constructor %make-compiled-debug-fun + (compiler-debug-fun component)) + (:copier nil)) + ;; compiler's dumped DEBUG-FUN information (unexported) + (compiler-debug-fun nil :type sb!c::compiled-debug-fun) + ;; code object (unexported). component - ;; The :FUNCTION-START breakpoint (if any) used to facilitate - ;; function end breakpoints. + ;; the :FUN-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 -;;; COMPILED-DEBUG-FUNCTIONs, so we can get at cached stuff and not -;;; duplicate COMPILED-DEBUG-FUNCTION structures. -(defvar *compiled-debug-functions* (make-hash-table :test 'eq)) +;;; This maps SB!C::COMPILED-DEBUG-FUNs to +;;; COMPILED-DEBUG-FUNs, so we can get at cached stuff and not +;;; duplicate COMPILED-DEBUG-FUN structures. +(defvar *compiled-debug-funs* (make-hash-table :test 'eq)) -;;; Make a COMPILED-DEBUG-FUNCTION for a SB!C::COMPILER-DEBUG-FUNCTION +;;; Make a COMPILED-DEBUG-FUN for a SB!C::COMPILER-DEBUG-FUN ;;; and its component. This maps the latter to the former in -;;; *COMPILED-DEBUG-FUNCTIONS*. If there already is a -;;; COMPILED-DEBUG-FUNCTION, then this returns it from -;;; *COMPILED-DEBUG-FUNCTIONS*. -(defun make-compiled-debug-function (compiler-debug-fun component) - (or (gethash compiler-debug-fun *compiled-debug-functions*) - (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)))) +;;; *COMPILED-DEBUG-FUNS*. If there already is a +;;; COMPILED-DEBUG-FUN, then this returns it from +;;; *COMPILED-DEBUG-FUNS*. +(defun make-compiled-debug-fun (compiler-debug-fun component) + (or (gethash compiler-debug-fun *compiled-debug-funs*) + (setf (gethash compiler-debug-fun *compiled-debug-funs*) + (%make-compiled-debug-fun compiler-debug-fun component)))) + +(defstruct (bogus-debug-fun + (:include debug-fun) + (:constructor make-bogus-debug-fun + (%name &aux + (%lambda-list nil) + (%debug-vars 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))))) - +(defvar *ir1-lambda-debug-fun* (make-hash-table :test 'eq)) + ;;;; 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) - (prin1 (debug-block-function-name obj) str))) + (prin1 (debug-block-fun-name obj) str))) #!+sb-doc (setf (fdocumentation 'debug-block-successors 'function) - "Returns the list of possible code-locations where execution may continue + "Return the list of possible code-locations where execution may continue when the basic-block represented by debug-block completes its execution.") #!+sb-doc (setf (fdocumentation 'debug-block-elsewhere-p 'function) - "Returns whether debug-block represents elsewhere code.") + "Return whether debug-block represents elsewhere code.") (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. - (offset nil :type sb!c::index) + (offset nil :type index) ;; The original instruction replaced by the breakpoint. (instruction nil :type (or null (unsigned-byte 32))) ;; A list of user breakpoints at this location. @@ -478,26 +388,27 @@ (def!method print-object ((obj breakpoint-data) str) (print-unreadable-object (obj str :type t) (format str "~S at ~S" - (debug-function-name - (debug-function-from-pc (breakpoint-data-component obj) - (breakpoint-data-offset obj))) + (debug-fun-name + (debug-fun-from-pc (breakpoint-data-component obj) + (breakpoint-data-offset obj))) (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 + ;; list of values. Values are supplied for :FUN-END breakpoints ;; as values to return for the function containing the breakpoint. - ;; :FUNCTION-END breakpoint hook-functions also take a cookie + ;; :FUN-END breakpoint hook-functions also take a cookie ;; argument. See COOKIE-FUN slot. (hook-function nil :type function) - ;; CODE-LOCATION or DEBUG-FUNCTION - (what nil :type (or code-location debug-function)) - ;; :CODE-LOCATION, :FUNCTION-START, or :FUNCTION-END for that kind + ;; CODE-LOCATION or DEBUG-FUN + (what nil :type (or code-location debug-fun)) + ;; :CODE-LOCATION, :FUN-START, or :FUN-END for that kind ;; of breakpoint. :UNKNOWN-RETURN-PARTNER if this is the partner of ;; a :code-location breakpoint at an :UNKNOWN-RETURN code-location. - (kind nil :type (member :code-location :function-start :function-end + (kind nil :type (member :code-location :fun-start :fun-end :unknown-return-partner)) ;; Status helps the user and the implementation. (status :inactive :type (member :active :inactive :deleted)) @@ -509,7 +420,7 @@ ;; breakpoint for the other one, or NIL if this isn't at an ;; :UNKNOWN-RETURN code location. (unknown-return-partner nil :type (or null breakpoint)) - ;; :FUNCTION-END breakpoints use a breakpoint at the :FUNCTION-START + ;; :FUN-END breakpoints use a breakpoint at the :FUN-START ;; to establish the end breakpoint upon function entry. We do this ;; by frobbing the LRA to jump to a special piece of code that ;; breaks and provides the return values for the returnee. This slot @@ -517,8 +428,8 @@ ;; and delete it. (start-helper nil :type (or null breakpoint)) ;; This is a hook users supply to get a dynamically unique cookie - ;; for identifying :FUNCTION-END breakpoint executions. That is, if - ;; there is one :FUNCTION-END breakpoint, but there may be multiple + ;; for identifying :FUN-END breakpoint executions. That is, if + ;; there is one :FUN-END breakpoint, but there may be multiple ;; pending calls of its function on the stack. This function takes ;; the cookie, and the hook-function takes the cookie too. (cookie-fun nil :type (or null function)) @@ -531,132 +442,73 @@ "~S~:[~;~:*~S~]" (etypecase what (code-location what) - (debug-function (debug-function-name what))) + (debug-fun (debug-fun-name what))) (etypecase what (code-location nil) - (debug-function (breakpoint-kind obj))))))) - -#!+sb-doc -(setf (fdocumentation 'breakpoint-hook-function 'function) - "Returns the breakpoint's function the system calls when execution encounters - the breakpoint, and it is active. This is SETF'able.") - -#!+sb-doc -(setf (fdocumentation 'breakpoint-what 'function) - "Returns the breakpoint's what specification.") - -#!+sb-doc -(setf (fdocumentation 'breakpoint-kind 'function) - "Returns the breakpoint's kind specification.") - + (debug-fun (breakpoint-kind obj))))))) + ;;;; CODE-LOCATIONs -(defstruct (code-location (:constructor nil)) - ;; This is the debug-function containing code-location. - (debug-function nil :type debug-function) +(defstruct (code-location (:constructor nil) + (:copier nil)) + ;; the DEBUG-FUN containing this CODE-LOCATION + (debug-fun nil :type debug-fun) ;; This is initially :UNSURE. Upon first trying to access an - ;; :unparsed slot, if the data is unavailable, then this becomes t, + ;; :UNPARSED slot, if the data is unavailable, then this becomes T, ;; and the code-location is unknown. If the data is available, this - ;; becomes nil, a known location. We can't use a separate type + ;; becomes NIL, a known location. We can't use a separate type ;; code-location for this since we must return code-locations before ;; we can tell whether they're known or unknown. For example, when ;; parsing the stack, we don't want to unpack all the variables and ;; blocks just to make frames. (%unknown-p :unsure :type (member t nil :unsure)) - ;; This is the debug-block containing code-location. Possibly toss - ;; this out and just find it in the blocks cache in debug-function. + ;; the DEBUG-BLOCK containing CODE-LOCATION. XXX Possibly toss this + ;; out and just find it in the blocks cache in DEBUG-FUN. (%debug-block :unparsed :type (or debug-block (member :unparsed))) ;; This is the number of forms processed by the compiler or loader - ;; before the top-level form containing this code-location. - (%tlf-offset :unparsed :type (or sb!c::index (member :unparsed))) + ;; before the top level form containing this code-location. + (%tlf-offset :unparsed :type (or index (member :unparsed))) ;; This is the depth-first number of the node that begins - ;; code-location within its top-level form. - (%form-number :unparsed :type (or sb!c::index (member :unparsed)))) + ;; code-location within its top level form. + (%form-number :unparsed :type (or index (member :unparsed)))) (def!method print-object ((obj code-location) str) (print-unreadable-object (obj str :type t) - (prin1 (debug-function-name (code-location-debug-function obj)) + (prin1 (debug-fun-name (code-location-debug-fun obj)) str))) -#!+sb-doc -(setf (fdocumentation 'code-location-debug-function 'function) - "Returns the debug-function representing information about the function - corresponding to the code-location.") - (defstruct (compiled-code-location (:include code-location) (:constructor make-known-code-location - (pc debug-function %tlf-offset %form-number + (pc debug-fun %tlf-offset %form-number %live-set kind &aux (%unknown-p nil))) - (:constructor make-compiled-code-location (pc debug-function))) - ;; 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 - ;; DEBUG-FUNCTION-DEBUG-VARS indicating whether the variable has a + (:constructor make-compiled-code-location (pc debug-fun)) + (:copier nil)) + ;; an index into DEBUG-FUN's component slot + (pc nil :type index) + ;; a bit-vector indexed by a variable's position in + ;; DEBUG-FUN-DEBUG-VARS indicating whether the variable has a ;; valid value at this code-location. (unexported). (%live-set :unparsed :type (or simple-bit-vector (member :unparsed))) ;; (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 -;;; and LRAs used for :function-end breakpoints. When a components -;;; debug-info slot is :bogus-lra, then the real-lra-slot contains the +;;; This is used in FIND-ESCAPED-FRAME and with the bogus components +;;; and LRAs used for :FUN-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 ;;; component which appeared in some frame's LRA location. (defconstant real-lra-slot sb!vm:code-constants-offset) @@ -666,19 +518,18 @@ (defun current-fp () (current-fp)) (defun stack-ref (s n) (stack-ref s n)) (defun %set-stack-ref (s n value) (%set-stack-ref s n value)) -(defun function-code-header (fun) (function-code-header fun)) -#!-gengc (defun lra-code-header (lra) (lra-code-header lra)) +(defun fun-code-header (fun) (fun-code-header fun)) +(defun lra-code-header (lra) (lra-code-header lra)) (defun make-lisp-obj (value) (make-lisp-obj value)) (defun get-lisp-obj-address (thing) (get-lisp-obj-address thing)) -(defun function-word-offset (fun) (function-word-offset fun)) +(defun fun-word-offset (fun) (fun-word-offset fun)) #!-sb-fluid (declaim (inline cstack-pointer-valid-p)) (defun cstack-pointer-valid-p (x) (declare (type system-area-pointer x)) #!-x86 ; stack grows toward high address values (and (sap< x (current-sp)) - (sap<= #!-gengc (int-sap control-stack-start) - #!+gengc (mutator-control-stack-base) + (sap<= (int-sap control-stack-start) x) (zerop (logand (sap-int x) #b11))) #!+x86 ; stack grows toward low address values @@ -686,15 +537,15 @@ (sap> (int-sap control-stack-end) x) (zerop (logand (sap-int x) #b11)))) -#!+(or gengc x86) -(sb!alien:def-alien-routine component-ptr-from-pc (system-area-pointer) +#!+x86 +(sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer) (pc system-area-pointer)) -#!+(or gengc x86) +#!+x86 (defun component-from-component-ptr (component-ptr) (declare (type system-area-pointer component-ptr)) (make-lisp-obj (logior (sap-int component-ptr) - sb!vm:other-pointer-type))) + sb!vm:other-pointer-lowtag))) ;;;; X86 support @@ -706,10 +557,10 @@ (let ((component-ptr (component-ptr-from-pc pc))) (unless (sap= component-ptr (int-sap #x0)) (let* ((code (component-from-component-ptr component-ptr)) - (code-header-len (* (get-header-data code) sb!vm:word-bytes)) + (code-header-len (* (get-header-data code) sb!vm:n-word-bytes)) (pc-offset (- (sap-int pc) (- (get-lisp-obj-address code) - sb!vm:other-pointer-type) + sb!vm:other-pointer-lowtag) code-header-len))) ; (format t "c-lra-fpc ~A ~A ~A~%" pc code pc-offset) (values pc-offset code))))) @@ -736,9 +587,9 @@ ;;; XXX Should probably check whether it has reached the bottom of the ;;; stack. ;;; -;;; XXX Should handle interrupted frames, both Lisp and C. At present it -;;; manages to find a fp trail, see linux hack below. -(defun x86-call-context (fp &key (depth 8)) +;;; XXX Should handle interrupted frames, both Lisp and C. At present +;;; it manages to find a fp trail, see linux hack below. +(defun x86-call-context (fp &key (depth 0)) (declare (type system-area-pointer fp) (fixnum depth)) ;;(format t "*CC ~S ~S~%" fp depth) @@ -748,11 +599,11 @@ nil) (t ;; Check the two possible frame pointers. - (let ((lisp-ocfp (sap-ref-sap fp (- (* (1+ sb!vm::ocfp-save-offset) 4)))) - (lisp-ra (sap-ref-sap fp (- (* (1+ sb!vm::return-pc-save-offset) + (let ((lisp-ocfp (sap-ref-sap fp (- (* (1+ ocfp-save-offset) 4)))) + (lisp-ra (sap-ref-sap fp (- (* (1+ return-pc-save-offset) 4)))) - (c-ocfp (sap-ref-sap fp (* 0 sb!vm:word-bytes))) - (c-ra (sap-ref-sap fp (* 1 sb!vm:word-bytes)))) + (c-ocfp (sap-ref-sap fp (* 0 sb!vm:n-word-bytes))) + (c-ra (sap-ref-sap fp (* 1 sb!vm:n-word-bytes)))) (cond ((and (sap> lisp-ocfp fp) (cstack-pointer-valid-p lisp-ocfp) (ra-pointer-valid-p lisp-ra) (sap> c-ocfp fp) (cstack-pointer-valid-p c-ocfp) @@ -762,15 +613,20 @@ lisp-ocfp lisp-ra c-ocfp c-ra) ;; Look forward another step to check their validity. (let ((lisp-path-fp (x86-call-context lisp-ocfp - :depth (- depth 1))) - (c-path-fp (x86-call-context c-ocfp :depth (- depth 1)))) + :depth (1+ depth))) + (c-path-fp (x86-call-context c-ocfp :depth (1+ depth)))) (cond ((and lisp-path-fp c-path-fp) - ;; Both still seem valid - choose the smallest. - #+nil (format t "debug: both still valid ~S ~S ~S ~S~%" - lisp-ocfp lisp-ra c-ocfp c-ra) - (if (sap< lisp-ocfp c-ocfp) - (values lisp-ra lisp-ocfp) - (values c-ra c-ocfp))) + ;; Both still seem valid - choose the lisp frame. + #+nil (when (zerop depth) + (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) + (values lisp-ra lisp-ocfp) + (values c-ra c-ocfp)) + #-freebsd + (values lisp-ra lisp-ocfp)) (lisp-path-fp ;; The lisp convention is looking good. #+nil (format t "*C lisp-ocfp ~S ~S~%" lisp-ocfp lisp-ra) @@ -807,61 +663,48 @@ (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." + (/noshow0 "entering TOP-FRAME") (multiple-value-bind (fp pc) (%caller-frame-and-pc) - (possibly-an-interpreted-frame - (compute-calling-frame (descriptor-sap fp) - #!-gengc pc #!+gengc (descriptor-sap pc) - nil) - nil))) + (compute-calling-frame (descriptor-sap fp) pc 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." + (/noshow0 "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))) + (let ((debug-fun (frame-debug-fun frame))) + (/noshow0 "in DOWN :UNPARSED case") (setf (frame-%down frame) (etypecase debug-fun - (compiled-debug-function - (let ((c-d-f (compiled-debug-function-compiler-debug-fun + (compiled-debug-fun + (let ((c-d-f (compiled-debug-fun-compiler-debug-fun debug-fun))) - (possibly-an-interpreted-frame - (compute-calling-frame - (descriptor-sap - (get-context-value - real sb!vm::ocfp-save-offset - (sb!c::compiled-debug-function-old-fp c-d-f))) - #!-gengc + (compute-calling-frame + (descriptor-sap (get-context-value - real sb!vm::lra-save-offset - (sb!c::compiled-debug-function-return-pc c-d-f)) - #!+gengc - (descriptor-sap - (get-context-value - real sb!vm::ra-save-offset - (sb!c::compiled-debug-function-return-pc c-d-f))) - frame) + frame ocfp-save-offset + (sb!c::compiled-debug-fun-old-fp c-d-f))) + (get-context-value + frame lra-save-offset + (sb!c::compiled-debug-fun-return-pc c-d-f)) frame))) - (bogus-debug-function - (let ((fp (frame-pointer real))) + (bogus-debug-fun + (let ((fp (frame-pointer frame))) (when (cstack-pointer-valid-p fp) #!+x86 (multiple-value-bind (ra ofp) (x86-call-context fp) @@ -869,18 +712,15 @@ #!-x86 (compute-calling-frame #!-alpha - (sap-ref-sap fp (* sb!vm::ocfp-save-offset - sb!vm:word-bytes)) + (sap-ref-sap fp (* ocfp-save-offset + sb!vm:n-word-bytes)) #!+alpha (int-sap - (sap-ref-32 fp (* sb!vm::ocfp-save-offset - sb!vm:word-bytes))) - - #!-gengc - (stack-ref fp sb!vm::lra-save-offset) - #!+gengc - (sap-ref-sap fp (* sb!vm::ra-save-offset - sb!vm:word-bytes)) + (sap-ref-32 fp (* ocfp-save-offset + sb!vm:n-word-bytes))) + + (stack-ref fp lra-save-offset) + frame))))))) down))) @@ -890,7 +730,7 @@ #!-x86 (defun get-context-value (frame stack-slot loc) (declare (type compiled-frame frame) (type unsigned-byte stack-slot) - (type sb!c::sc-offset loc)) + (type sb!c:sc-offset loc)) (let ((pointer (frame-pointer frame)) (escaped (compiled-frame-escaped frame))) (if escaped @@ -899,21 +739,21 @@ #!+x86 (defun get-context-value (frame stack-slot loc) (declare (type compiled-frame frame) (type unsigned-byte stack-slot) - (type sb!c::sc-offset loc)) + (type sb!c:sc-offset loc)) (let ((pointer (frame-pointer frame)) (escaped (compiled-frame-escaped frame))) (if escaped (sub-access-debug-var-slot pointer loc escaped) (ecase stack-slot - (#.sb!vm::ocfp-save-offset + (#.ocfp-save-offset (stack-ref pointer stack-slot)) - (#.sb!vm::lra-save-offset + (#.lra-save-offset (sap-ref-sap pointer (- (* (1+ stack-slot) 4)))))))) #!-x86 (defun (setf get-context-value) (value frame stack-slot loc) (declare (type compiled-frame frame) (type unsigned-byte stack-slot) - (type sb!c::sc-offset loc)) + (type sb!c:sc-offset loc)) (let ((pointer (frame-pointer frame)) (escaped (compiled-frame-escaped frame))) (if escaped @@ -923,68 +763,22 @@ #!+x86 (defun (setf get-context-value) (value frame stack-slot loc) (declare (type compiled-frame frame) (type unsigned-byte stack-slot) - (type sb!c::sc-offset loc)) + (type sb!c:sc-offset loc)) (let ((pointer (frame-pointer frame)) (escaped (compiled-frame-escaped frame))) (if escaped (sub-set-debug-var-slot pointer loc value escaped) (ecase stack-slot - (#.sb!vm::ocfp-save-offset + (#.ocfp-save-offset (setf (stack-ref pointer stack-slot) value)) - (#.sb!vm::lra-save-offset + (#.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. -(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))))) - ;;; This returns a frame for the one existing in time immediately ;;; prior to the frame referenced by current-fp. This is current-fp's ;;; caller or the next frame down the control stack. If there is no -;;; down frame, this returns nil for the bottom of the stack. Up-frame -;;; is the up link for the resulting frame object, and it is nil when +;;; down frame, this returns NIL for the bottom of the stack. UP-FRAME +;;; is the up link for the resulting frame object, and it is null when ;;; we call this to get the top of the stack. ;;; ;;; The current frame contains the pointer to the temporally previous @@ -994,7 +788,7 @@ ;;; Note: Sometimes LRA is actually a fixnum. This happens when lisp ;;; calls into C. In this case, the code object is stored on the stack ;;; after the LRA, and the LRA is the word offset. -#!-(or gengc x86) +#!-x86 (defun compute-calling-frame (caller lra up-frame) (declare (type system-area-pointer caller)) (when (cstack-pointer-valid-p caller) @@ -1004,13 +798,13 @@ (if (fixnump lra) (let ((fp (frame-pointer up-frame))) (values lra - (stack-ref fp (1+ sb!vm::lra-save-offset)))) + (stack-ref fp (1+ lra-save-offset)))) (values (get-header-data lra) (lra-code-header lra))) (if code (values code (* (1+ (- word-offset (get-header-data code))) - sb!vm:word-bytes) + sb!vm:n-word-bytes) nil) (values :foreign-function 0 @@ -1022,211 +816,220 @@ (compute-calling-frame caller real-lra up-frame)) (let ((d-fun (case code (:undefined-function - (make-bogus-debug-function + (make-bogus-debug-fun "undefined function")) (:foreign-function - (make-bogus-debug-function + (make-bogus-debug-fun "foreign function call land")) ((nil) - (make-bogus-debug-function + (make-bogus-debug-fun "bogus stack frame")) (t - (debug-function-from-pc code pc-offset))))) + (debug-fun-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)))))) - #!+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) + (/noshow0 "entering COMPUTE-CALLING-FRAME") (when (cstack-pointer-valid-p caller) -; (format t "ccf2~%") + (/noshow0 "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))))) - -#!-(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")) + (/noshow0 "at COND") + (cond (code + (/noshow0 "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 + (/noshow0 "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-fun + "undefined function")) + (:foreign-function + (make-bogus-debug-fun + "foreign function call land")) + ((nil) + (make-bogus-debug-fun + "bogus stack frame")) + (t + (debug-fun-from-pc code pc-offset))))) + (/noshow0 "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)) - (dotimes (index sb!impl::*free-interrupt-context-index* (values nil 0 nil)) + (/noshow0 "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)) + (/noshow0 "at head of WITH-ALIEN") (let ((context (sb!alien:deref lisp-interrupt-contexts index))) + (/noshow0 "got CONTEXT") (when (= (sap-int frame-pointer) (sb!vm:context-register context sb!vm::cfp-offset)) (without-gcing + (/noshow0 "in WITHOUT-GCING") (let* ((component-ptr (component-ptr-from-pc (sb!vm:context-pc context))) - (code (if (sap= component-ptr (int-sap #x0)) - nil ; FIXME: UNLESS might be clearer than IF. - (component-from-component-ptr component-ptr)))) + (code (unless (sap= component-ptr (int-sap #x0)) + (component-from-component-ptr component-ptr)))) + (/noshow0 "got CODE") (when (null code) (return (values code 0 context))) (let* ((code-header-len (* (get-header-data code) - sb!vm:word-bytes)) + sb!vm:n-word-bytes)) (pc-offset (- (sap-int (sb!vm:context-pc context)) (- (get-lisp-obj-address code) - sb!vm:other-pointer-type) + sb!vm:other-pointer-lowtag) code-header-len))) + (/noshow "got PC-OFFSET") (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. + sb!vm:n-word-bytes)) + ;; We were in an assembly routine. Therefore, use the + ;; LRA as the pc. + ;; + ;; FIXME: Should this be WARN or ERROR or what? (format t "** pc-offset ~S not in code obj ~S?~%" pc-offset code)) + (/noshow0 "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:n-word-bytes)) + (pc-offset + (- (sap-int (sb!vm:context-pc scp)) + (- (get-lisp-obj-address code) + sb!vm:other-pointer-lowtag) + 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:n-word-bytes)) + (unless (<= 0 pc-offset + (* (code-header-ref code sb!vm:code-code-size-slot) + sb!vm:n-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. -#!-gengc (defun code-object-from-bits (bits) (declare (type (unsigned-byte 32) bits)) (let ((object (make-lisp-obj bits))) (if (functionp object) - (or (function-code-header object) + (or (fun-code-header object) :undefined-function) - (let ((lowtag (get-lowtag object))) - (if (= lowtag sb!vm:other-pointer-type) - (let ((type (get-type object))) - (cond ((= type sb!vm:code-header-type) + (let ((lowtag (lowtag-of object))) + (if (= lowtag sb!vm:other-pointer-lowtag) + (let ((widetag (widetag-of object))) + (cond ((= widetag sb!vm:code-header-widetag) object) - ((= type sb!vm:return-pc-header-type) + ((= widetag sb!vm:return-pc-header-widetag) (lra-code-header object)) (t nil)))))))) - -;;; SB!KERNEL:*SAVED-STATE-CHAIN* -- maintained by the C code as a -;;; list of SAPs, each SAP pointing to a saved exception state. -#!+gengc -(declaim (special *saved-state-chain*)) - -;;; CMU CL had -;;; (DEFUN LOOKUP-TRACE-TABLE-ENTRY (COMPONENT PC) ..) -;;; for this case, but it hasn't been maintained in SBCL. -#!+gengc -(eval-when (:compile-toplevel :load-toplevel :execute) - (error "hopelessly stale")) - -;;; CMU CL had -;;; (DEFUN EXTRACT-INFO-FROM-STATE (STATE) ..) -;;; for this case, but it hasn't been maintained in SBCL. -#!+gengc -(eval-when (:compile-toplevel :load-toplevel :execute) - (error "hopelessly stale")) - -;;; CMU CL had -;;; (DEFUN COMPUTE-CALLING-FRAME (OCFP RA UP-FRAME) ..) -;;; for this case, but it hasn't been maintained in SBCL. -#!+gengc -(eval-when (:compile-toplevel :load-toplevel :execute) - (error "hopelessly stale")) ;;;; frame utilities -;;; This returns a COMPILED-DEBUG-FUNCTION for code and pc. We fetch -;;; the SB!C::DEBUG-INFO and run down its function-map to get a -;;; SB!C::COMPILED-DEBUG-FUNCTION from the pc. The result only needs -;;; to reference the component, for function constants, and the -;;; SB!C::COMPILED-DEBUG-FUNCTION. -(defun debug-function-from-pc (component pc) +;;; This returns a COMPILED-DEBUG-FUN for COMPONENT and PC. We fetch the +;;; SB!C::DEBUG-INFO and run down its FUN-MAP to get a +;;; SB!C::COMPILED-DEBUG-FUN from the PC. The result only needs to +;;; reference the COMPONENT, for function constants, and the +;;; SB!C::COMPILED-DEBUG-FUN. +(defun debug-fun-from-pc (component pc) (let ((info (%code-debug-info component))) (cond ((not info) (debug-signal 'no-debug-info :code-component component)) ((eq info :bogus-lra) - (make-bogus-debug-function "function end breakpoint")) + (make-bogus-debug-fun "function end breakpoint")) (t - (let* ((function-map (get-debug-info-function-map info)) - (len (length function-map))) - (declare (simple-vector function-map)) + (let* ((fun-map (sb!c::compiled-debug-info-fun-map info)) + (len (length fun-map))) + (declare (type simple-vector fun-map)) (if (= len 1) - (make-compiled-debug-function (svref function-map 0) component) + (make-compiled-debug-fun (svref fun-map 0) component) (let ((i 1) (elsewhere-p - (>= pc (sb!c::compiled-debug-function-elsewhere-pc - (svref function-map 0))))) - ;; FIXME: I don't think SB!C is the home package of INDEX. - (declare (type sb!c::index i)) + (>= pc (sb!c::compiled-debug-fun-elsewhere-pc + (svref fun-map 0))))) + (declare (type sb!int:index i)) (loop (when (or (= i len) (< pc (if elsewhere-p - (sb!c::compiled-debug-function-elsewhere-pc - (svref function-map (1+ i))) - (svref function-map i)))) - (return (make-compiled-debug-function - (svref function-map (1- i)) + (sb!c::compiled-debug-fun-elsewhere-pc + (svref fun-map (1+ i))) + (svref fun-map i)))) + (return (make-compiled-debug-fun + (svref fun-map (1- i)) component))) (incf i 2))))))))) -;;; This returns a code-location for the COMPILED-DEBUG-FUNCTION, +;;; This returns a code-location for the COMPILED-DEBUG-FUN, ;;; DEBUG-FUN, and the pc into its code vector. If we stopped at a ;;; breakpoint, find the CODE-LOCATION for that breakpoint. Otherwise, ;;; make an :UNSURE code location, so it can be filled in when we ;;; figure out what is going on. (defun code-location-from-pc (debug-fun pc escaped) - (or (and (compiled-debug-function-p debug-fun) + (or (and (compiled-debug-fun-p debug-fun) escaped (let ((data (breakpoint-data - (compiled-debug-function-component debug-fun) + (compiled-debug-fun-component debug-fun) pc nil))) (when (and data (breakpoint-data-breakpoints data)) (let ((what (breakpoint-what @@ -1235,110 +1038,96 @@ 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 (mutator-current-catch-block)) - (res nil) - (fp (frame-pointer (frame-real-frame frame)))) - (loop - (when (zerop (sap-int catch)) (return (nreverse res))) - (when (sap= fp - #!-alpha - (sap-ref-sap catch - (* sb!vm:catch-block-current-cont-slot - sb!vm:word-bytes)) - #!+alpha - (:int-sap - (sap-ref-32 catch - (* sb!vm:catch-block-current-cont-slot - sb!vm:word-bytes)))) - (let* (#!-(or gengc x86) - (lra (stack-ref catch sb!vm:catch-block-entry-pc-slot)) - #!+(or gengc x86) - (ra (sap-ref-sap - catch (* sb!vm:catch-block-entry-pc-slot - sb!vm:word-bytes))) - #!-x86 - (component - (stack-ref catch sb!vm:catch-block-current-code-slot)) - #!+x86 - (component (component-from-component-ptr - (component-ptr-from-pc ra))) - (offset - #!-(or gengc x86) - (* (- (1+ (get-header-data lra)) - (get-header-data component)) - sb!vm:word-bytes) - #!+gengc - (+ (- (sap-int ra) - (get-lisp-obj-address component) - (get-header-data component)) - sb!vm:other-pointer-type) - #!+x86 - (- (sap-int ra) - (- (get-lisp-obj-address component) - sb!vm:other-pointer-type) - (* (get-header-data component) sb!vm:word-bytes)))) - (push (cons #!-x86 - (stack-ref catch sb!vm:catch-block-tag-slot) - #!+x86 - (make-lisp-obj - (sap-ref-32 catch (* sb!vm:catch-block-tag-slot - sb!vm:word-bytes))) - (make-compiled-code-location - offset (frame-debug-function frame))) - res))) - (setf catch - #!-alpha - (sap-ref-sap catch - (* sb!vm:catch-block-previous-catch-slot - sb!vm:word-bytes)) - #!+alpha - (:int-sap - (sap-ref-32 catch - (* sb!vm:catch-block-previous-catch-slot - sb!vm:word-bytes))))))) - -;;; If an interpreted frame, return the real frame, otherwise frame. -(defun frame-real-frame (frame) - (etypecase frame - (compiled-frame frame) - (interpreted-frame (interpreted-frame-real-frame frame)))) + (let ((catch (descriptor-sap sb!vm:*current-catch-block*)) + (reversed-result nil) + (fp (frame-pointer frame))) + (loop until (zerop (sap-int catch)) + finally (return (nreverse reversed-result)) + do + (when (sap= fp + #!-alpha + (sap-ref-sap catch + (* sb!vm:catch-block-current-cont-slot + sb!vm:n-word-bytes)) + #!+alpha + (int-sap + (sap-ref-32 catch + (* sb!vm:catch-block-current-cont-slot + sb!vm:n-word-bytes)))) + (let* (#!-x86 + (lra (stack-ref catch sb!vm:catch-block-entry-pc-slot)) + #!+x86 + (ra (sap-ref-sap + catch (* sb!vm:catch-block-entry-pc-slot + sb!vm:n-word-bytes))) + #!-x86 + (component + (stack-ref catch sb!vm:catch-block-current-code-slot)) + #!+x86 + (component (component-from-component-ptr + (component-ptr-from-pc ra))) + (offset + #!-x86 + (* (- (1+ (get-header-data lra)) + (get-header-data component)) + sb!vm:n-word-bytes) + #!+x86 + (- (sap-int ra) + (- (get-lisp-obj-address component) + sb!vm:other-pointer-lowtag) + (* (get-header-data component) sb!vm:n-word-bytes)))) + (push (cons #!-x86 + (stack-ref catch sb!vm:catch-block-tag-slot) + #!+x86 + (make-lisp-obj + (sap-ref-32 catch (* sb!vm:catch-block-tag-slot + sb!vm:n-word-bytes))) + (make-compiled-code-location + offset (frame-debug-fun frame))) + reversed-result))) + (setf catch + #!-alpha + (sap-ref-sap catch + (* sb!vm:catch-block-previous-catch-slot + sb!vm:n-word-bytes)) + #!+alpha + (int-sap + (sap-ref-32 catch + (* sb!vm:catch-block-previous-catch-slot + sb!vm:n-word-bytes))))))) -;;;; operations on DEBUG-FUNCTIONs - -(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." +;;;; operations on DEBUG-FUNs + +;;; Execute the forms in a context with BLOCK-VAR bound to each +;;; DEBUG-BLOCK in DEBUG-FUN successively. Result is an optional +;;; form to execute for return values, and DO-DEBUG-FUN-BLOCKS +;;; returns nil if there is no result form. This signals a +;;; NO-DEBUG-BLOCKS condition when the DEBUG-FUN lacks +;;; DEBUG-BLOCK information. +(defmacro do-debug-fun-blocks ((block-var debug-fun &optional result) + &body body) (let ((blocks (gensym)) (i (gensym))) - `(let ((,blocks (debug-function-debug-blocks ,debug-function))) + `(let ((,blocks (debug-fun-debug-blocks ,debug-fun))) (declare (simple-vector ,blocks)) (dotimes (,i (length ,blocks) ,result) (let ((,block-var (svref ,blocks ,i))) ,@body))))) -(defmacro do-debug-function-variables ((var debug-function &optional result) +;;; Execute body in a context with VAR bound to each DEBUG-VAR in +;;; DEBUG-FUN. This returns the value of executing result (defaults to +;;; nil). This may iterate over only some of DEBUG-FUN's variables or +;;; none depending on debug policy; for example, possibly the +;;; compilation only preserved argument information. +(defmacro do-debug-fun-variables ((var debug-fun &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))) + `(let ((,vars (debug-fun-debug-vars ,debug-fun))) (declare (type (or null simple-vector) ,vars)) (if ,vars (dotimes (,i (length ,vars) ,result) @@ -1346,76 +1135,63 @@ ,@body)) ,result)))) -(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))) +;;; Return the object of type FUNCTION associated with the DEBUG-FUN, +;;; or NIL if the function is unavailable or is non-existent as a user +;;; callable function object. +(defun debug-fun-fun (debug-fun) + (let ((cached-value (debug-fun-%function debug-fun))) (if (eq cached-value :unparsed) - (setf (debug-function-%function debug-function) - (etypecase debug-function - (compiled-debug-function + (setf (debug-fun-%function debug-fun) + (etypecase debug-fun + (compiled-debug-fun (let ((component - (compiled-debug-function-component debug-function)) + (compiled-debug-fun-component debug-fun)) (start-pc - (sb!c::compiled-debug-function-start-pc - (compiled-debug-function-compiler-debug-fun - debug-function)))) + (sb!c::compiled-debug-fun-start-pc + (compiled-debug-fun-compiler-debug-fun debug-fun)))) (do ((entry (%code-entry-points component) - (%function-next entry))) + (%simple-fun-next entry))) ((null entry) nil) (when (= start-pc - (sb!c::compiled-debug-function-start-pc - (compiled-debug-function-compiler-debug-fun - (function-debug-function entry)))) + (sb!c::compiled-debug-fun-start-pc + (compiled-debug-fun-compiler-debug-fun + (fun-debug-fun 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))) + (bogus-debug-fun nil))) cached-value))) -(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)))) - -(defun function-debug-function (fun) - #!+sb-doc - "Returns a debug-function that represents debug information for function." - (case (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))))) - ((#.sb!vm:function-header-type #.sb!vm:closure-function-header-type) - (let* ((name (%function-name fun)) - (component (function-code-header fun)) +;;; Return the name of the function represented by DEBUG-FUN. This may +;;; be a string or a cons; do not assume it is a symbol. +(defun debug-fun-name (debug-fun) + (declare (type debug-fun debug-fun)) + (etypecase debug-fun + (compiled-debug-fun + (sb!c::compiled-debug-fun-name + (compiled-debug-fun-compiler-debug-fun debug-fun))) + (bogus-debug-fun + (bogus-debug-fun-%name debug-fun)))) + +;;; Return a DEBUG-FUN that represents debug information for FUN. +(defun fun-debug-fun (fun) + (declare (type function fun)) + (ecase (widetag-of fun) + (#.sb!vm:closure-header-widetag + (fun-debug-fun (%closure-fun fun))) + (#.sb!vm:funcallable-instance-header-widetag + (fun-debug-fun (funcallable-instance-fun fun))) + ((#.sb!vm:simple-fun-header-widetag + #.sb!vm:closure-fun-header-widetag) + (let* ((name (%simple-fun-name fun)) + (component (fun-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))) - (get-debug-info-function-map + (lambda (x) + (and (sb!c::compiled-debug-fun-p x) + (eq (sb!c::compiled-debug-fun-name x) name) + (eq (sb!c::compiled-debug-fun-kind x) nil))) + (sb!c::compiled-debug-info-fun-map (%code-debug-info component))))) (if res - (make-compiled-debug-function res component) + (make-compiled-debug-fun res component) ;; KLUDGE: comment from CMU CL: ;; This used to be the non-interpreted branch, but ;; William wrote it to return the debug-fun of fun's XEP @@ -1424,41 +1200,35 @@ ;; appropriate cases. It mostly works, and probably ;; works for all named functions anyway. ;; -- WHN 20000120 - (debug-function-from-pc component - (* (- (function-word-offset fun) - (get-header-data component)) - sb!vm:word-bytes))))))) - -(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." + (debug-fun-from-pc component + (* (- (fun-word-offset fun) + (get-header-data component)) + sb!vm:n-word-bytes))))))) + +;;; Return the kind of the function, which is one of :OPTIONAL, +;;; :EXTERNAL, :TOPLEVEL, :CLEANUP, or NIL. +(defun debug-fun-kind (debug-fun) ;; 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 + (etypecase debug-fun + (compiled-debug-fun + (sb!c::compiled-debug-fun-kind + (compiled-debug-fun-compiler-debug-fun debug-fun))) + (bogus-debug-fun nil))) -(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)))) - -(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))) +;;; Is there any variable information for DEBUG-FUN? +(defun debug-var-info-available (debug-fun) + (not (not (debug-fun-debug-vars debug-fun)))) + +;;; Return a list of DEBUG-VARs in DEBUG-FUN 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-FUN; for +;;; example, possibly DEBUG-FUN only knows about its arguments. +(defun debug-fun-symbol-variables (debug-fun symbol) + (let ((vars (ambiguous-debug-vars debug-fun (symbol-name symbol))) (package (and (symbol-package symbol) (package-name (symbol-package symbol))))) (delete-if (if (stringp package) @@ -1470,13 +1240,14 @@ (stringp (debug-var-package-name var)))) vars))) -(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." +;;; Return a list of DEBUG-VARs in DEBUG-FUN whose names contain +;;; NAME-PREFIX-STRING as an initial substring. The result of this +;;; function is limited to the availability of variable information in +;;; debug-fun; for example, possibly debug-fun only knows +;;; about its arguments. +(defun ambiguous-debug-vars (debug-fun name-prefix-string) (declare (simple-string name-prefix-string)) - (let ((variables (debug-function-debug-vars debug-function))) + (let ((variables (debug-fun-debug-vars debug-fun))) (declare (type (or null simple-vector) variables)) (if variables (let* ((len (length variables)) @@ -1515,111 +1286,44 @@ (string= x y :end1 name-len :end2 name-len)))) :end (or end (length variables))))) -(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))) +;;; Return a list representing the lambda-list for DEBUG-FUN. 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-FUN. This signals a +;;; LAMBDA-LIST-UNAVAILABLE condition when there is no argument list +;;; information. +(defun debug-fun-lambda-list (debug-fun) + (etypecase debug-fun + (compiled-debug-fun (compiled-debug-fun-lambda-list debug-fun)) + (bogus-debug-fun 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. -(defun compiled-debug-function-lambda-list (debug-function) - (let ((lambda-list (debug-function-%lambda-list debug-function))) +;;; Note: If this has to compute the lambda list, it caches it in DEBUG-FUN. +(defun compiled-debug-fun-lambda-list (debug-fun) + (let ((lambda-list (debug-fun-%lambda-list debug-fun))) (cond ((eq lambda-list :unparsed) (multiple-value-bind (args argsp) - (parse-compiled-debug-function-lambda-list debug-function) - (setf (debug-function-%lambda-list debug-function) args) + (parse-compiled-debug-fun-lambda-list debug-fun) + (setf (debug-fun-%lambda-list debug-fun) args) (if argsp args (debug-signal 'lambda-list-unavailable - :debug-function debug-function)))) + :debug-fun debug-fun)))) (lambda-list) - ((bogus-debug-function-p debug-function) + ((bogus-debug-fun-p debug-fun) nil) - ((sb!c::compiled-debug-function-arguments - (compiled-debug-function-compiler-debug-fun - debug-function)) + ((sb!c::compiled-debug-fun-arguments + (compiled-debug-fun-compiler-debug-fun debug-fun)) ;; If the packed information is there (whether empty or not) as ;; opposed to being nil, then returned our cached value (nil). nil) @@ -1627,26 +1331,25 @@ ;; Our cached value is nil, and the packed lambda-list information ;; is nil, so we don't have anything available. (debug-signal 'lambda-list-unavailable - :debug-function debug-function))))) - -;;; COMPILED-DEBUG-FUNCTION-LAMBDA-LIST calls this when a -;;; compiled-debug-function has no lambda-list information cached. It -;;; returns the lambda-list as the first value and whether there was -;;; any argument information as the second value. Therefore, nil and t -;;; means there were no arguments, but nil and nil means there was no -;;; argument information. -(defun parse-compiled-debug-function-lambda-list (debug-function) - (let ((args (sb!c::compiled-debug-function-arguments - (compiled-debug-function-compiler-debug-fun - debug-function)))) + :debug-fun debug-fun))))) + +;;; COMPILED-DEBUG-FUN-LAMBDA-LIST calls this when a +;;; COMPILED-DEBUG-FUN has no lambda list information cached. It +;;; returns the lambda list as the first value and whether there was +;;; any argument information as the second value. Therefore, +;;; (VALUES NIL T) means there were no arguments, but (VALUES NIL NIL) +;;; means there was no argument information. +(defun parse-compiled-debug-fun-lambda-list (debug-fun) + (let ((args (sb!c::compiled-debug-fun-arguments + (compiled-debug-fun-compiler-debug-fun debug-fun)))) (cond ((not args) (values nil nil)) ((eq args :minimal) - (values (coerce (debug-function-debug-vars debug-function) 'list) + (values (coerce (debug-fun-debug-vars debug-fun) 'list) t)) (t - (let ((vars (debug-function-debug-vars debug-function)) + (let ((vars (debug-fun-debug-vars debug-fun)) (i 0) (len (length args)) (res nil) @@ -1669,23 +1372,23 @@ ;; element representing the keyword or optional, ;; which is the previous one. (nconc (car res) - (list (compiled-debug-function-lambda-list-var + (list (compiled-debug-fun-lambda-list-var args (incf i) vars)))) (sb!c::rest-arg (push (list :rest - (compiled-debug-function-lambda-list-var + (compiled-debug-fun-lambda-list-var args (incf i) vars)) 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 + (compiled-debug-fun-lambda-list-var args (incf i) vars)) res)))) (optionalp @@ -1699,8 +1402,8 @@ (incf i)) (values (nreverse res) t)))))) -;;; This is used in COMPILED-DEBUG-FUNCTION-LAMBDA-LIST. -(defun compiled-debug-function-lambda-list-var (args i vars) +;;; This is used in COMPILED-DEBUG-FUN-LAMBDA-LIST. +(defun compiled-debug-fun-lambda-list-var (args i vars) (declare (type (simple-array * (*)) args) (simple-vector vars)) (let ((ele (aref args i))) @@ -1708,8 +1411,8 @@ ((eq ele 'sb!c::deleted) :deleted) (t (error "malformed arguments description"))))) -(defun compiled-debug-function-debug-info (debug-fun) - (%code-debug-info (compiled-debug-function-component debug-fun))) +(defun compiled-debug-fun-debug-info (debug-fun) + (%code-debug-info (compiled-debug-fun-component debug-fun))) ;;;; unpacking variable and basic block data @@ -1717,7 +1420,7 @@ (make-array 20 :adjustable t :fill-pointer t)) (defvar *other-parsing-buffer* (make-array 20 :adjustable t :fill-pointer t)) -;;; PARSE-DEBUG-BLOCKS, PARSE-DEBUG-VARS and UNCOMPACT-FUNCTION-MAP +;;; PARSE-DEBUG-BLOCKS and PARSE-DEBUG-VARS ;;; use this to unpack binary encoded information. It returns the ;;; values returned by the last form in body. ;;; @@ -1756,46 +1459,45 @@ ) ; EVAL-WHEN ;;; The argument is a debug internals structure. This returns the -;;; debug-blocks for debug-function, regardless of whether we have -;;; unpacked them yet. It signals a no-debug-blocks condition if it -;;; can't return the blocks. -(defun debug-function-debug-blocks (debug-function) - (let ((blocks (debug-function-blocks debug-function))) +;;; DEBUG-BLOCKs for DEBUG-FUN, regardless of whether we have unpacked +;;; them yet. It signals a NO-DEBUG-BLOCKS condition if it can't +;;; return the blocks. +(defun debug-fun-debug-blocks (debug-fun) + (let ((blocks (debug-fun-blocks debug-fun))) (cond ((eq blocks :unparsed) - (setf (debug-function-blocks debug-function) - (parse-debug-blocks debug-function)) - (unless (debug-function-blocks debug-function) + (setf (debug-fun-blocks debug-fun) + (parse-debug-blocks debug-fun)) + (unless (debug-fun-blocks debug-fun) (debug-signal 'no-debug-blocks - :debug-function debug-function)) - (debug-function-blocks debug-function)) + :debug-fun debug-fun)) + (debug-fun-blocks debug-fun)) (blocks) (t (debug-signal 'no-debug-blocks - :debug-function debug-function))))) - -;;; 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-fun debug-fun))))) + +;;; Return a SIMPLE-VECTOR of DEBUG-BLOCKs or NIL. NIL indicates there +;;; was no basic block information. +(defun parse-debug-blocks (debug-fun) + (etypecase debug-fun + (compiled-debug-fun + (parse-compiled-debug-blocks debug-fun)) + (bogus-debug-fun + (debug-signal 'no-debug-blocks :debug-fun debug-fun)))) ;;; This does some of the work of PARSE-DEBUG-BLOCKS. -(defun parse-compiled-debug-blocks (debug-function) - (let* ((debug-fun (compiled-debug-function-compiler-debug-fun - debug-function)) - (var-count (length (debug-function-debug-vars debug-function))) - (blocks (sb!c::compiled-debug-function-blocks debug-fun)) +(defun parse-compiled-debug-blocks (debug-fun) + (let* ((var-count (length (debug-fun-debug-vars debug-fun))) + (compiler-debug-fun (compiled-debug-fun-compiler-debug-fun + debug-fun)) + (blocks (sb!c::compiled-debug-fun-blocks compiler-debug-fun)) ;; KLUDGE: 8 is a hard-wired constant in the compiler for the ;; element size of the packed binary representation of the ;; blocks data. (live-set-len (ceiling var-count 8)) - (tlf-number (sb!c::compiled-debug-function-tlf-number debug-fun))) - (unless blocks (return-from parse-compiled-debug-blocks nil)) + (tlf-number (sb!c::compiled-debug-fun-tlf-number compiler-debug-fun))) + (unless blocks + (return-from parse-compiled-debug-blocks nil)) (macrolet ((aref+ (a i) `(prog1 (aref ,a ,i) (incf ,i)))) (with-parsing-buffer (blocks-buffer locations-buffer) (let ((i 0) @@ -1813,7 +1515,7 @@ (let* ((locations (dotimes (k (sb!c::read-var-integer blocks i) (result locations-buffer)) - (let ((kind (svref sb!c::compiled-code-location-kinds + (let ((kind (svref sb!c::*compiled-code-location-kinds* (aref+ blocks i))) (pc (+ last-pc (sb!c::read-var-integer blocks i))) @@ -1824,7 +1526,7 @@ (live-set (sb!c::read-packed-bit-vector live-set-len blocks i))) (vector-push-extend (make-known-code-location - pc debug-function tlf-offset + pc debug-fun tlf-offset form-number live-set kind) locations-buffer) (setf last-pc pc)))) @@ -1847,90 +1549,33 @@ (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. -(defun debug-function-debug-vars (debug-function) - (let ((vars (debug-function-%debug-vars debug-function))) +;;; it returns a SIMPLE-VECTOR of DEBUG-VARs. +(defun debug-fun-debug-vars (debug-fun) + (let ((vars (debug-fun-%debug-vars debug-fun))) (if (eq vars :unparsed) - (setf (debug-function-%debug-vars debug-function) - (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)))) + (setf (debug-fun-%debug-vars debug-fun) + (etypecase debug-fun + (compiled-debug-fun + (parse-compiled-debug-vars debug-fun)) + (bogus-debug-fun 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)) - (width (length (format nil "~D" (1- len))))) + (width (length (format nil "~W" (1- len))))) (dotimes (i len) (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.. @@ -1942,15 +1587,17 @@ ;; 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 +;;; DEBUG-FUN's SB!C::COMPILED-DEBUG-FUN, 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)) - (packed-vars (sb!c::compiled-debug-function-variables cdebug-fun)) - (args-minimal (eq (sb!c::compiled-debug-function-arguments cdebug-fun) +(defun parse-compiled-debug-vars (debug-fun) + (let* ((cdebug-fun (compiled-debug-fun-compiler-debug-fun + debug-fun)) + (packed-vars (sb!c::compiled-debug-fun-variables cdebug-fun)) + (args-minimal (eq (sb!c::compiled-debug-fun-arguments cdebug-fun) :minimal))) (when packed-vars (do ((i 0) @@ -1964,7 +1611,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) @@ -1972,7 +1620,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 @@ -1980,127 +1628,16 @@ save-sc-offset) buffer))))))) -;;;; unpacking minimal debug functions - -(eval-when (:compile-toplevel :execute) - -;;; sleazoid "macro" to keep our indentation sane in UNCOMPACT-FUNCTION-MAP -(sb!xc:defmacro make-uncompacted-debug-fun () - '(sb!c::make-compiled-debug-function - :name - (let ((base (ecase (ldb sb!c::minimal-debug-function-name-style-byte - options) - (#.sb!c::minimal-debug-function-name-symbol - (intern (sb!c::read-var-string map i) - (sb!c::compiled-debug-info-package info))) - (#.sb!c::minimal-debug-function-name-packaged - (let ((pkg (sb!c::read-var-string map i))) - (intern (sb!c::read-var-string map i) pkg))) - (#.sb!c::minimal-debug-function-name-uninterned - (make-symbol (sb!c::read-var-string map i))) - (#.sb!c::minimal-debug-function-name-component - (sb!c::compiled-debug-info-name info))))) - (if (logtest flags sb!c::minimal-debug-function-setf-bit) - `(setf ,base) - base)) - :kind (svref sb!c::minimal-debug-function-kinds - (ldb sb!c::minimal-debug-function-kind-byte options)) - :variables - (when vars-p - (let ((len (sb!c::read-var-integer map i))) - (prog1 (subseq map i (+ i len)) - (incf i len)))) - :arguments (when vars-p :minimal) - :returns - (ecase (ldb sb!c::minimal-debug-function-returns-byte options) - (#.sb!c::minimal-debug-function-returns-standard - :standard) - (#.sb!c::minimal-debug-function-returns-fixed - :fixed) - (#.sb!c::minimal-debug-function-returns-specified - (with-parsing-buffer (buf) - (dotimes (idx (sb!c::read-var-integer map i)) - (vector-push-extend (sb!c::read-var-integer map i) buf)) - (result buf)))) - :return-pc (sb!c::read-var-integer map i) - :old-fp (sb!c::read-var-integer map i) - :nfp (when (logtest flags sb!c::minimal-debug-function-nfp-bit) - (sb!c::read-var-integer map i)) - :start-pc - (progn - (setq code-start-pc (+ code-start-pc (sb!c::read-var-integer map i))) - (+ code-start-pc (sb!c::read-var-integer map i))) - :elsewhere-pc - (setq elsewhere-pc (+ elsewhere-pc (sb!c::read-var-integer map i))))) - -) ; EVAL-WHEN - -;;; Return a normal function map derived from a minimal debug info -;;; function map. This involves looping parsing -;;; minimal-debug-functions and then building a vector out of them. -;;; -;;; FIXME: This and its helper macro just above become dead code now -;;; that we no longer use compacted function maps. -(defun uncompact-function-map (info) - (declare (type sb!c::compiled-debug-info info)) - - ;; (This is stubified until we solve the problem of representing - ;; debug information in a way which plays nicely with package renaming.) - (error "FIXME: dead code UNCOMPACT-FUNCTION-MAP (was stub)") - - (let* ((map (sb!c::compiled-debug-info-function-map info)) - (i 0) - (len (length map)) - (code-start-pc 0) - (elsewhere-pc 0)) - (declare (type (simple-array (unsigned-byte 8) (*)) map)) - (sb!int:collect ((res)) - (loop - (when (= i len) (return)) - (let* ((options (prog1 (aref map i) (incf i))) - (flags (prog1 (aref map i) (incf i))) - (vars-p (logtest flags - sb!c::minimal-debug-function-variables-bit)) - (dfun (make-uncompacted-debug-fun))) - (res code-start-pc) - (res dfun))) - - (coerce (cdr (res)) 'simple-vector)))) - -;;; This variable maps minimal debug-info function maps to an unpacked -;;; version thereof. -(defvar *uncompacted-function-maps* (make-hash-table :test 'eq)) - -;;; Return a function-map for a given compiled-debug-info object. If -;;; the info is minimal, and has not been parsed, then parse it. -;;; -;;; FIXME: Now that we no longer use the minimal-debug-function -;;; representation, calls to this function can be replaced by calls to -;;; the bare COMPILED-DEBUG-INFO-FUNCTION-MAP slot accessor function, -;;; and this function and everything it calls become dead code which -;;; can be deleted. -(defun get-debug-info-function-map (info) - (declare (type sb!c::compiled-debug-info info)) - (let ((map (sb!c::compiled-debug-info-function-map info))) - (if (simple-vector-p map) - map - (or (gethash map *uncompacted-function-maps*) - (setf (gethash map *uncompacted-function-maps*) - (uncompact-function-map info)))))) - ;;;; CODE-LOCATIONs -;;; If we're sure of whether code-location is known, return t or nil. -;;; If we're :unsure, then try to fill in the code-location's slots. +;;; If we're sure of whether code-location is known, return T or NIL. +;;; If we're :UNSURE, then try to fill in the code-location's slots. ;;; This determines whether there is any debug-block information, and ;;; if code-location is known. ;;; ;;; ??? IF this conses closures every time it's called, then break off the -;;; :unsure part to get the HANDLER-CASE into another function. +;;; :UNSURE part to get the HANDLER-CASE into another function. (defun code-location-unknown-p (basic-code-location) - #!+sb-doc - "Returns whether basic-code-location is unknown. It returns nil when the - code-location is known." (ecase (code-location-%unknown-p basic-code-location) ((t) t) ((nil) nil) @@ -2109,27 +1646,24 @@ (handler-case (not (fill-in-code-location basic-code-location)) (no-debug-blocks () t)))))) +;;; Return the DEBUG-BLOCK containing code-location if it is available. +;;; Some debug policies inhibit debug-block information, and if none +;;; is available, then this signals a NO-DEBUG-BLOCKS condition. (defun code-location-debug-block (basic-code-location) - #!+sb-doc - "Returns the debug-block containing code-location if it is available. Some - debug policies inhibit debug-block information, and if none is available, - then this signals a no-debug-blocks condition." (let ((block (code-location-%debug-block basic-code-location))) (if (eq block :unparsed) (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))) -;;; This stores and returns BASIC-CODE-LOCATION's debug-block. It -;;; determines the correct one using the code-location's pc. This uses -;;; DEBUG-FUNCTION-DEBUG-BLOCKS to return the cached block information -;;; or signal a 'no-debug-blocks condition. The blocks are sorted by +;;; Store and return BASIC-CODE-LOCATION's debug-block. We determines +;;; the correct one using the code-location's pc. We use +;;; DEBUG-FUN-DEBUG-BLOCKS to return the cached block information +;;; or signal a NO-DEBUG-BLOCKS condition. The blocks are sorted by ;;; their first code-location's pc, in ascending order. Therefore, as ;;; soon as we find a block that starts with a pc greater than ;;; basic-code-location's pc, we know the previous block contains the @@ -2140,9 +1674,9 @@ ;;; code first in order to see how to compare the code-location's pc. (defun compute-compiled-code-location-debug-block (basic-code-location) (let* ((pc (compiled-code-location-pc basic-code-location)) - (debug-function (code-location-debug-function + (debug-fun (code-location-debug-fun basic-code-location)) - (blocks (debug-function-debug-blocks debug-function)) + (blocks (debug-fun-debug-blocks debug-fun)) (len (length blocks))) (declare (simple-vector blocks)) (setf (code-location-%debug-block basic-code-location) @@ -2155,9 +1689,9 @@ (cond ((debug-block-elsewhere-p last) (if (< pc - (sb!c::compiled-debug-function-elsewhere-pc - (compiled-debug-function-compiler-debug-fun - debug-function))) + (sb!c::compiled-debug-fun-elsewhere-pc + (compiled-debug-fun-compiler-debug-fun + debug-fun))) (svref blocks (1- end)) last)) ((< pc @@ -2166,7 +1700,7 @@ 0))) (svref blocks (1- end))) (t last)))) - (declare (type sb!c::index i end)) + (declare (type index i end)) (when (< pc (compiled-code-location-pc (svref (compiled-debug-block-code-locations @@ -2174,42 +1708,35 @@ 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 - (code-location-debug-function code-location))) + (let* ((info (compiled-debug-fun-debug-info + (code-location-debug-fun code-location))) (sources (sb!c::compiled-debug-info-source info)) (len (length sources))) (declare (list sources)) (when (zerop len) - (debug-signal 'no-debug-blocks :debug-function - (code-location-debug-function code-location))) + (debug-signal 'no-debug-blocks :debug-fun + (code-location-debug-fun code-location))) (if (= len 1) (car sources) (do ((prev sources src) (src (cdr sources) (cdr src)) - (offset (code-location-top-level-form-offset code-location))) + (offset (code-location-toplevel-form-offset code-location))) ((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)))))))))) - -(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." + ;; (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-toplevel-form-offset (code-location) (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 +1748,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 +1769,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 +1792,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. @@ -2280,8 +1805,8 @@ (let ((live-set (compiled-code-location-%live-set code-location))) (cond ((eq live-set :unparsed) (unless (fill-in-code-location code-location) - ;; This check should be unnecessary. We're missing debug info - ;; the compiler should have dumped. + ;; This check should be unnecessary. We're missing + ;; debug info the compiler should have dumped. ;; ;; FIXME: This error and comment happen over and over again. ;; Make them a shared function. @@ -2289,38 +1814,35 @@ (compiled-code-location-%live-set code-location)) (t live-set))))) +;;; true if OBJ1 and OBJ2 are the same place in the code (defun code-location= (obj1 obj2) - #!+sb-doc - "Returns whether obj1 and obj2 are the same place in the code." (etypecase obj1 (compiled-code-location (etypecase obj2 (compiled-code-location - (and (eq (code-location-debug-function obj1) - (code-location-debug-function obj2)) + (and (eq (code-location-debug-fun obj1) + (code-location-debug-fun 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 IR1-interpreted code.) + )) (defun sub-compiled-code-location= (obj1 obj2) (= (compiled-code-location-pc obj1) (compiled-code-location-pc obj2))) -;;; This fills in CODE-LOCATION's :unparsed slots. It returns t or nil +;;; Fill in CODE-LOCATION's :UNPARSED slots, returning T or NIL ;;; depending on whether the code-location was known in its -;;; debug-function's debug-block information. This may signal a -;;; NO-DEBUG-BLOCKS condition due to DEBUG-FUNCTION-DEBUG-BLOCKS, and +;;; DEBUG-FUN's debug-block information. This may signal a +;;; NO-DEBUG-BLOCKS condition due to DEBUG-FUN-DEBUG-BLOCKS, and ;;; it assumes the %UNKNOWN-P slot is already set or going to be set. (defun fill-in-code-location (code-location) (declare (type compiled-code-location code-location)) - (let* ((debug-function (code-location-debug-function code-location)) - (blocks (debug-function-debug-blocks debug-function))) + (let* ((debug-fun (code-location-debug-fun code-location)) + (blocks (debug-fun-debug-blocks debug-fun))) (declare (simple-vector blocks)) (dotimes (i (length blocks) nil) (let* ((block (svref blocks i)) @@ -2342,57 +1864,40 @@ ;;;; 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))))) -(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." +;;; Return the name of the function represented by DEBUG-FUN. +;;; This may be a string or a cons; do not assume it is a symbol. +(defun debug-block-fun-name (debug-block) (etypecase debug-block (compiled-debug-block (let ((code-locs (compiled-debug-block-code-locations debug-block))) (declare (simple-vector code-locs)) (if (zerop (length code-locs)) "??? 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)))))) + (debug-fun-name + (code-location-debug-fun (svref code-locs 0)))))) + ;; (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 @@ -2405,48 +1910,38 @@ (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) - (let ((res (access-compiled-debug-var-slot debug-var frame))) - (if (indirect-value-cell-p res) - (sb!c: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))))) + (aver (typep frame 'compiled-frame)) + (let ((res (access-compiled-debug-var-slot debug-var frame))) + (if (indirect-value-cell-p res) + (value-cell-ref res) + res))) ;;; 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,16 +1950,14 @@ ;;; GC, and might also arise in debug variable locations when ;;; 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)) (if (or ;; fixnum (zerop (logand val 3)) ;; character (and (zerop (logand val #xffff0000)) ; Top bits zero - (= (logand val #xff) sb!vm:base-char-type)) ; Char tag + (= (logand val #xff) sb!vm:base-char-widetag)) ; char tag ;; unbound marker - (= val sb!vm:unbound-marker-type) + (= val sb!vm:unbound-marker-widetag) ;; pointer (and (logand val 1) ;; Check that the pointer is valid. XXX Could do a better @@ -2472,36 +1965,166 @@ ;; routine in the C runtime support code (or (< sb!vm:read-only-space-start val (* sb!vm:*read-only-space-free-pointer* - sb!vm:word-bytes)) + sb!vm:n-word-bytes)) (< sb!vm:static-space-start val (* sb!vm:*static-space-free-pointer* - sb!vm:word-bytes)) + sb!vm:n-word-bytes)) (< sb!vm:dynamic-space-start val (sap-int (dynamic-space-free-pointer)))))) (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 (* nfp-save-offset + sb!vm:n-word-bytes)) + #!+alpha + (sb!vm::make-number-stack-pointer + (sb!sys:sap-ref-32 fp (* nfp-save-offset + sb!vm:n-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:n-word-bits) val) + (logior val (ash -1 sb!vm:n-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:n-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:n-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:n-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:n-word-bytes)) + (sb!sys:sap-ref-single nfp (* (1+ (sb!c:sc-offset-offset sc-offset)) + sb!vm:n-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:n-word-bytes)) + (sb!sys:sap-ref-double nfp (* (+ (sb!c:sc-offset-offset sc-offset) 2) + sb!vm:n-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:n-word-bytes)) + (sb!sys:sap-ref-long nfp (* (+ (sb!c:sc-offset-offset sc-offset) + #!+sparc 4) + sb!vm:n-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:n-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:n-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:n-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:n-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)) (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)) ,@forms) :invalid-value-for-unescaped-register-storage)) (escaped-float-value (format) @@ -2519,131 +2142,95 @@ :invalid-value-for-unescaped-register-storage))) (ecase (sb!c:sc-offset-scn sc-offset) ((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number) - (/show0 "case of ANY-REG-SC-NUMBER or DESCRIPTOR-REG-SC-NUMBER") (without-gcing (with-escaped-value (val) - (/show0 "VAL=..") - #!+sb-show (%primitive print (sb!impl::hexstr val)) (make-valid-lisp-obj val)))) (#.sb!vm:base-char-reg-sc-number - (/show0 "case of BASE-CHAR-REG-SC-NUMBER") (with-escaped-value (val) (code-char val))) (#.sb!vm:sap-reg-sc-number - (/show0 "case of SAP-REG-SC-NUMBER") (with-escaped-value (val) (int-sap val))) (#.sb!vm:signed-reg-sc-number - (/show0 "case of SIGNED-REG-SC-NUMBER") (with-escaped-value (val) - (if (logbitp (1- sb!vm:word-bits) val) - (logior val (ash -1 sb!vm:word-bits)) + (if (logbitp (1- sb!vm:n-word-bits) val) + (logior val (ash -1 sb!vm:n-word-bits)) val))) (#.sb!vm:unsigned-reg-sc-number - (/show0 "case of UNSIGNED-REG-SC-NUMBER") (with-escaped-value (val) val)) (#.sb!vm:single-reg-sc-number - (/show0 "case of SINGLE-REG-SC-NUMBER") (escaped-float-value single-float)) (#.sb!vm:double-reg-sc-number - (/show0 "case of DOUBLE-REG-SC-NUMBER") (escaped-float-value double-float)) #!+long-float (#.sb!vm:long-reg-sc-number - (/show0 "case of LONG-REG-SC-NUMBER") (escaped-float-value long-float)) (#.sb!vm:complex-single-reg-sc-number - (/show0 "case of COMPLEX-SINGLE-REG-SC-NUMBER") (escaped-complex-float-value single-float)) (#.sb!vm:complex-double-reg-sc-number - (/show0 "case of COMPLEX-DOUBLE-REG-SC-NUMBER") (escaped-complex-float-value double-float)) #!+long-float (#.sb!vm:complex-long-reg-sc-number - (/show0 "case of COMPLEX-LONG-REG-SC-NUMBER") (escaped-complex-float-value long-float)) (#.sb!vm:single-stack-sc-number - (/show0 "case of SINGLE-STACK-SC-NUMBER") (sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:word-bytes)))) + sb!vm:n-word-bytes)))) (#.sb!vm:double-stack-sc-number - (/show0 "case of DOUBLE-STACK-SC-NUMBER") (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) - sb!vm:word-bytes)))) + sb!vm:n-word-bytes)))) #!+long-float (#.sb!vm:long-stack-sc-number - (/show0 "case of LONG-STACK-SC-NUMBER") (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3) - sb!vm:word-bytes)))) + sb!vm:n-word-bytes)))) (#.sb!vm:complex-single-stack-sc-number - (/show0 "case of COMPLEX-STACK-SC-NUMBER") (complex (sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:word-bytes))) + sb!vm:n-word-bytes))) (sap-ref-single fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) - sb!vm:word-bytes))))) + sb!vm:n-word-bytes))))) (#.sb!vm:complex-double-stack-sc-number - (/show0 "case of COMPLEX-DOUBLE-STACK-SC-NUMBER") (complex (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) - sb!vm:word-bytes))) + sb!vm:n-word-bytes))) (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 4) - sb!vm:word-bytes))))) + sb!vm:n-word-bytes))))) #!+long-float (#.sb!vm:complex-long-stack-sc-number - (/show0 "case of COMPLEX-LONG-STACK-SC-NUMBER") (complex (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3) - sb!vm:word-bytes))) + sb!vm:n-word-bytes))) (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 6) - sb!vm:word-bytes))))) + sb!vm:n-word-bytes))))) (#.sb!vm:control-stack-sc-number - (/show0 "case of CONTROL-STACK-SC-NUMBER") (stack-ref fp (sb!c:sc-offset-offset sc-offset))) (#.sb!vm:base-char-stack-sc-number - (/show0 "case of BASE-CHAR-STACK-SC-NUMBER") (code-char (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:word-bytes))))) + sb!vm:n-word-bytes))))) (#.sb!vm:unsigned-stack-sc-number - (/show0 "case of UNSIGNED-STACK-SC-NUMBER") (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:word-bytes)))) + sb!vm:n-word-bytes)))) (#.sb!vm:signed-stack-sc-number - (/show0 "case of SIGNED-STACK-SC-NUMBER") (signed-sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:word-bytes)))) + sb!vm:n-word-bytes)))) (#.sb!vm:sap-stack-sc-number - (/show0 "case of SAP-STACK-SC-NUMBER") (sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:word-bytes))))))) + sb!vm:n-word-bytes))))))) ;;; 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. -(defun %set-debug-var-value (debug-var frame value) - (etypecase debug-var - (compiled-debug-var - (check-type 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) - (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))) - value) - -;;; This stores value for the variable represented by debug-var +;;; both closed over and set. +(defun %set-debug-var-value (debug-var frame new-value) + (aver (typep frame 'compiled-frame)) + (let ((old-value (access-compiled-debug-var-slot debug-var frame))) + (if (indirect-value-cell-p old-value) + (value-cell-set old-value new-value) + (set-compiled-debug-var-slot debug-var frame new-value))) + new-value) + +;;; This stores VALUE for the variable represented by debug-var ;;; relative to the frame. This assumes the location directly contains ;;; the variable's value; that is, there is no indirect value cell ;;; currently there in case the variable is both closed over and set. @@ -2683,13 +2270,13 @@ sb!vm::nfp-offset)) #!-alpha (sap-ref-sap fp - (* sb!vm::nfp-save-offset - sb!vm:word-bytes)) + (* nfp-save-offset + sb!vm:n-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)))))) + (* nfp-save-offset + sb!vm:n-word-bytes)))))) ,@body))) (ecase (sb!c:sc-offset-scn sc-offset) ((#.sb!vm:any-reg-sc-number @@ -2703,7 +2290,7 @@ (#.sb!vm:sap-reg-sc-number (set-escaped-value (sap-int value))) (#.sb!vm:signed-reg-sc-number - (set-escaped-value (logand value (1- (ash 1 sb!vm:word-bits))))) + (set-escaped-value (logand value (1- (ash 1 sb!vm:n-word-bits))))) (#.sb!vm:unsigned-reg-sc-number (set-escaped-value value)) (#.sb!vm:non-descriptor-reg-sc-number @@ -2754,68 +2341,68 @@ (#.sb!vm:single-stack-sc-number (with-nfp (nfp) (setf (sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:word-bytes)) + sb!vm:n-word-bytes)) (the single-float value)))) (#.sb!vm:double-stack-sc-number (with-nfp (nfp) (setf (sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:word-bytes)) + sb!vm:n-word-bytes)) (the double-float value)))) #!+long-float (#.sb!vm:long-stack-sc-number (with-nfp (nfp) (setf (sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:word-bytes)) + sb!vm:n-word-bytes)) (the long-float value)))) (#.sb!vm:complex-single-stack-sc-number (with-nfp (nfp) (setf (sap-ref-single - nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:word-bytes)) + nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes)) (the single-float (realpart value))) (setf (sap-ref-single nfp (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:word-bytes)) + sb!vm:n-word-bytes)) (the single-float (realpart value))))) (#.sb!vm:complex-double-stack-sc-number (with-nfp (nfp) (setf (sap-ref-double - nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:word-bytes)) + nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes)) (the double-float (realpart value))) (setf (sap-ref-double nfp (* (+ (sb!c:sc-offset-offset sc-offset) 2) - sb!vm:word-bytes)) + sb!vm:n-word-bytes)) (the double-float (realpart value))))) #!+long-float (#.sb!vm:complex-long-stack-sc-number (with-nfp (nfp) (setf (sap-ref-long - nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:word-bytes)) + nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes)) (the long-float (realpart value))) (setf (sap-ref-long nfp (* (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4) - sb!vm:word-bytes)) + sb!vm:n-word-bytes)) (the long-float (realpart value))))) (#.sb!vm:control-stack-sc-number (setf (stack-ref fp (sb!c:sc-offset-offset sc-offset)) value)) (#.sb!vm:base-char-stack-sc-number (with-nfp (nfp) (setf (sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:word-bytes)) + sb!vm:n-word-bytes)) (char-code (the character value))))) (#.sb!vm:unsigned-stack-sc-number (with-nfp (nfp) (setf (sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:word-bytes)) + sb!vm:n-word-bytes)) (the (unsigned-byte 32) value)))) (#.sb!vm:signed-stack-sc-number (with-nfp (nfp) (setf (signed-sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:word-bytes)) + sb!vm:n-word-bytes)) (the (signed-byte 32) value)))) (#.sb!vm:sap-stack-sc-number (with-nfp (nfp) (setf (sap-ref-sap nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:word-bytes)) + sb!vm:n-word-bytes)) (the system-area-pointer value))))))) #!+x86 @@ -2837,7 +2424,7 @@ (#.sb!vm:sap-reg-sc-number (set-escaped-value (sap-int value))) (#.sb!vm:signed-reg-sc-number - (set-escaped-value (logand value (1- (ash 1 sb!vm:word-bits))))) + (set-escaped-value (logand value (1- (ash 1 sb!vm:n-word-bits))))) (#.sb!vm:unsigned-reg-sc-number (set-escaped-value value)) (#.sb!vm:single-reg-sc-number @@ -2853,119 +2440,117 @@ (#.sb!vm:single-stack-sc-number (setf (sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:word-bytes))) + sb!vm:n-word-bytes))) (the single-float value))) (#.sb!vm:double-stack-sc-number (setf (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) - sb!vm:word-bytes))) + sb!vm:n-word-bytes))) (the double-float value))) #!+long-float (#.sb!vm:long-stack-sc-number (setf (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3) - sb!vm:word-bytes))) + sb!vm:n-word-bytes))) (the long-float value))) (#.sb!vm:complex-single-stack-sc-number (setf (sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:word-bytes))) + sb!vm:n-word-bytes))) (realpart (the (complex single-float) value))) (setf (sap-ref-single fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) - sb!vm:word-bytes))) + sb!vm:n-word-bytes))) (imagpart (the (complex single-float) value)))) (#.sb!vm:complex-double-stack-sc-number (setf (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) - sb!vm:word-bytes))) + sb!vm:n-word-bytes))) (realpart (the (complex double-float) value))) (setf (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 4) - sb!vm:word-bytes))) + sb!vm:n-word-bytes))) (imagpart (the (complex double-float) value)))) #!+long-float (#.sb!vm:complex-long-stack-sc-number (setf (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3) - sb!vm:word-bytes))) + sb!vm:n-word-bytes))) (realpart (the (complex long-float) value))) (setf (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 6) - sb!vm:word-bytes))) + sb!vm:n-word-bytes))) (imagpart (the (complex long-float) value)))) (#.sb!vm:control-stack-sc-number (setf (stack-ref fp (sb!c:sc-offset-offset sc-offset)) value)) (#.sb!vm:base-char-stack-sc-number (setf (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:word-bytes))) + sb!vm:n-word-bytes))) (char-code (the character value)))) (#.sb!vm:unsigned-stack-sc-number (setf (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:word-bytes))) + sb!vm:n-word-bytes))) (the (unsigned-byte 32) value))) (#.sb!vm:signed-stack-sc-number (setf (signed-sap-ref-32 - fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) sb!vm:word-bytes))) + fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) + sb!vm:n-word-bytes))) (the (signed-byte 32) value))) (#.sb!vm:sap-stack-sc-number (setf (sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:word-bytes))) + sb!vm:n-word-bytes))) (the system-area-pointer value)))))) ;;; The method for setting and accessing COMPILED-DEBUG-VAR values use ;;; this to determine if the value stored is the actual value or an ;;; indirection cell. (defun indirect-value-cell-p (x) - (and (= (get-lowtag x) sb!vm:other-pointer-type) - (= (get-type x) sb!vm:value-cell-header-type))) - + (and (= (lowtag-of x) sb!vm:other-pointer-lowtag) + (= (widetag-of x) sb!vm:value-cell-header-widetag))) + +;;; 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))) + (let ((debug-fun (code-location-debug-fun basic-code-location))) (if (>= (compiled-code-location-pc basic-code-location) - (sb!c::compiled-debug-function-start-pc - (compiled-debug-function-compiler-debug-fun debug-fun))) + (sb!c::compiled-debug-fun-start-pc + (compiled-debug-fun-compiler-debug-fun debug-fun))) :valid :invalid))) ((code-location-unknown-p basic-code-location) :unknown) (t (let ((pos (position debug-var - (debug-function-debug-vars - (code-location-debug-function basic-code-location))))) + (debug-fun-debug-vars + (code-location-debug-fun + basic-code-location))))) (unless pos (error 'unknown-debug-var :debug-var debug-var - :debug-function - (code-location-debug-function basic-code-location))) + :debug-fun + (code-location-debug-fun 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))))) @@ -2975,35 +2560,35 @@ ;;; This code produces and uses what we call source-paths. A ;;; source-path is a list whose first element is a form number as ;;; returned by CODE-LOCATION-FORM-NUMBER and whose last element is a -;;; top-level-form number as returned by -;;; CODE-LOCATION-TOP-LEVEL-FORM-NUMBER. The elements from the last to +;;; top level form number as returned by +;;; CODE-LOCATION-TOPLEVEL-FORM-NUMBER. The elements from the last to ;;; the first, exclusively, are the numbered subforms into which to ;;; descend. For example: ;;; (defun foo (x) ;;; (let ((a (aref x 3))) ;;; (cons a 3))) ;;; The call to AREF in this example is form number 5. Assuming this -;;; DEFUN is the 11'th top-level-form, the source-path for the AREF +;;; DEFUN is the 11'th top level form, the source-path for the AREF ;;; call is as follows: ;;; (5 1 0 1 3 11) ;;; 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 TOPLEVEL-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 TOPLEVEL-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)) @@ -3031,13 +2616,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. @@ -3067,27 +2652,26 @@ (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-FUN 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-VAR-NAME, and FRAME-FUN-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))) + (fun (code-location-debug-fun loc))) (unless (debug-var-info-available fun) - (debug-signal 'no-debug-vars :debug-function fun)) + (debug-signal 'no-debug-vars :debug-fun fun)) (sb!int:collect ((binds) (specs)) - (do-debug-function-variables (var fun) + (do-debug-fun-variables (var fun) (let ((validity (debug-var-validity var loc))) (unless (eq validity :invalid) (let* ((sym (debug-var-symbol var)) @@ -3102,10 +2686,12 @@ (:valid (specs `(,name (debug-var-value ',var ,n-frame)))) (:unknown - (specs `(,name (debug-signal 'invalid-value :debug-var ',var + (specs `(,name (debug-signal 'invalid-value + :debug-var ',var :frame ,n-frame)))) (:ambiguous - (specs `(,name (debug-signal 'ambiguous-variable-name :name ',name + (specs `(,name (debug-signal 'ambiguous-var-name + :name ',name :frame ,n-frame))))))) (let ((res (coerce `(lambda (,n-frame) (declare (ignorable ,n-frame)) @@ -3115,59 +2701,55 @@ ;; This prevents these functions from being used in any ;; location other than a function return location, so ;; maybe this should only check whether frame's - ;; debug-function is the same as loc's. + ;; DEBUG-FUN is the same as loc's. (unless (code-location= (frame-code-location frame) loc) - (debug-signal 'frame-function-mismatch + (debug-signal 'frame-fun-mismatch :code-location loc :form form :frame frame)) (funcall res frame)))))) - -(defun eval-in-frame (frame form) - (declare (type frame frame)) - #!+sb-doc - "Evaluate Form in the lexical context of Frame's current code location, - returning the results of the evaluation." - (funcall (preprocess-for-eval form (frame-code-location frame)) frame)) ;;;; breakpoints ;;;; user-visible interface +;;; Create and return a breakpoint. When program execution encounters +;;; the breakpoint, the system calls HOOK-FUNCTION. HOOK-FUNCTION takes the +;;; current frame for the function in which the program is running and the +;;; breakpoint object. +;;; +;;; WHAT and KIND determine where in a function the system invokes +;;; HOOK-FUNCTION. WHAT is either a code-location or a DEBUG-FUN. +;;; KIND is one of :CODE-LOCATION, :FUN-START, or :FUN-END. +;;; Since the starts and ends of functions may not have code-locations +;;; representing them, designate these places by supplying WHAT as a +;;; DEBUG-FUN and KIND indicating the :FUN-START or +;;; :FUN-END. When WHAT is a DEBUG-FUN and kind is +;;; :FUN-END, then hook-function must take two additional +;;; arguments, a list of values returned by the function and a +;;; FUN-END-COOKIE. +;;; +;;; INFO is information supplied by and used by the user. +;;; +;;; FUN-END-COOKIE is a function. To implement :FUN-END +;;; breakpoints, the system uses starter breakpoints to establish the +;;; :FUN-END breakpoint for each invocation of the function. Upon +;;; each entry, the system creates a unique cookie to identify the +;;; invocation, and when the user supplies a function for this +;;; argument, the system invokes it on the frame and the cookie. The +;;; system later invokes the :FUN-END breakpoint hook on the same +;;; cookie. The user may save the cookie for comparison in the hook +;;; function. +;;; +;;; Signal an error if WHAT is an unknown code-location. (defun make-breakpoint (hook-function what - &key (kind :code-location) info function-end-cookie) - #!+sb-doc - "This creates and returns a breakpoint. When program execution encounters - the breakpoint, the system calls hook-function. Hook-function takes the - current frame for the function in which the program is running and the - breakpoint object. - What and kind determine where in a function the system invokes - hook-function. What is either a code-location or a debug-function. Kind is - one of :code-location, :function-start, or :function-end. Since the starts - and ends of functions may not have code-locations representing them, - designate these places by supplying what as a debug-function and kind - indicating the :function-start or :function-end. When what is a - debug-function and kind is :function-end, then hook-function must take two - additional arguments, a list of values returned by the function and a - function-end-cookie. - Info is information supplied by and used by the user. - Function-end-cookie is a function. To implement :function-end breakpoints, - the system uses starter breakpoints to establish the :function-end breakpoint - for each invocation of the function. Upon each entry, the system creates a - unique cookie to identify the invocation, and when the user supplies a - function for this argument, the system invokes it on the frame and the - cookie. The system later invokes the :function-end breakpoint hook on the - same cookie. The user may save the cookie for comparison in the hook - function. - This signals an error if what is an unknown code-location." + &key (kind :code-location) info fun-end-cookie) (etypecase what (code-location (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) @@ -3175,78 +2757,78 @@ :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 + (compiled-debug-fun (ecase kind - (:function-start + (:fun-start (%make-breakpoint hook-function what kind info)) - (:function-end - (unless (eq (sb!c::compiled-debug-function-returns - (compiled-debug-function-compiler-debug-fun what)) + (:fun-end + (unless (eq (sb!c::compiled-debug-fun-returns + (compiled-debug-fun-compiler-debug-fun what)) :standard) - (error ":FUNCTION-END breakpoints are currently unsupported ~ + (error ":FUN-END breakpoints are currently unsupported ~ for the known return convention.")) (let* ((bpt (%make-breakpoint hook-function what kind info)) - (starter (compiled-debug-function-end-starter what))) + (starter (compiled-debug-fun-end-starter what))) (unless starter - (setf starter (%make-breakpoint #'list what :function-start nil)) + (setf starter (%make-breakpoint #'list what :fun-start nil)) (setf (breakpoint-hook-function starter) - (function-end-starter-hook starter what)) - (setf (compiled-debug-function-end-starter what) starter)) + (fun-end-starter-hook starter what)) + (setf (compiled-debug-fun-end-starter what) starter)) (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.")))) + (setf (breakpoint-cookie-fun bpt) fun-end-cookie) + bpt)))))) ;;; These are unique objects created upon entry into a function by a -;;; :FUNCTION-END breakpoint's starter hook. These are only created -;;; when users supply :FUNCTION-END-COOKIE to MAKE-BREAKPOINT. Also, -;;; the :FUNCTION-END breakpoint's hook is called on the same cookie +;;; :FUN-END breakpoint's starter hook. These are only created +;;; when users supply :FUN-END-COOKIE to MAKE-BREAKPOINT. Also, +;;; the :FUN-END breakpoint's hook is called on the same cookie ;;; when it is created. -(defstruct (function-end-cookie +(defstruct (fun-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-fun-end-cookie (bogus-lra debug-fun)) + (:copier nil)) + ;; a pointer to the bogus-lra created for :FUN-END breakpoints bogus-lra - ;; This is the debug-function associated with the cookie. + ;; the DEBUG-FUN associated with this cookie debug-fun) -;;; This maps bogus-lra-components to cookies, so -;;; HANDLE-FUNCTION-END-BREAKPOINT can find the appropriate cookie for the +;;; This maps bogus-lra-components to cookies, so that +;;; HANDLE-FUN-END-BREAKPOINT can find the appropriate cookie for the ;;; breakpoint hook. -(defvar *function-end-cookies* (make-hash-table :test 'eq)) +(defvar *fun-end-cookies* (make-hash-table :test 'eq)) ;;; This returns a hook function for the start helper breakpoint -;;; associated with a :FUNCTION-END breakpoint. The returned function +;;; associated with a :FUN-END breakpoint. The returned function ;;; makes a fake LRA that all returns go through, and this piece of ;;; fake code actually breaks. Upon return from the break, the code ;;; provides the returnee with any values. Since the returned function ;;; effectively activates FUN-END-BPT on each entry to DEBUG-FUN's ;;; function, we must establish breakpoint-data about FUN-END-BPT. -(defun function-end-starter-hook (starter-bpt debug-fun) +(defun fun-end-starter-hook (starter-bpt debug-fun) (declare (type breakpoint starter-bpt) - (type compiled-debug-function debug-fun)) + (type compiled-debug-fun debug-fun)) #'(lambda (frame breakpoint) (declare (ignore breakpoint) (type frame frame)) (let ((lra-sc-offset - (sb!c::compiled-debug-function-return-pc - (compiled-debug-function-compiler-debug-fun debug-fun)))) + (sb!c::compiled-debug-fun-return-pc + (compiled-debug-fun-compiler-debug-fun debug-fun)))) (multiple-value-bind (lra component offset) (make-bogus-lra (get-context-value frame - #!-gengc sb!vm::lra-save-offset - #!+gengc sb!vm::ra-save-offset + lra-save-offset lra-sc-offset)) (setf (get-context-value frame - #!-gengc sb!vm::lra-save-offset - #!+gengc sb!vm::ra-save-offset + lra-save-offset lra-sc-offset) lra) (let ((end-bpts (breakpoint-%info starter-bpt))) @@ -3254,43 +2836,42 @@ (setf (breakpoint-data-breakpoints data) end-bpts) (dolist (bpt end-bpts) (setf (breakpoint-internal-data bpt) data))) - (let ((cookie (make-function-end-cookie lra debug-fun))) - (setf (gethash component *function-end-cookies*) cookie) + (let ((cookie (make-fun-end-cookie lra debug-fun))) + (setf (gethash component *fun-end-cookies*) cookie) (dolist (bpt end-bpts) (let ((fun (breakpoint-cookie-fun bpt))) (when fun (funcall fun frame cookie)))))))))) -(defun function-end-cookie-valid-p (frame cookie) - #!+sb-doc - "This takes a function-end-cookie and a frame, and it returns whether the - cookie is still valid. A cookie becomes invalid when the frame that - established the cookie has exited. Sometimes cookie holders are unaware - of cookie invalidation because their :function-end breakpoint hooks didn't - run due to THROW'ing. This takes a frame as an efficiency hack since the - user probably has a frame object in hand when using this routine, and it - saves repeated parsing of the stack and consing when asking whether a - series of cookies is valid." - (let ((lra (function-end-cookie-bogus-lra cookie)) - (lra-sc-offset (sb!c::compiled-debug-function-return-pc - (compiled-debug-function-compiler-debug-fun - (function-end-cookie-debug-fun cookie))))) +;;; This takes a FUN-END-COOKIE and a frame, and it returns +;;; whether the cookie is still valid. A cookie becomes invalid when +;;; the frame that established the cookie has exited. Sometimes cookie +;;; holders are unaware of cookie invalidation because their +;;; :FUN-END breakpoint hooks didn't run due to THROW'ing. +;;; +;;; This takes a frame as an efficiency hack since the user probably +;;; has a frame object in hand when using this routine, and it saves +;;; repeated parsing of the stack and consing when asking whether a +;;; series of cookies is valid. +(defun fun-end-cookie-valid-p (frame cookie) + (let ((lra (fun-end-cookie-bogus-lra cookie)) + (lra-sc-offset (sb!c::compiled-debug-fun-return-pc + (compiled-debug-fun-compiler-debug-fun + (fun-end-cookie-debug-fun cookie))))) (do ((frame frame (frame-down frame))) ((not frame) nil) (when (and (compiled-frame-p frame) - (eq lra - (get-context-value frame - #!-gengc sb!vm::lra-save-offset - #!+gengc sb!vm::ra-save-offset - lra-sc-offset))) + (#-x86 eq #+x86 sap= + lra + (get-context-value frame lra-save-offset lra-sc-offset))) (return t))))) - + ;;;; ACTIVATE-BREAKPOINT +;;; Cause the system to invoke the breakpoint's hook-function until +;;; the next call to DEACTIVATE-BREAKPOINT or DELETE-BREAKPOINT. The +;;; system invokes breakpoint hook functions in the opposite order +;;; that you activate them. (defun activate-breakpoint (breakpoint) - #!+sb-doc - "This causes the system to invoke the breakpoint's hook-function until the - next call to DEACTIVATE-BREAKPOINT or DELETE-BREAKPOINT. The system invokes - breakpoint hook functions in the opposite order that you activate them." (when (eq (breakpoint-status breakpoint) :deleted) (error "cannot activate a deleted breakpoint: ~S" breakpoint)) (unless (eq (breakpoint-status breakpoint) :active) @@ -3298,31 +2879,32 @@ (: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))))))) - (:function-start + (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.) + ))) + (:fun-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))))) - (:function-end + (compiled-debug-fun + (activate-compiled-fun-start-breakpoint breakpoint)) + ;; (There used to be more cases back before sbcl-0.7.0, when + ;; we did special tricks to debug the IR1 interpreter.) + )) + (:fun-end (etypecase (breakpoint-what breakpoint) - (compiled-debug-function + (compiled-debug-fun (let ((starter (breakpoint-start-helper breakpoint))) (unless (eq (breakpoint-status starter) :active) - ;; May already be active by some other :function-end breakpoint. - (activate-compiled-function-start-breakpoint starter))) + ;; may already be active by some other :FUN-END breakpoint + (activate-compiled-fun-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) @@ -3331,8 +2913,8 @@ (declare (type compiled-code-location loc)) (sub-activate-breakpoint breakpoint - (breakpoint-data (compiled-debug-function-component - (code-location-debug-function loc)) + (breakpoint-data (compiled-debug-fun-component + (code-location-debug-fun loc)) (+ (compiled-code-location-pc loc) (if (or (eq (breakpoint-kind breakpoint) :unknown-return-partner) @@ -3341,14 +2923,14 @@ sb!vm:single-value-return-byte-offset 0)))))) -(defun activate-compiled-function-start-breakpoint (breakpoint) +(defun activate-compiled-fun-start-breakpoint (breakpoint) (declare (type breakpoint breakpoint)) (let ((debug-fun (breakpoint-what breakpoint))) (sub-activate-breakpoint breakpoint - (breakpoint-data (compiled-debug-function-component debug-fun) - (sb!c::compiled-debug-function-start-pc - (compiled-debug-function-compiler-debug-fun + (breakpoint-data (compiled-debug-fun-component debug-fun) + (sb!c::compiled-debug-fun-start-pc + (compiled-debug-fun-compiler-debug-fun debug-fun)))))) (defun sub-activate-breakpoint (breakpoint data) @@ -3365,28 +2947,27 @@ (setf (breakpoint-data-breakpoints data) (append (breakpoint-data-breakpoints data) (list breakpoint))) (setf (breakpoint-internal-data breakpoint) data))) - + ;;;; 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) + ((or compiled-code-location compiled-debug-fun) (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) - (if (eq (breakpoint-kind breakpoint) :function-end) + (if (eq (breakpoint-kind breakpoint) :fun-end) (let ((starter (breakpoint-start-helper breakpoint))) (unless (find-if #'(lambda (bpt) (and (not (eq bpt breakpoint)) @@ -3406,34 +2987,30 @@ (delete-breakpoint-data data)))) (setf (breakpoint-status breakpoint) :inactive) breakpoint) - + ;;;; 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) (let ((other (breakpoint-unknown-return-partner breakpoint))) (when other (setf (breakpoint-%info other) value)))) - + ;;;; 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) @@ -3442,46 +3019,46 @@ (let ((other (breakpoint-unknown-return-partner breakpoint))) (when other (setf (breakpoint-status other) :deleted))) - (when (eq (breakpoint-kind breakpoint) :function-end) + (when (eq (breakpoint-kind breakpoint) :fun-end) (let* ((starter (breakpoint-start-helper breakpoint)) (breakpoints (delete breakpoint (the list (breakpoint-info starter))))) (setf (breakpoint-info starter) breakpoints) (unless breakpoints (delete-breakpoint starter) - (setf (compiled-debug-function-end-starter + (setf (compiled-debug-fun-end-starter (breakpoint-what breakpoint)) nil)))))) breakpoint) - + ;;;; C call out stubs ;;; This actually installs the break instruction in the component. It ;;; returns the overwritten bits. You must call this in a context in ;;; which GC is disabled, so that Lisp doesn't move objects around ;;; that C is pointing to. -(sb!alien:def-alien-routine "breakpoint_install" sb!c-call:unsigned-long +(sb!alien:define-alien-routine "breakpoint_install" sb!c-call:unsigned-long (code-obj sb!c-call:unsigned-long) (pc-offset sb!c-call:int)) ;;; This removes the break instruction and replaces the original ;;; instruction. You must call this in a context in which GC is disabled ;;; so Lisp doesn't move objects around that C is pointing to. -(sb!alien:def-alien-routine "breakpoint_remove" sb!c-call:void +(sb!alien:define-alien-routine "breakpoint_remove" sb!c-call:void (code-obj sb!c-call:unsigned-long) (pc-offset sb!c-call:int) (old-inst sb!c-call:unsigned-long)) -(sb!alien:def-alien-routine "breakpoint_do_displaced_inst" sb!c-call:void +(sb!alien:define-alien-routine "breakpoint_do_displaced_inst" sb!c-call:void (scp (* os-context-t)) (orig-inst sb!c-call:unsigned-long)) ;;;; breakpoint handlers (layer between C and exported interface) -;;; This maps components to a mapping of offsets to breakpoint-datas. +;;; This maps components to a mapping of offsets to BREAKPOINT-DATAs. (defvar *component-breakpoint-offsets* (make-hash-table :test 'eq)) -;;; This returns the breakpoint-data associated with component cross +;;; This returns the BREAKPOINT-DATA object associated with component cross ;;; offset. If none exists, this makes one, installs it, and returns it. (defun breakpoint-data (component offset &optional (create t)) (flet ((install-breakpoint-data () @@ -3499,7 +3076,7 @@ (install-breakpoint-data))))) ;;; We use this when there are no longer any active breakpoints -;;; corresponding to data. +;;; corresponding to DATA. (defun delete-breakpoint-data (data) (let* ((component (breakpoint-data-component data)) (offsets (delete (breakpoint-data-offset data) @@ -3511,34 +3088,33 @@ (values)) ;;; The C handler for interrupts calls this when it has a -;;; debugging-tool break instruction. This does NOT handle all breaks; -;;; for example, it does not handle breaks for internal errors. +;;; debugging-tool break instruction. This does *not* handle all +;;; breaks; for example, it does not handle breaks for internal +;;; errors. (defun handle-breakpoint (offset component signal-context) - (/show0 "entering HANDLE-BREAKPOINT") (let ((data (breakpoint-data component offset nil))) (unless data (error "unknown breakpoint in ~S at offset ~S" - (debug-function-name (debug-function-from-pc component offset)) + (debug-fun-name (debug-fun-from-pc component offset)) offset)) (let ((breakpoints (breakpoint-data-breakpoints data))) (if (or (null breakpoints) - (eq (breakpoint-kind (car breakpoints)) :function-end)) - (handle-function-end-breakpoint-aux breakpoints data signal-context) + (eq (breakpoint-kind (car breakpoints)) :fun-end)) + (handle-fun-end-breakpoint-aux breakpoints data signal-context) (handle-breakpoint-aux breakpoints data offset component signal-context))))) ;;; This holds breakpoint-datas while invoking the breakpoint hooks ;;; associated with that particular component and location. While they ;;; are executing, if we hit the location again, we ignore the -;;; breakpoint to avoid infinite recursion. Function-end breakpoints +;;; breakpoint to avoid infinite recursion. fun-end breakpoints ;;; must work differently since the breakpoint-data is unique for each ;;; invocation. (defvar *executing-breakpoint-hooks* nil) -;;; This handles code-location and debug-function :FUNCTION-START +;;; This handles code-location and DEBUG-FUN :FUN-START ;;; breakpoints. (defun handle-breakpoint-aux (breakpoints data offset component signal-context) - (/show0 "entering HANDLE-BREAKPOINT-AUX") (unless breakpoints (error "internal error: breakpoint that nobody wants")) (unless (member data *executing-breakpoint-hooks*) @@ -3561,14 +3137,16 @@ ;; 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) - (let* ((debug-fun (debug-function-from-pc component offset)) + (let* ((debug-fun (debug-fun-from-pc component offset)) (frame (do ((f (top-frame) (frame-down f))) - ((eq debug-fun (frame-debug-function f)) f)))) + ((eq debug-fun (frame-debug-fun f)) f)))) (dolist (bpt breakpoints) (funcall (breakpoint-hook-function bpt) frame @@ -3580,23 +3158,21 @@ (breakpoint-unknown-return-partner bpt) bpt))))) -(defun handle-function-end-breakpoint (offset component context) - (/show0 "entering HANDLE-FUNCTION-END-BREAKPOINT") +(defun handle-fun-end-breakpoint (offset component context) (let ((data (breakpoint-data component offset nil))) (unless data (error "unknown breakpoint in ~S at offset ~S" - (debug-function-name (debug-function-from-pc component offset)) + (debug-fun-name (debug-fun-from-pc component offset)) offset)) (let ((breakpoints (breakpoint-data-breakpoints data))) (when breakpoints - (assert (eq (breakpoint-kind (car breakpoints)) :function-end)) - (handle-function-end-breakpoint-aux breakpoints data context))))) + (aver (eq (breakpoint-kind (car breakpoints)) :fun-end)) + (handle-fun-end-breakpoint-aux breakpoints data context))))) -;;; Either HANDLE-BREAKPOINT calls this for :FUNCTION-END breakpoints -;;; [old C code] or HANDLE-FUNCTION-END-BREAKPOINT calls this directly +;;; Either HANDLE-BREAKPOINT calls this for :FUN-END breakpoints +;;; [old C code] or HANDLE-FUN-END-BREAKPOINT calls this directly ;;; [new C code]. -(defun handle-function-end-breakpoint-aux (breakpoints data signal-context) - (/show0 "entering HANDLE-FUNCTION-END-BREAKPOINT-AUX") +(defun handle-fun-end-breakpoint-aux (breakpoints data signal-context) (delete-breakpoint-data data) (let* ((scp (locally @@ -3605,24 +3181,24 @@ (frame (do ((cfp (sb!vm:context-register scp sb!vm::cfp-offset)) (f (top-frame) (frame-down f))) ((= cfp (sap-int (frame-pointer f))) f) - (declare (type (unsigned-byte #.sb!vm:word-bits) cfp)))) + (declare (type (unsigned-byte #.sb!vm:n-word-bits) cfp)))) (component (breakpoint-data-component data)) - (cookie (gethash component *function-end-cookies*))) - (remhash component *function-end-cookies*) + (cookie (gethash component *fun-end-cookies*))) + (remhash component *fun-end-cookies*) (dolist (bpt breakpoints) (funcall (breakpoint-hook-function bpt) frame bpt - (get-function-end-breakpoint-values scp) + (get-fun-end-breakpoint-values scp) cookie)))) -(defun get-function-end-breakpoint-values (scp) +(defun get-fun-end-breakpoint-values (scp) (let ((ocfp (int-sap (sb!vm:context-register scp #!-x86 sb!vm::ocfp-offset #!+x86 sb!vm::ebx-offset))) (nargs (make-lisp-obj (sb!vm:context-register scp sb!vm::nargs-offset))) - (reg-arg-offsets '#.sb!vm::register-arg-offsets) + (reg-arg-offsets '#.sb!vm::*register-arg-offsets*) (results nil)) (without-gcing (dotimes (arg-num nargs) @@ -3632,30 +3208,24 @@ (stack-ref ocfp arg-num)) results))) (nreverse results))) + +;;;; MAKE-BOGUS-LRA (used for :FUN-END breakpoints) -;;;; 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")) - (trap-loc (foreign-symbol-address "function_end_breakpoint_trap")) + (let* ((src-start (foreign-symbol-address "fun_end_breakpoint_guts")) + (src-end (foreign-symbol-address "fun_end_breakpoint_end")) + (trap-loc (foreign-symbol-address "fun_end_breakpoint_trap")) (length (sap- src-end src-start)) (code-object (%primitive @@ -3678,13 +3248,13 @@ (setf (code-header-ref code-object (1+ real-lra-slot)) offset)) (setf (code-header-ref code-object known-return-p-slot) known-return-p) - (system-area-copy src-start 0 dst-start 0 (* length sb!vm:byte-bits)) + (system-area-copy src-start 0 dst-start 0 (* length sb!vm:n-byte-bits)) (sb!vm:sanctify-for-execution code-object) #!+x86 (values dst-start code-object (sap- trap-loc src-start)) #!-x86 (let ((new-lra (make-lisp-obj (+ (sap-int dst-start) - sb!vm:other-pointer-type)))) + sb!vm:other-pointer-lowtag)))) (set-header-data new-lra (logandc2 (+ sb!vm:code-constants-offset bogus-lra-constants 1) @@ -3694,37 +3264,31 @@ ;;;; miscellaneous -;;; This appears here because it cannot go with the debug-function +;;; This appears here because it cannot go with the DEBUG-FUN ;;; interface since DO-DEBUG-BLOCK-LOCATIONS isn't defined until after -;;; the debug-function routines. +;;; the DEBUG-FUN routines. -(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." +;;; 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-fun-start-location (debug-fun) (etypecase debug-fun - (compiled-debug-function + (compiled-debug-fun (code-location-from-pc debug-fun - (sb!c::compiled-debug-function-start-pc - (compiled-debug-function-compiler-debug-fun + (sb!c::compiled-debug-fun-start-pc + (compiled-debug-fun-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))) - (do-debug-function-blocks (block debug-fun) + (let ((debug-fun (fun-debug-fun function))) + (do-debug-fun-blocks (block debug-fun) (do-debug-block-locations (loc block) (fill-in-code-location loc) - (format t "~S code location at ~D" + (format t "~S code location at ~W" (compiled-code-location-kind loc) (compiled-code-location-pc loc)) (sb!debug::print-code-location-source-form loc 0)