#!+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 ~
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)
(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)
()
(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.
;;;; 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)
;; a unique integer identification relative to other variables with the same
#!+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).
+ (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.
+ ;; storage class and offset when saved somewhere
(save-sc-offset nil :type (or sb!c::sc-offset null)))
-(defstruct (interpreted-debug-var
- (:include debug-var (alive-p t))
- (:constructor make-interpreted-debug-var (symbol ir1-var)))
- ;; This is the IR1 structure that holds information about interpreted vars.
- (ir1-var nil :type sb!c::lambda-var))
-
;;;; frames
-;;; These represent call-frames on the stack.
-(defstruct (frame (:constructor nil))
+;;; 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
;; 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
+\f
+;;;; 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))
+\f
;;;; 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)
#!+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*)))))
-
+\f
;;;; 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.
(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))
;; 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
;; 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))
"~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)))))))
+\f
;;;; 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,
;; and the code-location is unknown. If the data is available, this
;; 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.
(%form-number :unparsed :type (or sb!c::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.
+ (:constructor make-compiled-code-location (pc debug-fun))
+ (:copier nil))
+ ;; an index into DEBUG-FUN'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
+ ;; 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))
+\f
+;;;; 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.")
\f
;;;; 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)
(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
(sap> (int-sap control-stack-end) x)
(zerop (logand (sap-int x) #b11))))
-#!+(or gengc x86)
+#!+x86
(sb!alien:def-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
(code-header-len (* (get-header-data code) sb!vm: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)))))
;;; 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)
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)
(defun descriptor-sap (x)
(int-sap (get-lisp-obj-address x)))
+;;; Return the top frame of the control stack as it was before calling
+;;; this function.
(defun top-frame ()
- #!+sb-doc
- "Returns the top frame of the control stack as it was before calling this
- function."
+ (/show0 "entering TOP-FRAME")
(multiple-value-bind (fp pc) (%caller-frame-and-pc)
- (possibly-an-interpreted-frame
- (compute-calling-frame (descriptor-sap fp)
- #!-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."
+ (/show0 "entering FRAME-DOWN")
+ ;; We have to access the old-fp and return-pc out of frame and pass
+ ;; them to COMPUTE-CALLING-FRAME.
(let ((down (frame-%down frame)))
(if (eq down :unparsed)
- (let* ((real (frame-real-frame frame))
- (debug-fun (frame-debug-function real)))
+ (let ((debug-fun (frame-debug-fun frame)))
+ (/show0 "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 sb!vm::ocfp-save-offset
+ (sb!c::compiled-debug-fun-old-fp c-d-f)))
+ (get-context-value
+ frame sb!vm::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)
(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))
+
frame)))))))
down)))
(#.sb!vm::lra-save-offset
(setf (sap-ref-sap pointer (- (* (1+ stack-slot) 4))) value))))))
-(defvar *debugging-interpreter* nil
- #!+sb-doc
- "When set, the debugger foregoes making interpreted-frames, so you can
- debug the functions that manifest the interpreter.")
-
-;;; This takes a newly computed frame, FRAME, and the frame above it
-;;; on the stack, UP-FRAME, which is possibly NIL. FRAME is NIL when
-;;; we hit the bottom of the control stack. When FRAME represents a
-;;; call to SB!EVAL::INTERNAL-APPLY-LOOP, we make an interpreted frame
-;;; to replace FRAME. The interpreted frame points to FRAME.
-(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
;;; 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)
(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)
#!+x86
(defun compute-calling-frame (caller ra up-frame)
(declare (type system-area-pointer caller ra))
-; (format t "ccf: ~A ~A ~A~%" caller ra up-frame)
+ (/show0 "entering COMPUTE-CALLING-FRAME")
(when (cstack-pointer-valid-p caller)
-; (format t "ccf2~%")
+ (/show0 "in WHEN")
;; First check for an escaped frame.
(multiple-value-bind (code pc-offset escaped) (find-escaped-frame caller)
- (cond (code
- ;; If it's escaped it may be a function end breakpoint trap.
-; (format t "ccf2: escaped ~S ~S~%" code pc-offset)
- (when (and (code-component-p code)
- (eq (%code-debug-info code) :bogus-lra))
- ;; If :bogus-lra grab the real lra.
- (setq pc-offset (code-header-ref
- code (1+ real-lra-slot)))
- (setq code (code-header-ref code real-lra-slot))
-; (format t "ccf3 :bogus-lra ~S ~S~%" code pc-offset)
- (assert code)))
- (t
- ;; Not escaped
- (multiple-value-setq (pc-offset code)
- (compute-lra-data-from-pc ra))
-; (format t "ccf4 ~S ~S~%" code pc-offset)
- (unless code
- (setf code :foreign-function
- pc-offset 0
- escaped nil))))
-
- (let ((d-fun (case code
- (:undefined-function
- (make-bogus-debug-function
- "undefined function"))
- (:foreign-function
- (make-bogus-debug-function
- "foreign function call land"))
- ((nil)
- (make-bogus-debug-function
- "bogus stack frame"))
- (t
- (debug-function-from-pc code pc-offset)))))
- (make-compiled-frame caller up-frame d-fun
- (code-location-from-pc d-fun pc-offset
- escaped)
- (if up-frame (1+ (frame-number up-frame)) 0)
- escaped)))))
-
-#!-(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"))
+ (/show0 "at COND")
+ (cond (code
+ (/show0 "in CODE clause")
+ ;; If it's escaped it may be a function end breakpoint trap.
+ (when (and (code-component-p code)
+ (eq (%code-debug-info code) :bogus-lra))
+ ;; If :bogus-lra grab the real lra.
+ (setq pc-offset (code-header-ref
+ code (1+ real-lra-slot)))
+ (setq code (code-header-ref code real-lra-slot))
+ (aver code)))
+ (t
+ (/show0 "in T clause")
+ ;; not escaped
+ (multiple-value-setq (pc-offset code)
+ (compute-lra-data-from-pc ra))
+ (unless code
+ (setf code :foreign-function
+ pc-offset 0
+ escaped nil))))
+
+ (let ((d-fun (case code
+ (:undefined-function
+ (make-bogus-debug-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)))))
+ (/show0 "returning MAKE-COMPILED-FRAME from COMPUTE-CALLING-FRAME")
+ (make-compiled-frame caller up-frame d-fun
+ (code-location-from-pc d-fun pc-offset
+ escaped)
+ (if up-frame (1+ (frame-number up-frame)) 0)
+ escaped)))))
+
#!+x86
(defun find-escaped-frame (frame-pointer)
(declare (type system-area-pointer frame-pointer))
- (dotimes (index sb!impl::*free-interrupt-context-index* (values nil 0 nil))
+ (/show0 "entering FIND-ESCAPED-FRAME")
+ (dotimes (index *free-interrupt-context-index* (values nil 0 nil))
(sb!alien:with-alien
- ((lisp-interrupt-contexts (array (* os-context-t) nil)
- :extern))
+ ((lisp-interrupt-contexts (array (* os-context-t) nil) :extern))
+ (/show0 "at head of WITH-ALIEN")
(let ((context (sb!alien:deref lisp-interrupt-contexts index)))
+ (/show0 "got CONTEXT")
(when (= (sap-int frame-pointer)
(sb!vm:context-register context sb!vm::cfp-offset))
(without-gcing
+ (/show0 "in WITHOUT-GCING")
(let* ((component-ptr (component-ptr-from-pc
(sb!vm:context-pc context)))
(code (unless (sap= component-ptr (int-sap #x0))
(component-from-component-ptr component-ptr))))
+ (/show0 "got CODE")
(when (null code)
(return (values code 0 context)))
(let* ((code-header-len (* (get-header-data code)
(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)))
+ (/show "got PC-OFFSET")
(unless (<= 0 pc-offset
(* (code-header-ref code sb!vm:code-code-size-slot)
sb!vm:word-bytes))
;; FIXME: Should this be WARN or ERROR or what?
(format t "** pc-offset ~S not in code obj ~S?~%"
pc-offset code))
+ (/show0 "returning from FIND-ESCAPED-FRAME")
(return
(values code pc-offset context))))))))))
+#!-x86
+(defun find-escaped-frame (frame-pointer)
+ (declare (type system-area-pointer frame-pointer))
+ (dotimes (index *free-interrupt-context-index* (values nil 0 nil))
+ (sb!alien:with-alien
+ ((lisp-interrupt-contexts (array (* os-context-t) nil) :extern))
+ (let ((scp (sb!alien:deref lisp-interrupt-contexts index)))
+ (when (= (sap-int frame-pointer)
+ (sb!vm:context-register scp sb!vm::cfp-offset))
+ (without-gcing
+ (let ((code (code-object-from-bits
+ (sb!vm:context-register scp sb!vm::code-offset))))
+ (when (symbolp code)
+ (return (values code 0 scp)))
+ (let* ((code-header-len (* (get-header-data code)
+ sb!vm:word-bytes))
+ (pc-offset
+ (- (sap-int (sb!vm:context-pc scp))
+ (- (get-lisp-obj-address code)
+ sb!vm:other-pointer-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:word-bytes))
+ (unless (<= 0 pc-offset
+ (* (code-header-ref code sb!vm:code-code-size-slot)
+ sb!vm:word-bytes))
+ ;; We were in an assembly routine. Therefore, use the
+ ;; LRA as the pc.
+ (setf pc-offset
+ (- (sb!vm:context-register scp sb!vm::lra-offset)
+ (get-lisp-obj-address code)
+ code-header-len)))
+ (return
+ (if (eq (%code-debug-info code) :bogus-lra)
+ (let ((real-lra (code-header-ref code
+ real-lra-slot)))
+ (values (lra-code-header real-lra)
+ (get-header-data real-lra)
+ nil))
+ (values code pc-offset scp)))))))))))
+
;;; Find the code object corresponding to the object represented by
;;; bits and return it. We assume bogus functions correspond to the
;;; undefined-function.
-#!-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)
+ (if (= lowtag sb!vm:other-pointer-lowtag)
(let ((type (get-type object)))
- (cond ((= type sb!vm:code-header-type)
+ (cond ((= type sb!vm:code-header-widetag)
object)
- ((= type sb!vm:return-pc-header-type)
+ ((= type 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"))
\f
;;;; 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 code 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 (get-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)))))
+ (>= 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
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))
+ (let ((catch (descriptor-sap *current-catch-block*))
(res nil)
- (fp (frame-pointer (frame-real-frame frame))))
+ (fp (frame-pointer frame)))
(loop
(when (zerop (sap-int catch)) (return (nreverse res)))
(when (sap= fp
(sap-ref-32 catch
(* sb!vm:catch-block-current-cont-slot
sb!vm:word-bytes))))
- (let* (#!-(or gengc x86)
+ (let* (#!-x86
(lra (stack-ref catch sb!vm:catch-block-entry-pc-slot))
- #!+(or gengc x86)
+ #!+x86
(ra (sap-ref-sap
catch (* sb!vm:catch-block-entry-pc-slot
sb!vm:word-bytes)))
(component (component-from-component-ptr
(component-ptr-from-pc ra)))
(offset
- #!-(or gengc x86)
+ #!-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)
+ sb!vm:other-pointer-lowtag)
(* (get-header-data component) sb!vm:word-bytes))))
(push (cons #!-x86
(stack-ref catch sb!vm:catch-block-tag-slot)
(sap-ref-32 catch (* sb!vm:catch-block-tag-slot
sb!vm:word-bytes)))
(make-compiled-code-location
- offset (frame-debug-function frame)))
+ offset (frame-debug-fun frame)))
res)))
(setf catch
#!-alpha
(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))))
\f
-;;;; 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)
,@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)
+ (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 (get-type 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)))
+ (get-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
;; 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:word-bytes)))))))
+
+;;; Return the kind of the function, which is one of :OPTIONAL,
+;;; :EXTERNAL, TOP-level, :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)
(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))
(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)
;; 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)
;; 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
(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)))
((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)))
\f
;;;; unpacking variable and basic block data
(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.
;;;
) ; 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)))))
+ :debug-fun debug-fun)))))
-;;; This returns a simple-vector of debug-blocks or nil. NIL indicates
+;;; This returns a SIMPLE-VECTOR of DEBUG-BLOCKs or NIL. NIL indicates
;;; there was no basic block information.
-(defun parse-debug-blocks (debug-function)
- (etypecase debug-function
- (compiled-debug-function
- (parse-compiled-debug-blocks debug-function))
- (bogus-debug-function
- (debug-signal 'no-debug-blocks :debug-function debug-function))
- (interpreted-debug-function
- (parse-interpreted-debug-blocks debug-function))))
+(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* ((debug-fun (compiled-debug-fun-compiler-debug-fun
+ debug-fun))
+ (var-count (length (debug-fun-debug-vars debug-fun)))
+ (blocks (sb!c::compiled-debug-fun-blocks 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)))
+ (tlf-number (sb!c::compiled-debug-fun-tlf-number 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)
(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))))
(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))
(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..
;; 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)
(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)
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
\f
;;;; 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)
+;;; Return a FUN-MAP for a given COMPILED-DEBUG-INFO object.
+(defun get-debug-info-fun-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))))))
+ (let ((map (sb!c::compiled-debug-info-fun-map info)))
+ ;; The old CMU CL had various hairy possibilities here, but in
+ ;; SBCL we only use this one, right?
+ (aver (simple-vector-p map))
+ ;; So it's easy..
+ map))
\f
;;;; 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)
(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
;;; 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)
(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
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)
((null src) (car prev))
(when (< offset (sb!c::debug-source-source-root (car src)))
(return (car prev)))))))
- (interpreted-code-location
- (first
- (let ((sb!c::*lexenv* (make-null-lexenv)))
- (sb!c::debug-source-for-info
- (sb!c::component-source-info
- (sb!c::block-component
- (sb!c::node-block
- (interpreted-code-location-ir1-node code-location))))))))))
-
+ ;; (There used to be more cases back before sbcl-0.7.0, when we
+ ;; did special tricks to debug the IR1 interpreter.)
+ ))
+
+;;; Returns the number of top-level forms before the one containing
+;;; CODE-LOCATION as seen by the compiler in some compilation unit. (A
+;;; compilation unit is not necessarily a single file, see the section
+;;; on debug-sources.)
(defun code-location-top-level-form-offset (code-location)
- #!+sb-doc
- "Returns the number of top-level forms before the one containing
- code-location as seen by the compiler in some compilation unit. A
- compilation unit is not necessarily a single file, see the section on
- debug-sources."
(when (code-location-unknown-p code-location)
(error 'unknown-code-location :code-location code-location))
(let ((tlf-offset (code-location-%tlf-offset code-location)))
;; 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)))
;; 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
(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.
(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.
(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 the IR1
+ ;; interpreter.)
+ ))
(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))
\f
;;;; operations on DEBUG-BLOCKs
-(defmacro do-debug-block-locations ((code-var debug-block &optional return)
+;;; Execute FORMS in a context with CODE-VAR bound to each
+;;; CODE-LOCATION in DEBUG-BLOCK, and return the value of RESULT.
+(defmacro do-debug-block-locations ((code-var debug-block &optional result)
&body body)
- #!+sb-doc
- "Executes forms in a context with code-var bound to each code-location in
- debug-block. This returns the value of executing result (defaults to nil)."
(let ((code-locations (gensym))
(i (gensym)))
`(let ((,code-locations (debug-block-code-locations ,debug-block)))
(declare (simple-vector ,code-locations))
- (dotimes (,i (length ,code-locations) ,return)
+ (dotimes (,i (length ,code-locations) ,result)
(let ((,code-var (svref ,code-locations ,i)))
,@body)))))
+;;; Return the name of the function represented by DEBUG-FUN.
+;;; This may be a string or a cons; do not assume it is a symbol.
(defun debug-block-function-name (debug-block)
- #!+sb-doc
- "Returns the name of the function represented by debug-function. This may
- be a string or a cons; do not assume it is a symbol."
(etypecase debug-block
(compiled-debug-block
(let ((code-locs (compiled-debug-block-code-locations debug-block)))
(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.)
+ ))
\f
;;;; operations on debug variables
(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.
;;; those variables are invalid.)
(defun make-valid-lisp-obj (val)
(/show0 "entering MAKE-VALID-LISP-OBJ, VAL=..")
- #!+sb-show (%primitive print (sb!impl::hexstr val))
+ #!+sb-show (/hexstr val)
(if (or
;; fixnum
(zerop (logand val 3))
;; 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
(make-lisp-obj val)
:invalid-object))
-;;; CMU CL had
-;;; (DEFUN SUB-ACCESS-DEBUG-VAR-SLOT (FP SC-OFFSET &OPTIONAL ESCAPED) ..)
-;;; code for this case.
#!-x86
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (error "hopelessly stale"))
+(defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
+ (macrolet ((with-escaped-value ((var) &body forms)
+ `(if escaped
+ (let ((,var (sb!vm:context-register
+ escaped
+ (sb!c:sc-offset-offset sc-offset))))
+ ,@forms)
+ :invalid-value-for-unescaped-register-storage))
+ (escaped-float-value (format)
+ `(if escaped
+ (sb!vm:context-float-register
+ escaped
+ (sb!c:sc-offset-offset sc-offset)
+ ',format)
+ :invalid-value-for-unescaped-register-storage))
+ (with-nfp ((var) &body body)
+ `(let ((,var (if escaped
+ (sb!sys:int-sap
+ (sb!vm:context-register escaped
+ sb!vm::nfp-offset))
+ #!-alpha
+ (sb!sys:sap-ref-sap fp (* sb!vm::nfp-save-offset
+ sb!vm:word-bytes))
+ #!+alpha
+ (sb!vm::make-number-stack-pointer
+ (sb!sys:sap-ref-32 fp (* sb!vm::nfp-save-offset
+ sb!vm:word-bytes))))))
+ ,@body)))
+ (ecase (sb!c:sc-offset-scn sc-offset)
+ ((#.sb!vm:any-reg-sc-number
+ #.sb!vm:descriptor-reg-sc-number
+ #!+rt #.sb!vm:word-pointer-reg-sc-number)
+ (sb!sys:without-gcing
+ (with-escaped-value (val) (sb!kernel:make-lisp-obj val))))
+
+ (#.sb!vm:base-char-reg-sc-number
+ (with-escaped-value (val)
+ (code-char val)))
+ (#.sb!vm:sap-reg-sc-number
+ (with-escaped-value (val)
+ (sb!sys:int-sap val)))
+ (#.sb!vm:signed-reg-sc-number
+ (with-escaped-value (val)
+ (if (logbitp (1- sb!vm: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:word-bytes))))
+ (#.sb!vm:double-stack-sc-number
+ (with-nfp (nfp)
+ (sb!sys:sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes))))
+ #!+long-float
+ (#.sb!vm:long-stack-sc-number
+ (with-nfp (nfp)
+ (sb!sys:sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes))))
+ (#.sb!vm:complex-single-stack-sc-number
+ (with-nfp (nfp)
+ (complex
+ (sb!sys:sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes))
+ (sb!sys:sap-ref-single nfp (* (1+ (sb!c:sc-offset-offset sc-offset))
+ sb!vm:word-bytes)))))
+ (#.sb!vm:complex-double-stack-sc-number
+ (with-nfp (nfp)
+ (complex
+ (sb!sys:sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes))
+ (sb!sys:sap-ref-double nfp (* (+ (sb!c:sc-offset-offset sc-offset) 2)
+ sb!vm:word-bytes)))))
+ #!+long-float
+ (#.sb!vm:complex-long-stack-sc-number
+ (with-nfp (nfp)
+ (complex
+ (sb!sys:sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes))
+ (sb!sys:sap-ref-long nfp (* (+ (sb!c:sc-offset-offset sc-offset)
+ #!+sparc 4)
+ sb!vm:word-bytes)))))
+ (#.sb!vm:control-stack-sc-number
+ (sb!kernel:stack-ref fp (sb!c:sc-offset-offset sc-offset)))
+ (#.sb!vm:base-char-stack-sc-number
+ (with-nfp (nfp)
+ (code-char (sb!sys:sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes)))))
+ (#.sb!vm:unsigned-stack-sc-number
+ (with-nfp (nfp)
+ (sb!sys:sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes))))
+ (#.sb!vm:signed-stack-sc-number
+ (with-nfp (nfp)
+ (sb!sys:signed-sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes))))
+ (#.sb!vm:sap-stack-sc-number
+ (with-nfp (nfp)
+ (sb!sys:sap-ref-sap nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes)))))))
#!+x86
(defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
(declare (type system-area-pointer fp))
(/show0 "entering SUB-ACCESS-DEBUG-VAR-SLOT, FP,SC-OFFSET,ESCAPED=..")
- #!+sb-show (%primitive print (sb!impl::hexstr fp))
- #!+sb-show (%primitive print (sb!impl::hexstr sc-offset))
- #!+sb-show (%primitive print (sb!impl::hexstr escaped))
+ (/hexstr fp) (/hexstr sc-offset) (/hexstr escaped)
(macrolet ((with-escaped-value ((var) &body forms)
`(if escaped
(let ((,var (sb!vm:context-register
escaped
(sb!c:sc-offset-offset sc-offset))))
(/show0 "in escaped case, ,VAR value=..")
- #!+sb-show (%primitive print (sb!impl::hexstr ,var))
+ (/hexstr ,var)
,@forms)
:invalid-value-for-unescaped-register-storage))
(escaped-float-value (format)
(without-gcing
(with-escaped-value (val)
(/show0 "VAL=..")
- #!+sb-show (%primitive print (sb!impl::hexstr val))
+ (/hexstr val)
(make-valid-lisp-obj val))))
(#.sb!vm:base-char-reg-sc-number
(/show0 "case of BASE-CHAR-REG-SC-NUMBER")
(#.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")
;;; 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.
sb!vm::nfp-offset))
#!-alpha
(sap-ref-sap fp
- (* sb!vm::nfp-save-offset
- sb!vm:word-bytes))
+ (* sb!vm::nfp-save-offset
+ sb!vm:word-bytes))
#!+alpha
- (%alpha::make-number-stack-pointer
+ (sb!vm::make-number-stack-pointer
(sap-ref-32 fp
- (* sb!vm::nfp-save-offset
- sb!vm:word-bytes))))))
+ (* sb!vm::nfp-save-offset
+ sb!vm:word-bytes))))))
,@body)))
(ecase (sb!c:sc-offset-scn sc-offset)
((#.sb!vm:any-reg-sc-number
(#.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
(#.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
;;; 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 (= (get-lowtag x) sb!vm:other-pointer-lowtag)
+ (= (get-type 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)))))
;;; Given the DEFUN, 3 gets you the LET, 1 gets you the bindings, 0
;;; gets the first binding, and 1 gets the AREF form.
-;;; Temporary buffer used to build form-number => source-path translation in
-;;; FORM-NUMBER-TRANSLATIONS.
+;;; temporary buffer used to build form-number => source-path translation in
+;;; FORM-NUMBER-TRANSLATIONS
(defvar *form-number-temp* (make-array 10 :fill-pointer 0 :adjustable t))
-;;; Table used to detect CAR circularities in FORM-NUMBER-TRANSLATIONS.
+;;; table used to detect CAR circularities in FORM-NUMBER-TRANSLATIONS
(defvar *form-number-circularity-table* (make-hash-table :test 'eq))
+;;; This returns a table mapping form numbers to source-paths. A source-path
+;;; indicates a descent into the top-level-form form, going directly to the
+;;; subform corressponding to the form number.
+;;;
;;; The vector elements are in the same format as the compiler's
-;;; NODE-SOUCE-PATH; that is, the first element is the form number and the last
-;;; is the top-level-form number.
+;;; NODE-SOURCE-PATH; that is, the first element is the form number and
+;;; the last is the top-level-form number.
(defun form-number-translations (form tlf-number)
- #!+sb-doc
- "This returns a table mapping form numbers to source-paths. A source-path
- indicates a descent into the top-level-form form, going directly to the
- subform corressponding to the form number."
(clrhash *form-number-circularity-table*)
(setf (fill-pointer *form-number-temp*) 0)
(sub-translate-form-numbers form (list tlf-number))
(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.
(cons res (nthcdr (1+ n) form))))))))
(frob form path context))))
\f
-;;;; 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-VARIABLE-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))
;; 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))
\f
;;;; 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)
: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
+ sb!vm::lra-save-offset
lra-sc-offset))
(setf (get-context-value frame
- #!-gengc sb!vm::lra-save-offset
- #!+gengc sb!vm::ra-save-offset
+ sb!vm::lra-save-offset
lra-sc-offset)
lra)
(let ((end-bpts (breakpoint-%info starter-bpt)))
(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
+ sb!vm::lra-save-offset
lra-sc-offset)))
(return t)))))
-
+\f
;;;; 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)
(: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)
(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)
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)
(setf (breakpoint-data-breakpoints data)
(append (breakpoint-data-breakpoints data) (list breakpoint)))
(setf (breakpoint-internal-data breakpoint) data)))
-
+\f
;;;; 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))
(delete-breakpoint-data data))))
(setf (breakpoint-status breakpoint) :inactive)
breakpoint)
-
+\f
;;;; 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))))
-
+\f
;;;; 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)
(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)
-
+\f
;;;; C call out stubs
;;; This actually installs the break instruction in the component. It
(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")
;; 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
(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)
+ (/show0 "entering HANDLE-FUN-END-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)))
(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)
+ (/show0 "entering HANDLE-FUN-END-BREAKPOINT-AUX")
(delete-breakpoint-data data)
(let* ((scp
(locally
(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
(stack-ref ocfp arg-num))
results)))
(nreverse results)))
+\f
+;;;; 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
(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)
\f
;;;; 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"
projects / sbcl.git / blobdiff