;;;; the implementation of the programmer's interface to writing
;;;; debugging tools
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB-DI")
(defstruct (sb-c::core-debug-source (:pure t)
(:copier nil)
(:include debug-source))
;; Compilation to memory stores each toplevel form given to %COMPILE.
;; That form can generate multiple functions, and those functions can
;; be in one or more code components. They all point at the same form.
form
(function nil :read-only t))
;;; FIXME: There are an awful lot of package prefixes in this code.
;;; Couldn't we have SB-DI use the SB-C and SB-VM packages?
;;;; conditions
;;;; The interface to building debugging tools signals conditions that
;;;; prevent it from adhering to its contract. These are
;;;; serious-conditions because the program using the interface must
;;;; handle them before it can correctly continue execution. These
;;;; debugging conditions are not errors since it is no fault of the
;;;; programmers that the conditions occur. The interface does not
;;;; provide for programs to detect these situations other than
;;;; calling a routine that detects them and signals a condition. For
;;;; example, programmers call A which may fail to return successfully
;;;; due to a lack of debug information, and there is no B the they
;;;; could have called to realize A would fail. It is not an error to
;;;; have called A, but it is an error for the program to then ignore
;;;; the signal generated by A since it cannot continue without A's
;;;; correctly returning a value or performing some operation.
;;;;
;;;; Use DEBUG-SIGNAL to signal these conditions.
(define-condition debug-condition (serious-condition)
()
(:documentation
"All DEBUG-CONDITIONs inherit from this type. These are serious conditions
that must be handled, but they are not programmer errors."))
(define-condition no-debug-fun-returns (debug-condition)
((debug-fun :reader no-debug-fun-returns-debug-fun
:initarg :debug-fun))
(:documentation
"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-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 ~
values here."
fun)))))
(define-condition no-debug-blocks (debug-condition)
((debug-fun :reader no-debug-blocks-debug-fun
:initarg :debug-fun))
(: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-fun condition)))))
(define-condition no-debug-vars (debug-condition)
((debug-fun :reader no-debug-vars-debug-fun
:initarg :debug-fun))
(: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-fun condition)))))
(define-condition lambda-list-unavailable (debug-condition)
((debug-fun :reader lambda-list-unavailable-debug-fun
:initarg :debug-fun))
(:documentation
"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-fun condition)))))
(define-condition invalid-value (debug-condition)
((debug-var :reader invalid-value-debug-var :initarg :debug-var)
(frame :reader invalid-value-frame :initarg :frame))
(:report (lambda (condition stream)
(format stream "~&~S has :invalid or :unknown value in ~S."
(invalid-value-debug-var condition)
(invalid-value-frame condition)))))
(define-condition ambiguous-var-name (debug-condition)
((name :reader ambiguous-var-name-name :initarg :name)
(frame :reader ambiguous-var-name-frame :initarg :frame))
(:report (lambda (condition stream)
(format stream "~&~S names more than one valid variable in ~S."
(ambiguous-var-name-name condition)
(ambiguous-var-name-frame condition)))))
;;;; errors and DEBUG-SIGNAL
;;; The debug-internals code tries to signal all programmer errors as
;;; subtypes of DEBUG-ERROR. There are calls to ERROR signalling
;;; SIMPLE-ERRORs, but these dummy checks in the code and shouldn't
;;; come up.
;;;
;;; While under development, this code also signals errors in code
;;; branches that remain unimplemented.
(define-condition debug-error (error) ()
(:documentation
"All programmer errors from using the interface for building debugging
tools inherit from this type."))
(define-condition unhandled-debug-condition (debug-error)
((condition :reader unhandled-debug-condition-condition :initarg :condition))
(:report (lambda (condition stream)
(format stream "~&unhandled DEBUG-CONDITION:~%~A"
(unhandled-debug-condition-condition condition)))))
(define-condition unknown-code-location (debug-error)
((code-location :reader unknown-code-location-code-location
:initarg :code-location))
(:report (lambda (condition stream)
(format stream "~&invalid use of an unknown code-location: ~S"
(unknown-code-location-code-location condition)))))
(define-condition unknown-debug-var (debug-error)
((debug-var :reader unknown-debug-var-debug-var :initarg :debug-var)
(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-fun condition)))))
(define-condition invalid-control-stack-pointer (debug-error)
()
(:report (lambda (condition stream)
(declare (ignore condition))
(fresh-line stream)
(write-string "invalid control stack pointer" stream))))
(define-condition frame-fun-mismatch (debug-error)
((code-location :reader frame-fun-mismatch-code-location
:initarg :code-location)
(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-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.
;;;
;;; ??? Get SIGNAL in the right package!
(defmacro debug-signal (datum &rest arguments)
`(let ((condition (make-condition ,datum ,@arguments)))
(signal condition)
(error 'unhandled-debug-condition :condition condition)))
;;;; structures
;;;;
;;;; Most of these structures model information stored in internal
;;;; 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 "SB-DI" package.
;;;; DEBUG-VARs
;;; These exist for caching data stored in packed binary form in
;;; compiler DEBUG-FUNs.
(defstruct (debug-var (:constructor nil)
(:copier nil))
;; the name of the variable
(symbol (missing-arg) :type symbol)
;; a unique integer identification relative to other variables with the same
;; symbol
(id 0 :type index :read-only t)
;; Does the variable always have a valid value?
(alive-p nil :type boolean :read-only t))
(defmethod print-object ((debug-var debug-var) stream)
(print-unreadable-object (debug-var stream :type t :identity t)
(format stream
"~S ~W"
(debug-var-symbol debug-var)
(debug-var-id debug-var))))
(setf (documentation 'debug-var-id 'function)
"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 indirect-sc+offset info))
(:copier nil))
;; storage class and offset (unexported)
(sc+offset nil :type sb-c:sc+offset :read-only t)
;; storage class and offset when saved somewhere
(save-sc+offset nil :type (or sb-c:sc+offset null) :read-only t)
;; For indirect closures the fp of the parent frame is stored in the
;; normal SC+OFFSETs above, and this has the offset into the frame
(indirect-sc+offset nil :type (or sb-c:sc+offset null) :read-only t)
(info nil :read-only t))
;;;; DEBUG-FUNs
;;; These exist for caching data stored in packed binary form in
;;; 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).
;; 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
;; parse the packed binary info, but none is available.
(blocks :unparsed :type (or simple-vector null (member :unparsed)))
;; the actual function if available
(%function :unparsed :type (or null function (member :unparsed))))
(defmethod print-object ((obj debug-fun) stream)
(print-unreadable-object (obj stream :type t)
(prin1 (debug-fun-name obj) stream)))
(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 nil :read-only t))
;;;; DEBUG-BLOCKs
;;; These exist for caching data stored in packed binary form in compiler
;;; DEBUG-BLOCKs.
(defstruct (debug-block (:constructor nil)
(:copier nil))
;; 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))
(defmethod print-object ((obj debug-block) str)
(print-unreadable-object (obj str :type t)
(prin1 (debug-block-fun-name obj) str)))
(setf (documentation 'debug-block-elsewhere-p 'function)
"Return whether debug-block represents elsewhere code.")
(defstruct (compiled-debug-block (:include debug-block)
(:copier nil))
;; code-location information for the block
(code-locations #() :type simple-vector))
(defstruct (code-location (:constructor nil)
(:copier nil))
;; the DEBUG-FUN containing this CODE-LOCATION
(debug-fun nil :type debug-fun :read-only t)
;; 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
;; becomes NIL, a known location. We can't use a separate type
;; code-location for this since we must return code-locations before
;; we can tell whether they're known or unknown. For example, when
;; parsing the stack, we don't want to unpack all the variables and
;; blocks just to make frames.
(%unknown-p :unsure :type (member t nil :unsure))
;; 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 depth-first number of the node that begins
;; code-location within its top level form.
(%form-number :unparsed :type (or index (member :unparsed))))
;;;; frames
;;; These represent call frames on the stack.
(defstruct (frame (:constructor nil)
(:copier nil))
;; the next frame up, or NIL when top frame
;; KLUDGE - (OR NULL FRAME), and not (OR FRAME NULL), because PARSE-1-DSD
;; warns; we're so bad at understanding recursive structure.
(up nil :type (or null frame))
;; the previous frame down, or NIL when the bottom frame. Before
;; computing the next frame down, this slot holds the frame pointer
;; 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 (member nil :unparsed) frame))
;; the DEBUG-FUN for the function whose call this frame represents
(debug-fun nil :type debug-fun :read-only t)
;; 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 :read-only t)
;; an a-list of catch-tags to code-locations
(%catches :unparsed :type (or list (member :unparsed)))
;; pointer to frame on control stack (unexported)
(pointer nil :read-only t)
;; This is the frame's number for prompt printing. Top is zero.
(number 0 :type index))
(defstruct (compiled-frame
(:include frame)
(:constructor make-compiled-frame
(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, an os_context_t, i.e. the third
;; argument to an SA_SIGACTION-style signal handler.
(escaped nil :read-only t))
(defmethod print-object ((obj compiled-frame) str)
(print-unreadable-object (obj str :type t)
(format str
"~S~:[~;, interrupted~]"
(debug-fun-name (frame-debug-fun obj))
(compiled-frame-escaped obj))))
;;; 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.
#+cheneygc ; can't write to debug-info in a purified code object
(define-load-time-global *compiled-debug-funs*
(make-hash-table :test 'eq :weakness :key))
;;;; 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))
(:copier nil))
;; This is the component in which the breakpoint lies.
(component nil :read-only t)
;; This is the byte offset into the component.
(offset nil :type index :read-only t)
;; The original instruction replaced by the breakpoint.
(instruction nil :type (or null sb-vm:word))
;; A list of user breakpoints at this location.
(breakpoints nil :type list))
(defmethod print-object ((obj breakpoint-data) str)
(print-unreadable-object (obj str :type t)
(format str "~S at ~S"
(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-fun 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 :FUN-END breakpoints as
;; values to return for the function containing the breakpoint.
;; :FUN-END breakpoint hook functions also take a cookie argument.
;; See the COOKIE-FUN slot.
(hook-fun (required-arg) :type function)
;; CODE-LOCATION or DEBUG-FUN
(what nil :type (or code-location debug-fun) :read-only t)
;; :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 :fun-start :fun-end
:unknown-return-partner)
:read-only t)
;; Status helps the user and the implementation.
(status :inactive :type (member :active :inactive :deleted))
;; This is a backpointer to a breakpoint-data.
(internal-data nil :type (or null breakpoint-data))
;; With code-locations whose type is :UNKNOWN-RETURN, there are
;; really two breakpoints: one at the multiple-value entry point,
;; and one at the single-value entry point. This slot holds the
;; 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))
;; :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
;; points to the start breakpoint, so we can activate, deactivate,
;; and delete it.
(start-helper nil :type (or null breakpoint))
;; This is a hook users supply to get a dynamically unique cookie
;; 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))
;; This slot users can set with whatever information they find useful.
(%info nil))
(defmethod print-object ((obj breakpoint) str)
(let ((what (breakpoint-what obj)))
(print-unreadable-object (obj str :type t)
(format str
"~S~:[~;~:*~S~]"
(etypecase what
(code-location what)
(debug-fun (debug-fun-name what)))
(etypecase what
(code-location nil)
(debug-fun (breakpoint-kind obj)))))))
(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
:read-only t)
;; code object (unexported).
(component nil :read-only t)
;; the :FUN-START breakpoint (if any) used to facilitate
;; function end breakpoints
(end-starter nil :type (or null breakpoint)))
;;; Map a SB-C::COMPILED-DEBUG-FUN to a SB-DI::COMPILED-DEBUG-FUN.
;;; The mapping is memoized into a slot of %CODE-DEBUG-INFO of COMPONENT
;;; except on #+cheneygc where that is assumed not to be possible
;;; (even if it is possible), because usually it's not, because
;;; code and the debug structures are defined with :PURE T and might reside
;;; in readonly space, which can only have pointers to static space.
;;;
;;; BTW, the nomenclature here is utter and total confusion.
;;; The type of the object in the argument named COMPILER-DEBUG-FUN
;;; is SB-C::COMPILED-DEBUG-FUN.
;;; There is no such type as a "COMPILER-DEBUG-FUN", it's just the name
;;; of the slot in the SB-DI:: version of the structure.
(defun make-compiled-debug-fun (compiler-debug-fun component)
(declare (code-component component))
#+gencgc
(let ((memo-cell
(let* ((info (sb-vm::%%code-debug-info component))
(val (sb-c::compiled-debug-info-tlf-num+offset info)))
(if (consp val)
val
(let* ((list (list val))
(old (cas (sb-c::compiled-debug-info-tlf-num+offset info) val list)))
(if (eq old val) list old))))))
;; The CDR of TLF-NUM+OFFSET slot is an alist from compiler -> debugger structure.
(let ((new-df nil) (new-pair nil) (new-alist nil) (alist (cdr memo-cell)))
(loop
;; This list generally contains 5 items or less. At least, in our tests it does
;; which I assume is typical.
(awhen (assoc compiler-debug-fun alist :test #'eq) (return (cdr it)))
(if new-alist
(rplacd new-alist alist)
(setq new-df (%make-compiled-debug-fun compiler-debug-fun component)
new-pair (cons compiler-debug-fun new-df)
new-alist (cons new-pair alist)))
(let ((old (cas (cdr memo-cell) alist new-alist)))
(if (eq old alist) (return new-df) (setq alist old))))))
#+cheneygc
(ensure-gethash compiler-debug-fun *compiled-debug-funs*
(%make-compiled-debug-fun compiler-debug-fun component)))
;;;; CODE-LOCATIONs
(defmethod print-object ((obj code-location) str)
(print-unreadable-object (obj str :type t)
(prin1 (debug-fun-name (code-location-debug-fun obj))
str)))
(defstruct (compiled-code-location
(:include code-location)
(:constructor make-known-code-location
(pc debug-fun %debug-block %form-number
%live-set kind step-info context &aux (%unknown-p nil)))
(:constructor make-compiled-code-location (pc debug-fun))
(:copier nil))
;; an index into DEBUG-FUN's component slot
(pc nil :type index :read-only t)
;; 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:TYPEXPAND 'SB-C::LOCATION-KIND).
(kind :unparsed :type (or (member :unparsed) sb-c::location-kind))
(step-info :unparsed :type (or (member :unparsed :foo) simple-string))
(context :unparsed))
;;;; frames
;;; This is used in FIND-ESCAPED-FRAME and with the "breakpoint return" objects
;;; and LRAs used for :FUN-END breakpoints. When a code object's
;;; debug-info slot is :BPT-LRA, then the REAL-LRA-SLOT contains the
;;; real location to continue executing, as opposed to the intermediary object
;;; which appeared in some frame's LRA location.
;;; NB: If you change change REAL-LRA-SLOT, then you must also change
;;; "#define REAL_LRA_SLOT" in breakpoint.c. These have unfortunately
;;; different values, because this slot is relative to the object base
;;; address, whereas the one in C is an index into code->constants.
(defconstant real-lra-slot sb-vm:code-constants-offset)
(declaim (inline control-stack-pointer-valid-p))
(defun control-stack-pointer-valid-p (x &optional (aligned t))
(declare (type system-area-pointer x))
(let* (#-stack-grows-downward-not-upward
(control-stack-start
(descriptor-sap *control-stack-start*))
#+stack-grows-downward-not-upward
(control-stack-end
(descriptor-sap *control-stack-end*)))
#-stack-grows-downward-not-upward
(and (sap< x (current-sp))
(sap<= control-stack-start x)
(or (not aligned) (zerop (logand (sap-int x)
(1- (ash 1 sb-vm:word-shift))))))
#+stack-grows-downward-not-upward
(and (sap>= x (current-sp))
(sap> control-stack-end x)
(or (not aligned) (zerop (logand (sap-int x)
(1- (ash 1 sb-vm:word-shift))))))))
(declaim (inline valid-lisp-pointer-p))
(sb-alien:define-alien-routine valid-lisp-pointer-p sb-alien:int
(pointer system-area-pointer))
;;; There are many opportunities for things to go wrong when searching
;;; the heap for a code component. One possible problem occurs when
;;; component_ptr_from_pc() searches for a code component on a page which
;;; gets partially evacuated on x86[-64]. Suppose it contains pinned code
;;; preceded by some objects that got forwarded. The scan performed by
;;; gc_search_space could be interrupted in the middle, and resume execution
;;; looking at a forwarding pointer, which gets the fatal "no size function".
;;; Morover, excess delay between finding an object and creating a Lisp
;;; descriptor introduces additional potential for error.
;;; So we do two things to mitigate that problem:
;;; (1) use unsafe %MAKE-LISP-OBJ, since we've already determined
;;; where the code object starts with certainty, and we don't need
;;; yet another search to test validity of the address.
;;; (2) wrap the calls in WITHOUT-GCING.
;;;
;;; Here's a concrete example, assuming the following objects exists:
;;; 0x8000: vector header |
;;; 0x8008: vector length | object 1
;;; 0x8010: vector contents |
;;; : ... v
;;; 0x8100: code object | object 2
;;; : ...
;;; thread A is backtracing, and currently in component_ptr_to_pc(),
;;; looking at 0x8000. Suppose the code is pinned, and that a garbage collection
;;; will partially evacuate the page, and that partial evacuation zero-fills
;;; the unused ranges (which it no longer does). Consider these schedules:
;;;
;;; Thread A Thread B
;;; -------- --------
;;; read header @ 0x8000
;;; GC happens. zero-fill from 0x8000:0x8100
;;; read length @ 0x8008 => 0
;;; (skip to next object)
;;; read header @ 0x8010 => junk
;;;
;;; In this schedule, thread A reads a word which is not a valid object header.
;;;
;;; But partial evacution no longer zeros the freed subranges - instead it writes
;;; an unboxed array header so that only two words are touched per unused subrange.
;;; This causes a different problem: The array may appear to contain forwarding
;;; pointers to live objects that were moved off the page, and those pointers
;;; appear to be embedded in the unboxed array.
;;;
;;; Use of WITHOUT-GCING is unfortunate - it's always preferable to
;;; try to pin individual objects - but to do better we would have to
;;; implement page-wide hazard pointers informing GC not to do anything
;;; to any object on a specified page.
;;;
;;; On top of the considerations about dynamic space, there is a further issue
;;; with allocatin of immobile code. The allocator creates transient inconsistent
;;; states when it reuses holes. Even if the header could be written atomically,
;;; there can be junk in the remaining bytes of the hole that gets rewritten as
;;; a smaller hole. It's evident that acquiring the allocator mutex works around
;;; that glitch, as without such precaution, 'compiler.pure.lisp' would routinely
;;; crash when run in multiple threads. A better fix would be to preseve invariants
;;; at all times when allocating, both for the new hole that results from the hole
;;; that gets cut down to size, and for the new object per se. Example:
;;; | hole ............................ | 1 Kb
;;; ^ new-object here ^ smaller hole starts here
;;; (512 bytes)
;;;
;;; We first need to atomically write the header of the smaller hole
;;; (which can't even be seen until the new object header is written).
;;; This establishes that there won't be an inconsistent state.
;;; Then we need to atomically write the new object header.
;;; I suspect that both atomic writes should use double-wide CAS,
;;; because if the object header is written using lispword-sized writes,
;;; then the object can be sized wrong, and in this case it does cause problems
;;; because the remaining bytes are not zero-filled. The allocator is similar
;;; to malloc() in that regard.
(defun code-header-from-pc (pc)
(with-code-pages-pinned (:dynamic)
(let ((base-ptr
(sb-alien:alien-funcall
(sb-alien:extern-alien "component_ptr_from_pc"
(function sb-alien:unsigned system-area-pointer))
(etypecase pc
(system-area-pointer pc)
(sb-vm:word (int-sap pc))))))
(unless (= base-ptr 0)
(%make-lisp-obj (logior base-ptr sb-vm:other-pointer-lowtag))))))
;;;; (OR X86 X86-64) support
#+(or x86 x86-64)
(progn
(defun compute-lra-data-from-pc (pc)
(declare (type system-area-pointer pc))
;; While theoretically we should inhibit GC any time we search the heap,
;; in practice this function can only be called for code that is somewhere
;; on the stack, and therefore conservatively pinned.
(let ((code (code-header-from-pc pc)))
(values (if code (sap- pc (code-instructions code)) nil)
code)))
;;; Check for a valid return address - it could be any valid C/Lisp
;;; address.
;;;
;;; XXX Could be a little smarter.
(declaim (inline ra-pointer-valid-p))
(defun ra-pointer-valid-p (ra)
(declare (type system-area-pointer ra))
(and
;; not the first page (which is unmapped)
;;
;; FIXME: Where is this documented? Is it really true of every CPU
;; architecture? Is it even necessarily true in current SBCL?
(>= (sap-int ra) 4096)
;; not a Lisp stack pointer
(not (control-stack-pointer-valid-p ra))))
;;; Try to find a valid previous stack. This is complex on the x86 as
;;; it can jump between C and Lisp frames. To help find a valid frame
;;; it searches backwards.
;;;
;;; 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.
(declaim (maybe-inline x86-call-context))
(defun x86-call-context (fp)
(declare (type system-area-pointer fp))
(let ((ocfp (sap-ref-sap fp (sb-vm::frame-byte-offset ocfp-save-offset)))
(ra (sap-ref-sap fp (sb-vm::frame-byte-offset return-pc-save-offset))))
(if (and (control-stack-pointer-valid-p fp)
(sap> ocfp fp)
(control-stack-pointer-valid-p ocfp)
(ra-pointer-valid-p ra))
(values t ra ocfp)
(values nil (int-sap 0) (int-sap 0)))))
) ; #+x86 PROGN
;;; Return the top frame of the control stack as it was before calling
;;; this function.
(defun top-frame ()
(/noshow0 "entering TOP-FRAME")
(compute-calling-frame (descriptor-sap (%caller-frame))
(%caller-pc)
nil))
;;; Flush all of the frames above FRAME, and renumber all the frames
;;; below FRAME.
(defun flush-frames-above (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)))
#+(or x86 x86-64)
(defun find-saved-frame-down (fp up-frame)
(multiple-value-bind (saved-fp saved-pc)
(find-saved-fp-and-pc fp)
(when saved-fp
(compute-calling-frame saved-fp saved-pc up-frame t))))
(defun walk-binding-stack (symbol function)
(let* (#+sb-thread
(tls-index (symbol-tls-index symbol))
(current-value
#+sb-thread
(sap-ref-lispobj (sb-thread::current-thread-sap) tls-index)
#-sb-thread
(symbol-value symbol)))
(unless (eq (get-lisp-obj-address current-value)
no-tls-value-marker-widetag)
(funcall function current-value)
(loop for start = (descriptor-sap *binding-stack-start*)
for pointer = (descriptor-sap sb-vm::*binding-stack-pointer*)
then (sap+ pointer (* n-word-bytes -2))
while (sap> pointer start)
when
#+sb-thread (eq (sap-ref-word pointer (* n-word-bytes -1)) tls-index)
#-sb-thread (eq (sap-ref-lispobj pointer (* n-word-bytes -1)) symbol)
do (unless (or #+sb-thread
(= (sap-ref-word pointer (* n-word-bytes -2))
no-tls-value-marker-widetag))
(funcall function
(sap-ref-lispobj pointer
(* n-word-bytes -2))))))))
#+c-stack-is-control-stack
(defun find-saved-fp-and-pc (fp)
(block nil
(walk-binding-stack
'sb-alien-internals:*saved-fp*
(lambda (x)
(when x
(let* ((saved-fp (descriptor-sap x))
(caller-fp (sap-ref-sap saved-fp
(sb-vm::frame-byte-offset
ocfp-save-offset))))
(when (#+stack-grows-downward-not-upward
sap>
#-stack-grows-downward-not-upward
sap<
caller-fp fp)
(return (values caller-fp
(sap-ref-sap saved-fp
(sb-vm::frame-byte-offset
return-pc-save-offset)))))))))))
(defun return-pc-offset-for-location (debug-fun location)
(declare (ignorable debug-fun location))
#+fp-and-pc-standard-save
sb-c:return-pc-passing-offset
#-fp-and-pc-standard-save
(etypecase debug-fun
(compiled-debug-fun
(let ((c-d-f (compiled-debug-fun-compiler-debug-fun debug-fun))
(pc-offset (compiled-code-location-pc location)))
(if (>= pc-offset (sb-c::compiled-debug-fun-lra-saved-pc c-d-f))
(sb-c::compiled-debug-fun-return-pc c-d-f)
(sb-c::compiled-debug-fun-return-pc-pass c-d-f))))
(bogus-debug-fun
;; No handy backend (or compiler) defined constant for this one,
;; so construct it here and now.
(sb-c:make-sc+offset control-stack-sc-number lra-save-offset))))
(defun old-fp-offset-for-location (debug-fun location)
(declare (ignorable debug-fun location))
#+fp-and-pc-standard-save
sb-c:old-fp-passing-offset
#-fp-and-pc-standard-save
(etypecase debug-fun
(compiled-debug-fun
(let ((c-d-f (compiled-debug-fun-compiler-debug-fun debug-fun))
(pc-offset (compiled-code-location-pc location)))
(if (>= pc-offset (sb-c::compiled-debug-fun-cfp-saved-pc c-d-f))
(sb-c::compiled-debug-fun-old-fp c-d-f)
sb-c:old-fp-passing-offset)))
(bogus-debug-fun
;; No handy backend (or compiler) defined constant for this one,
;; so construct it here and now.
(sb-c:make-sc+offset control-stack-sc-number ocfp-save-offset))))
(defun frame-saved-cfp (frame debug-fun)
(sub-access-debug-var-slot
(frame-pointer frame)
(old-fp-offset-for-location debug-fun (frame-code-location frame))
(compiled-frame-escaped frame)))
(defun frame-saved-lra (frame debug-fun)
(sub-access-debug-var-slot
(frame-pointer frame)
(return-pc-offset-for-location debug-fun (frame-code-location frame))
(compiled-frame-escaped frame)))
(defun (setf frame-saved-lra) (new-lra frame debug-fun)
(sub-set-debug-var-slot
(frame-pointer frame)
(return-pc-offset-for-location debug-fun (frame-code-location frame))
new-lra
(compiled-frame-escaped frame))
new-lra)
;;; Return the frame immediately below FRAME on the stack; or when
;;; FRAME is the bottom of the stack, return NIL.
(defun frame-down (frame)
(/noshow0 "entering FRAME-DOWN")
;; We have to access the old-fp and return-pc out of frame and pass
;; them to COMPUTE-CALLING-FRAME.
(let ((down (frame-%down frame)))
(if (eq down :unparsed)
(let ((debug-fun (frame-debug-fun frame)))
(/noshow0 "in DOWN :UNPARSED case")
(setf (frame-%down frame)
(etypecase debug-fun
((or compiled-debug-fun
#-(or x86 x86-64) bogus-debug-fun)
(compute-calling-frame
(descriptor-sap (frame-saved-cfp frame debug-fun))
(frame-saved-lra frame debug-fun)
frame))
#+(or x86 x86-64)
(bogus-debug-fun
(let ((fp (frame-pointer frame)))
(when (control-stack-pointer-valid-p fp)
(multiple-value-bind (ok ra ofp) (x86-call-context fp)
(if ok
(compute-calling-frame ofp ra frame)
(find-saved-frame-down fp frame)))))))))
down)))
(defun foreign-function-backtrace-name (sap)
(let ((name (sap-foreign-symbol sap)))
(if name
(format nil "foreign function: ~A" name)
(format nil "foreign function: #x~X" (sap-int sap)))))
;;; This returns a frame for the one existing in time immediately
;;; prior to the frame referenced by current-fp. This is current-fp's
;;; caller or the next frame down the control stack. If there is no
;;; down frame, this returns NIL for the bottom of the stack. UP-FRAME
;;; is the up link for the resulting frame object, and it is null when
;;; we call this to get the top of the stack.
;;;
;;; The current frame contains the pointer to the temporally previous
;;; frame we want, and the current frame contains the pc at which we
;;; will continue executing upon returning to that previous frame.
;;;
;;; 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 x86 x86-64 arm64)
(defun compute-calling-frame (caller lra up-frame &optional savedp)
(declare (type system-area-pointer caller)
(ignore savedp))
(/noshow0 "entering COMPUTE-CALLING-FRAME")
(when (control-stack-pointer-valid-p caller)
(/noshow0 "in WHEN")
(multiple-value-bind (code pc-offset escaped)
(if lra
(multiple-value-bind (word-offset code)
(if (fixnump lra)
(let ((fp (frame-pointer up-frame)))
(values lra
(let ((code (stack-ref fp (1+ lra-save-offset))))
code
#+ppc64
(%make-lisp-obj (logior (ash code n-fixnum-tag-bits)
other-pointer-lowtag)))))
(values (get-header-data lra)
(lra-code-header lra)))
(if code
(values code
(* (1+ (- word-offset (code-header-words code)))
sb-vm:n-word-bytes)
nil)
(values :foreign-function
0
nil)))
(find-escaped-frame caller))
(if (and (code-component-p code)
(eq (%code-debug-info code) :bpt-lra))
(let ((real-lra (code-header-ref code real-lra-slot)))
(compute-calling-frame caller real-lra up-frame))
(let ((d-fun (case code
(:undefined-function
(make-bogus-debug-fun
"undefined function"))
(:foreign-function
(make-bogus-debug-fun
(foreign-function-backtrace-name
(int-sap (get-lisp-obj-address lra)))))
((nil)
(make-bogus-debug-fun
"bogus stack frame"))
(t
(debug-fun-from-pc code pc-offset)))))
(/noshow0 "returning MAKE-COMPILED-FRAME from COMPUTE-CALLING-FRAME")
(make-compiled-frame caller up-frame d-fun
(code-location-from-pc d-fun pc-offset
escaped)
(if up-frame (1+ (frame-number up-frame)) 0)
escaped))))))
#+arm64
(defun compute-calling-frame (caller lra up-frame &optional savedp)
(declare (type system-area-pointer caller)
(ignore savedp))
(when (control-stack-pointer-valid-p caller)
(multiple-value-bind (code pc-offset escaped)
(if lra
(let* ((lr (int-sap (ash lra n-fixnum-tag-bits)))
(code (code-header-from-pc lr)))
(values code
(if code
(sap- lr (code-instructions code))
0)))
(find-escaped-frame caller))
(if (and (code-component-p code)
(eq (%code-debug-info code) :bpt-lra))
(let ((real-lra (code-header-ref code real-lra-slot)))
(compute-calling-frame caller real-lra up-frame))
(let ((d-fun (case code
(:undefined-function
(make-bogus-debug-fun
"undefined function"))
(:foreign-function
(make-bogus-debug-fun
(foreign-function-backtrace-name
(int-sap (get-lisp-obj-address lra)))))
((nil)
(make-bogus-debug-fun
"bogus stack frame"))
(t
(debug-fun-from-pc code pc-offset escaped)))))
(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 x86 x86-64)
(defun compute-calling-frame (caller ra up-frame &optional savedp)
(declare (type system-area-pointer caller ra))
(/noshow0 "entering COMPUTE-CALLING-FRAME")
(when (control-stack-pointer-valid-p caller)
(/noshow0 "in WHEN")
;; First check for an escaped frame.
(multiple-value-bind (code pc-offset escaped off-stack)
(find-escaped-frame caller)
(/noshow0 "at COND")
(cond (code
;; If it's escaped it may be a function end breakpoint trap.
(when (and (code-component-p code)
(eq (%code-debug-info code) :bpt-lra))
;; If :bpt-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)))
((not escaped)
(multiple-value-setq (pc-offset code)
(compute-lra-data-from-pc ra))
(unless code
(setf code :foreign-function
pc-offset 0))))
(let ((d-fun (case code
(:undefined-function
(make-bogus-debug-fun
"undefined function"))
(:foreign-function
(make-bogus-debug-fun
(foreign-function-backtrace-name ra)))
((nil)
(make-bogus-debug-fun
"bogus stack frame"))
(t
(debug-fun-from-pc code pc-offset escaped)))))
(/noshow0 "returning MAKE-COMPILED-FRAME from COMPUTE-CALLING-FRAME")
(make-compiled-frame caller up-frame d-fun
(code-location-from-pc d-fun pc-offset
escaped)
(if up-frame (1+ (frame-number up-frame)) 0)
;; If we have an interrupt-context that's not on
;; our stack at all, and we're computing the
;; from from a saved FP, we're probably looking
;; at an interrupted syscall.
(or escaped (and savedp off-stack)))))))
(defun nth-interrupt-context (n)
(declare (muffle-conditions compiler-note))
(declare (type (mod #.sb-vm:max-interrupts) n)
(optimize (speed 3) (safety 0)))
(let ((tls-words (ash (sb-alien:extern-alien "dynamic_values_bytes"
(sb-alien:unsigned 32))
(- sb-vm:word-shift))))
(sb-alien:sap-alien (sb-vm::current-thread-offset-sap (+ tls-words n))
(* os-context-t))))
(defun catch-runaway-unwind (block)
(declare (ignorable block))
#-(and win32 x86) ;; uses SEH
(let ((target (sap-ref-sap (descriptor-sap block)
(* unwind-block-uwp-slot n-word-bytes))))
(loop for uwp = (descriptor-sap sb-vm::*current-unwind-protect-block*)
then (sap-ref-sap uwp (* unwind-block-uwp-slot n-word-bytes))
until (zerop (sap-int uwp))
thereis (sap= target uwp)
finally
(let* ((pc (sap-ref-sap (descriptor-sap block)
(* unwind-block-entry-pc-slot n-word-bytes)))
(code (code-header-from-pc pc))
(fun-name
(and code
(or
(multiple-value-bind (offset valid) (code-pc-offset pc code)
(and valid
(let ((debug-fun (debug-fun-from-pc code offset nil)))
(and (compiled-debug-fun-p debug-fun)
(debug-fun-name debug-fun)))))
code))))
(error 'simple-control-error
:format-control
"Attempt to RETURN-FROM a block or GO to a tag that no longer exists~@[ in ~s~]"
:format-arguments (list fun-name))))))
(defun code-pc-offset (pc code)
(declare (type code-component code))
;; We wrap WITH-PINNED-OBJECTS around CODE, but in truth this can go wrong if the
;; code was transported after taking a PC and before getting here. i.e. there is
;; nothing to be gained by arranging that while we calculate CODE-INSTRUCTIONS
;; the code can't move if it already moved.
;; The precisely GCed backends would be a lot more correct with respect to
;; debug-related stuff if we just never move code that is on-stack.
(let ((pc-offset (with-pinned-objects (code)
(sap- pc (code-instructions code))))
(code-size (%code-text-size code)))
(values pc-offset (<= 0 pc-offset code-size) code-size)))
(defun context-code-pc-offset (context code)
(code-pc-offset (context-pc context) code))
(defun find-escaped-frame (frame-pointer)
(declare (type system-area-pointer frame-pointer))
(/noshow0 "entering FIND-ESCAPED-FRAME")
(dotimes (index *free-interrupt-context-index* (values nil 0 nil))
(let* ((context (nth-interrupt-context index))
(cfp (int-sap (context-register context sb-vm::cfp-offset))))
(/noshow0 "got CONTEXT")
#+(or x86 x86-64)
(unless (control-stack-pointer-valid-p cfp)
(return (values nil nil nil t)))
(when (sap= frame-pointer cfp)
(with-code-pages-pinned (:dynamic)
(return (escaped-frame-from-context context)))))))
#+(or x86 x86-64)
(defun escaped-frame-from-context (context)
(declare (type (sb-alien:alien (* os-context-t)) context))
(block nil
(let ((code (code-object-from-context context)))
(/noshow0 "got CODE")
(when (null code)
;; KLUDGE: Detect undefined functions by a range-check
;; against the trampoline address and the following
;; function in the runtime.
(return (values code 0 context)))
(multiple-value-bind
(pc-offset valid-p)
(context-code-pc-offset context code)
(unless valid-p
;; We were in an assembly routine. Therefore, use the
;; LRA as the pc.
;;
;; FIXME: Should this be WARN or ERROR or what?
(format t "** pc-offset ~S not in code obj ~S?~%"
pc-offset code))
(/noshow0 "returning from FIND-ESCAPED-FRAME")
(return
(values code pc-offset context))))))
#-(or x86 x86-64)
(defun escaped-frame-from-context (context)
(declare (type (sb-alien:alien (* os-context-t)) context))
(block nil
(let ((code (code-object-from-context context)))
(/noshow0 "got CODE")
(when (symbolp code)
(return (values code 0 context)))
(multiple-value-bind
(pc-offset valid-p code-size)
(context-code-pc-offset context code)
(unless valid-p
;; We were in an assembly routine.
(multiple-value-bind (new-pc-offset computed-return)
(find-pc-from-assembly-fun code context)
(setf pc-offset new-pc-offset)
(unless (<= 0 pc-offset code-size)
(cerror
"Set PC-OFFSET to zero and continue backtrace."
'bug
:format-control
"~@<PC-OFFSET (~D) not in code object. Frame details:~
~2I~:@_PC: #X~X~:@_CODE: ~S~:@_CODE FUN: ~S~:@_LRA: ~
#X~X~:@_COMPUTED RETURN: #X~X.~:>"
:format-arguments
(list pc-offset
(sap-int (context-pc context))
code
(%code-entry-point code 0)
#-(or arm arm64)
(context-register context sb-vm::lra-offset)
#+(or arm arm64)
(stack-ref (int-sap (context-register context
sb-vm::cfp-offset))
lra-save-offset)
computed-return))
;; We failed to pinpoint where PC is, but set
;; pc-offset to 0 to keep the backtrace from
;; exploding.
(setf pc-offset 0))))
(/noshow0 "returning from FIND-ESCAPED-FRAME")
(return
(if (eq (%code-debug-info code) :bpt-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 context)))))))
#-(or x86 x86-64)
(defun find-pc-from-assembly-fun (code scp)
"Finds the PC for the return from an assembly routine properly.
For some architectures (such as PPC) this will not be the $LRA
register."
(with-pinned-objects (code)
(let ((return-machine-address (sb-vm::return-machine-address scp))
(code-header-len (* (code-header-words code) sb-vm:n-word-bytes)))
(values (- return-machine-address
(- (get-lisp-obj-address code)
sb-vm:other-pointer-lowtag)
code-header-len)
return-machine-address))))
;;; Find the code object corresponding to the object represented by
;;; bits and return it. We assume bogus functions correspond to the
;;; undefined-function.
#+(or x86 x86-64 arm64)
(defun code-object-from-context (context)
(declare (type (sb-alien:alien (* os-context-t)) context))
(code-header-from-pc (context-pc context)))
#-(or x86 x86-64 arm64)
(defun code-object-from-context (context)
(declare (type (sb-alien:alien (* os-context-t)) context))
;; The GC constraint on the program counter on precisely-scavenged
;; backends is that it partakes of the interior-pointer nature.
;; Which means that it may be within the scope of an object other
;; than that pointed to by reg_CODE / $CODE. This is necessarily
;; the case during function call and return: whichever the outbound
;; function is has reg_CODE set up for itself, and the inbound
;; function cannot have reg_CODE set up until after the program
;; counter is within its body, otherwise a badly timed signal can
;; mess things up entirely. In practical terms, this means that we
;; need to do the same sort of pairing of interior pointers that the
;; GC does these days (see scavenge_interrupt_context() in
;; gc-common.c for details), but limiting to "things that can be
;; code objects". -- AB, 2018-Jan-11
;;
;; Oh, and as of this writing, AFAIK, the only precisely-scavenged
;; backends that are actually interrupt-safe around function calls
;; are PPC, ARM64, and probably ARM. PPC and ARM64 because they
;; have thread support, and GC load testing on PPC is how this
;; constraint was found in the first place. Probably ARM because I
;; wrote the bulk of the ARM backend well after I fixed function
;; calling on PPC and rewrote scavenge_interrupt_context() so that
;; things behaved reliably. -- AB, 2018-Jan-11
(flet ((normalize-candidate (object)
;; Unlike with the prior implementation, we cannot presume
;; that a FUNCTION is amenable to FUN-CODE-HEADER (it might
;; be a closure, and that is unlikely to be at all useful).
;; Fortunately, WIDETAG-OF comes up with sane values for
;; all object types, and we can pick off the SIMPLE-FUN
;; case easily enough.
(let ((widetag (widetag-of object)))
(cond ((= widetag code-header-widetag)
object)
((= widetag return-pc-widetag)
(lra-code-header object))
((= widetag simple-fun-widetag)
(or (fun-code-header object)
:undefined-function))
(t
nil)))))
(dolist (boxed-reg-offset sb-vm::boxed-regs
;; If we can't actually pair the PC then we presume that
;; we're in an assembly-routine and that reg_CODE is, in
;; fact, the right thing to use... And that it will do
;; no harm to return it here anyway even if it isn't.
(normalize-candidate
#+ppc64
(let ((code (context-register context sb-vm::code-offset)))
(%make-lisp-obj (if (logtest sb-vm:lowtag-mask code)
code
(logior code sb-vm:other-pointer-lowtag))))
#-ppc64
(boxed-context-register context sb-vm::code-offset)))
(let ((candidate
(normalize-candidate
(boxed-context-register context boxed-reg-offset))))
(when (and (not (symbolp candidate)) ;; NIL or :UNDEFINED-FUNCTION
(nth-value 1 (context-code-pc-offset context candidate)))
(return candidate))))))
;;;; frame utilities
(defun compiled-debug-fun-from-pc (debug-info pc &optional escaped)
(let* ((fun-map (sb-c::compiled-debug-info-fun-map debug-info)))
(if (sb-c::compiled-debug-fun-next fun-map)
(let* ((first-elsewhere-pc (sb-c::compiled-debug-fun-elsewhere-pc fun-map))
(elsewhere-p
(if escaped ;; See the comment below
(>= pc first-elsewhere-pc)
(> pc first-elsewhere-pc))))
(loop for fun = fun-map then next
for next = (sb-c::compiled-debug-fun-next fun)
when (or (not next)
(let ((next-pc (if elsewhere-p
(sb-c::compiled-debug-fun-elsewhere-pc next)
(sb-c::compiled-debug-fun-offset next))))
(if escaped
(< pc next-pc)
;; Non-escaped frame means that this frame calls something.
;; And the PC points to where something should return.
;; The return adress may be in the next
;; function, e.g. in local tail calls the
;; function will be entered just after the
;; CALL.
;; See debug.impure.lisp/:local-tail-call for a test-case
(<= pc next-pc))))
return fun))
fun-map)))
;;; This returns a COMPILED-DEBUG-FUN for COMPONENT and PC. We fetch the
;;; SB-C::DEBUG-INFO and run down its FUN-MAP to get a
;;; SB-C::COMPILED-DEBUG-FUN from the PC. The result only needs to
;;; reference the COMPONENT, for function constants, and the
;;; SB-C::COMPILED-DEBUG-FUN.
(defun debug-fun-from-pc (component pc &optional (escaped t))
(let ((info (%code-debug-info component)))
(etypecase info
(sb-c::compiled-debug-info
(make-compiled-debug-fun (compiled-debug-fun-from-pc info pc escaped) component))
(hash-table ; interrupted in an assembler routine
(let ((routine (dohash ((name pc-range) info)
(when (<= (car pc-range) pc (cadr pc-range))
(return name)))))
(make-bogus-debug-fun (cond ((not routine)
"no debug information for frame")
((memq routine '(sb-vm::undefined-tramp
sb-vm::undefined-alien-tramp))
"undefined function")
(routine)))))
(closure ; interrupted in an immobile code trampoline
(make-bogus-debug-fun "closure-calling trampoline"))
((eql :bpt-lra)
(make-bogus-debug-fun "function end breakpoint")))))
;;; 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-fun-p debug-fun)
escaped
(let ((data (breakpoint-data
(compiled-debug-fun-component debug-fun)
pc nil)))
(when (and data (breakpoint-data-breakpoints data))
(let ((what (breakpoint-what
(first (breakpoint-data-breakpoints data)))))
(when (compiled-code-location-p 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)
(let ((catch (descriptor-sap *current-catch-block*))
(reversed-result nil)
(fp (frame-pointer frame)))
(labels ((catch-ref (slot)
(sap-ref-lispobj catch (* slot n-word-bytes)))
#-(or x86 x86-64 arm64)
(catch-entry-offset ()
(let* ((lra (catch-ref catch-block-entry-pc-slot))
(component (catch-ref catch-block-code-slot))
#+ppc64
(component (%make-lisp-obj (logior (ash component n-fixnum-tag-bits)
other-pointer-lowtag))))
(* (- (1+ (get-header-data lra))
(code-header-words component))
n-word-bytes)))
#+(or x86 x86-64 arm64)
(catch-entry-offset ()
(let* ((ra (sap-ref-sap
catch (* catch-block-entry-pc-slot
n-word-bytes)))
(component (code-header-from-pc ra)))
(- (sap-int ra)
(- (get-lisp-obj-address component)
other-pointer-lowtag)
(* (code-header-words component)
n-word-bytes)))))
(declare (inline catch-ref catch-entry-offset))
(loop
until (zerop (sap-int catch))
finally (return (nreverse reversed-result))
do (when (sap= fp
(descriptor-sap
(catch-ref catch-block-cfp-slot)))
(push (cons (catch-ref catch-block-tag-slot)
(make-compiled-code-location
(catch-entry-offset) (frame-debug-fun frame)))
reversed-result))
(setf catch
(descriptor-sap
(catch-ref catch-block-previous-catch-slot)))))))
;;; Modify the value of the OLD-TAG catches in FRAME to NEW-TAG
(defun replace-frame-catch-tag (frame old-tag new-tag)
(let ((catch (descriptor-sap *current-catch-block*))
(fp (frame-pointer frame)))
(labels ((catch-ref (slot)
(sap-ref-lispobj catch (* slot n-word-bytes)))
((setf catch-ref) (value slot)
(setf (sap-ref-lispobj catch (* slot n-word-bytes))
value)))
(declare (inline catch-ref (setf catch-ref)))
(loop
until (zerop (sap-int catch))
do (when (sap= fp
(descriptor-sap
(catch-ref catch-block-cfp-slot)))
(let ((current-tag (catch-ref catch-block-tag-slot)))
(when (eq current-tag old-tag)
(setf (catch-ref catch-block-tag-slot) new-tag))))
do (setf catch
(descriptor-sap
(catch-ref catch-block-previous-catch-slot)))))))
;;;; 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 (sb-xc:gensym))
(i (gensym)))
`(let ((,blocks (debug-fun-debug-blocks ,debug-fun)))
(declare (simple-vector ,blocks))
(dotimes (,i (length ,blocks) ,result)
(let ((,block-var (svref ,blocks ,i)))
,@body)))))
;;; 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-vars ((var debug-fun &optional result) &body body)
(let ((vars (gensym))
(i (gensym)))
`(let ((,vars (debug-fun-debug-vars ,debug-fun)))
(if ,vars
(dotimes (,i (compact-vector-length ,vars) ,result)
(let ((,var (compact-vector-ref ,vars ,i)))
,@body))
,result))))
;;; Compute byte offset of FUNCTION into CODE-INSTRUCTIONS of its code,
;;; which is the byte offset from the base of its code
;;; minus the number of bytes in the boxed portion of its code header.
(defun function-start-pc-offset (function)
(let* ((fun (%fun-fun function))
(code (fun-code-header fun)))
(- (%fun-code-offset fun)
(* (code-header-words code) sb-vm:n-word-bytes))))
;;; 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-fun-%function debug-fun)
(etypecase debug-fun
(compiled-debug-fun
(let (result)
(loop with component = (compiled-debug-fun-component debug-fun)
with start-pc = (sb-c::compiled-debug-fun-start-pc
(compiled-debug-fun-compiler-debug-fun debug-fun))
for i below (code-n-entries component)
for entry = (%code-entry-point component i)
while (> start-pc (function-start-pc-offset entry))
do (setf result entry))
result))
(bogus-debug-fun nil)))
cached-value)))
;;; 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 &optional (pretty t))
(declare (type debug-fun debug-fun) (ignorable pretty))
(etypecase debug-fun
(compiled-debug-fun
(let ((name (sb-c::compiled-debug-fun-name
(compiled-debug-fun-compiler-debug-fun debug-fun))))
;; Frames named (.EVAL. special-operator) should show the operator name
;; in backtraces, but if the debugger needs to detect that the frame is
;; interpreted for other purposes, it can specify PRETTY = NIL.
(cond #+sb-fasteval
((and (typep name '(cons (eql sb-interpreter::.eval.)))
pretty)
(if (singleton-p (cdr name)) (cadr name) (cdr name)))
(t name))))
(bogus-debug-fun
(bogus-debug-fun-%name debug-fun))))
(defun interrupted-frame-error (frame)
(declare (special sb-kernel::*current-internal-error*))
(when (and (compiled-frame-p frame)
(compiled-frame-escaped frame)
sb-kernel::*current-internal-error*
(array-in-bounds-p sb-c:+backend-internal-errors+
sb-kernel::*current-internal-error*))
(cadr (svref sb-c:+backend-internal-errors+
sb-kernel::*current-internal-error*))))
(defun all-args-available-p (frame)
(let ((error (interrupted-frame-error frame))
(df (frame-debug-fun frame)))
(or (and (eq error 'invalid-arg-count-error)
(eq (debug-fun-kind df) :external))
(and (eq error 'undefined-fun-error)
(bogus-debug-fun-p df)))))
;; Return the name of the closure, if named, otherwise nil.
(defun debug-fun-closure-name (debug-fun frame)
(unless (typep debug-fun 'compiled-debug-fun)
(return-from debug-fun-closure-name nil))
(let ((compiler-debug-fun (compiled-debug-fun-compiler-debug-fun debug-fun)))
(acond
;; Frames named (.APPLY. something) are interpreted function applicators.
;; Show them as the name of the interpreted function being applied.
#+sb-fasteval
((let ((name (sb-c::compiled-debug-fun-name compiler-debug-fun)))
(when (typep name '(cons (eql sb-interpreter::.apply.)))
;; Find a variable named FUN.
(awhen (car (debug-fun-symbol-vars debug-fun 'sb-interpreter::fun))
(let ((val (debug-var-value it frame))) ; Ensure it's a function
(when (typep val 'interpreted-function)
(%fun-name val))))))) ; Get its name
((sb-c::compiled-debug-fun-closure-save compiler-debug-fun)
(%fun-name
(if (all-args-available-p frame)
(sub-access-debug-var-slot (frame-pointer frame)
sb-c:closure-sc
(compiled-frame-escaped frame))
(sub-access-debug-var-slot (frame-pointer frame) it)))))))
;;; Return a DEBUG-FUN that represents debug information for FUN.
(defun fun-debug-fun (fun)
(declare (type function fun))
(let ((simple-fun (%fun-fun fun)))
(let* ((name (%simple-fun-name simple-fun))
(component (fun-code-header simple-fun))
(res (loop for fmap-entry = (sb-c::compiled-debug-info-fun-map
(%code-debug-info component))
then next
for next = (sb-c::compiled-debug-fun-next fmap-entry)
;; Is NAME really the right thing to match on given how bogus
;; it might be? I would think PC range is better.
when (and (eq (sb-c::compiled-debug-fun-name fmap-entry) name)
(eq (sb-c::compiled-debug-fun-kind fmap-entry) nil))
return fmap-entry
while next)))
(if res
(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
;; instead of fun's debug-fun. The above code does this
;; more correctly, but it doesn't get or eliminate all
;; appropriate cases. It mostly works, and probably
;; works for all named functions anyway.
;; -- WHN 20000120
(debug-fun-from-pc component
(function-start-pc-offset simple-fun))))))
;;; Return the kind of the function, which is one of :OPTIONAL, :MORE
;;; :EXTERNAL, :TOPLEVEL, :CLEANUP, or NIL.
(defun debug-fun-kind (debug-fun)
;; FIXME: This "is one of" information should become part of the function
;; declamation, not just a doc string
(etypecase debug-fun
(compiled-debug-fun
(sb-c::compiled-debug-fun-kind
(compiled-debug-fun-compiler-debug-fun debug-fun)))
(bogus-debug-fun
nil)))
;;; 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-vars (debug-fun symbol)
(let ((vars (ambiguous-debug-vars debug-fun (symbol-name symbol)))
(package (and (sb-xc:symbol-package symbol)
(package-name (sb-xc:symbol-package symbol)))))
(delete-if (if (stringp package)
(lambda (var)
(let ((p (debug-var-package-name var)))
(or (not (stringp p))
(string/= p package))))
(lambda (var)
(stringp (debug-var-package-name var))))
vars)))
;;; 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-fun-debug-vars debug-fun))
(len (compact-vector-length variables))
(prefix-len (length name-prefix-string))
(pos (find-var name-prefix-string variables len))
(res nil))
(when pos
;; Find names from pos to variable's len that contain prefix.
(do ((i pos (1+ i)))
((= i len))
(let* ((var (compact-vector-ref variables i))
(name (debug-var-symbol-name var))
(name-len (length name)))
(declare (simple-string name))
(when (/= (or (string/= name-prefix-string name
:end1 prefix-len :end2 name-len)
prefix-len)
prefix-len)
(return))
(push var res)))
(nreverse res))))
;;; This returns a position in VARIABLES for one containing NAME as an
;;; initial substring. END is the length of VARIABLES if supplied.
(defun find-var (name variables &optional end)
(declare (simple-vector variables)
(simple-string name))
(let ((name-len (length name)))
(position name variables
:test (lambda (x y)
(let* ((y (debug-var-symbol-name y))
(y-len (length y)))
(declare (simple-string y))
(and (>= y-len name-len)
(string= x y :end1 name-len :end2 name-len))))
:end (or end (length variables)))))
;;; 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)))
;;; 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-fun-lambda-list debug-fun)
(setf (debug-fun-%lambda-list debug-fun) args)
(if argsp
args
(debug-signal 'lambda-list-unavailable
:debug-fun debug-fun))))
(lambda-list)
((bogus-debug-fun-p debug-fun)
nil)
((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)
(t
;; 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-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)
;; workaround type inference bogosity that made this file not recompilable.
;; debug-fun-debug-vars was getting derived as returning :unparsed which is not
;; a sequence which causes compilation of COERCE to warn.
(declare (notinline debug-fun-debug-vars))
(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-fun-debug-vars debug-fun) 'list)
t))
(t
(values (parse-compiled-debug-fun-lambda-list/args-available
(debug-fun-debug-vars debug-fun) args)
t)))))
;;; A compact "vector" is either the element itself or a vector
(defun compact-vector-ref (vector index)
(declare (index index))
(typecase vector
(simple-vector
(svref vector index))
(string
(aver (zerop index))
vector)
(vector
(aref vector index))
(t
(aver (zerop index))
vector)))
(defun compact-vector-length (vector)
(typecase vector
(string
1)
(vector
(length vector))
(t
1)))
(defun parse-compiled-debug-fun-lambda-list/args-available (vars args)
(let ((i 0)
(len (compact-vector-length args))
(optionalp nil)
(keyword nil)
(result '()))
(flet ((push-var (tag-and-info &optional var-count)
(push (if var-count
(append tag-and-info
(loop :repeat var-count :collect
(compiled-debug-fun-lambda-list-var
args (incf i) vars)))
tag-and-info)
result))
(var-or-deleted (index-or-deleted)
(if (eq index-or-deleted sb-c::debug-info-var-deleted)
:deleted
(compact-vector-ref vars index-or-deleted))))
(loop
:while (< i len)
:for ele = (compact-vector-ref args i) :do
(cond
((eq ele sb-c::debug-info-var-optional)
(setf optionalp t))
((eq ele sb-c::debug-info-var-rest)
(push-var '(:rest) 1))
;; The next two args are the &MORE arg context and
;; count.
((eq ele sb-c::debug-info-var-more)
(push-var '(:more) 2))
;; SUPPLIED-P var immediately following keyword or
;; optional. Stick the extra var in the result element
;; representing the keyword or optional, which is the
;; previous one.
((eq ele sb-c::debug-info-var-supplied-p)
(push-var (pop result) 1))
;; The keyword of a keyword parameter. Store it so the next
;; element can be used to form a (:keyword KEYWORD VALUE)
;; entry.
((typep ele 'symbol)
(setf keyword ele))
;; The previous element was the keyword of a keyword
;; parameter and is stored in KEYWORD. The current element
;; is the index of the value (or a deleted
;; marker). Construct and push the complete entry.
(keyword
(push-var (list :keyword keyword (var-or-deleted ele))))
;; We saw an optional marker, so the following non-symbols
;; are indexes (or deleted markers) indicating optional
;; variables.
(optionalp
(push-var (list :optional (var-or-deleted ele))))
;; Deleted required, optional or keyword argument.
((eq ele sb-c::debug-info-var-deleted)
(push-var :deleted))
;; Required arg at beginning of args array.
(t
(push-var (compact-vector-ref vars ele))))
(incf i)
:finally (return (nreverse result))))))
;;; This is used in COMPILED-DEBUG-FUN-LAMBDA-LIST.
(defun compiled-debug-fun-lambda-list-var (args i vars)
(let ((ele (compact-vector-ref args i)))
(cond ((typep ele 'index) (compact-vector-ref vars ele))
((eq ele sb-c::debug-info-var-deleted) :deleted)
(t (error "malformed arguments description")))))
(defun compiled-debug-fun-debug-info (debug-fun)
(%code-debug-info (compiled-debug-fun-component debug-fun)))
;;;; unpacking variable and basic block data
;;; The argument is a debug internals structure. This returns the
;;; 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)))
(when (eq blocks :unparsed)
(let* ((new (parse-debug-blocks debug-fun))
(old (cas (debug-fun-blocks debug-fun) :unparsed new)))
(setq blocks (if (eq old :unparsed) new old))))
(or blocks
(debug-signal 'no-debug-blocks :debug-fun debug-fun))))
;;; Return a SIMPLE-VECTOR of DEBUG-BLOCKs or NIL. NIL indicates there
;;; was no basic block information.
(defun parse-debug-blocks (debug-fun)
(etypecase debug-fun
(compiled-debug-fun
(let ((parsed (parse-compiled-debug-blocks debug-fun)))
(if (equalp parsed #())
(debug-signal 'no-debug-blocks :debug-fun debug-fun)
parsed)))
(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-fun)
(macrolet ((aref+ (a i) `(prog1 (aref ,a ,i) (incf ,i))))
(let* ((var-count (length (debug-fun-debug-vars debug-fun)))
(compiler-debug-fun (compiled-debug-fun-compiler-debug-fun
debug-fun))
(compressed-data
(or (sb-c::compiled-debug-fun-blocks compiler-debug-fun)
(return-from parse-compiled-debug-blocks nil)))
(blocks (sb-c::lz-decompress compressed-data))
;; 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))
(elsewhere-pc (sb-c::compiled-debug-fun-elsewhere-pc compiler-debug-fun))
elsewhere-p
(len (length blocks))
(i 0)
(last-pc 0)
result-blocks
(block (make-compiled-debug-block))
locations
prev-live
prev-form-number)
(flet ((new-block ()
(when locations
(setf (compiled-debug-block-code-locations block)
(coerce (nreverse (shiftf locations nil))
'simple-vector)
(compiled-debug-block-elsewhere-p block)
elsewhere-p)
(push block result-blocks)
(setf block (make-compiled-debug-block)))))
(loop
(when (>= i len)
(new-block)
(return))
(let* ((flags (aref+ blocks i))
(kind (svref sb-c::+compiled-code-location-kinds+
(ldb (byte 3 0) flags)))
(pc (+ last-pc
(sb-c:read-var-integerf blocks i)))
(equal-live (logtest sb-c::compiled-code-location-equal-live flags))
(form-number
(cond ((logtest sb-c::compiled-code-location-zero-form-number flags)
0)
((and equal-live
(logtest sb-c::compiled-code-location-live flags))
prev-form-number)
(t
(setf prev-form-number
(sb-c:read-var-integerf blocks i)))))
(live-set
(cond (equal-live
prev-live)
((logtest sb-c::compiled-code-location-live flags)
(setf prev-live
(sb-c:read-packed-bit-vector live-set-len blocks i)))
(t
(make-array (* live-set-len 8) :element-type 'bit))))
(step-info
(if (logtest sb-c::compiled-code-location-stepping flags)
(sb-c:read-var-string blocks i)
""))
(context
(and (logtest sb-c::compiled-code-location-context flags)
(compact-vector-ref (sb-c::compiled-debug-info-contexts
(%code-debug-info (compiled-debug-fun-component debug-fun)))
(sb-c:read-var-integerf blocks i)))))
(when (or (memq kind '(:block-start :non-local-entry))
(and (not elsewhere-p)
(> pc elsewhere-pc)
(setf elsewhere-p t)))
(new-block))
(push (make-known-code-location
pc debug-fun block
form-number live-set kind
step-info context)
locations)
(setf last-pc pc))))
(coerce (nreverse result-blocks) 'simple-vector))))
;;; 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-fun-debug-vars (debug-fun)
(let ((vars (debug-fun-%debug-vars debug-fun)))
(if (eq vars :unparsed)
(let* ((new (etypecase debug-fun
(compiled-debug-fun
(parse-compiled-debug-vars debug-fun))
(bogus-debug-fun nil)))
(old (cas (debug-fun-%debug-vars debug-fun) :unparsed new)))
(if (eq old :unparsed) new old))
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.
(defun assign-minimal-var-names (vars)
(declare (simple-vector vars))
(let* ((len (length vars))
(width (length (format nil "~W" (1- len)))))
(dotimes (i len)
(without-package-locks
(setf (compiled-debug-var-symbol (svref vars i))
(intern (format nil "ARG-~V,'0D" width i)
#.(find-package "SB-DEBUG")))))))
;;; Parse the packed representation of DEBUG-VARs from
;;; 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-fun)
(let* ((cdebug-fun (compiled-debug-fun-compiler-debug-fun
debug-fun))
(packed-vars (sb-c::compiled-debug-fun-vars cdebug-fun))
(length (if (vectorp packed-vars)
(length packed-vars)
1))
(args-minimal (eq (sb-c::compiled-debug-fun-arguments cdebug-fun)
:minimal)))
(when packed-vars
(do ((i 0)
(id 0)
prev-name
(buffer (make-array 0 :fill-pointer 0 :adjustable t)))
((>= i length)
(let ((result (coerce buffer 'simple-vector)))
(when args-minimal
(assign-minimal-var-names result))
result))
(flet ((geti () (prog1 (compact-vector-ref packed-vars i) (incf i))))
(let* ((flags (geti))
(minimal (logtest sb-c::compiled-debug-var-minimal-p flags))
(deleted (logtest sb-c::compiled-debug-var-deleted-p flags))
(more-context-p (logtest sb-c::compiled-debug-var-more-context-p flags))
(more-count-p (logtest sb-c::compiled-debug-var-more-count-p flags))
(indirect-p (logtest sb-c::compiled-debug-var-indirect-p flags))
(live (logtest sb-c::compiled-debug-var-environment-live
flags))
(save (logtest sb-c::compiled-debug-var-save-loc-p flags))
(symbol (cond ((or more-count-p
more-context-p
minimal)
nil)
((logtest sb-c::compiled-debug-var-same-name-p flags)
prev-name)
(t (geti))))
;; Keep the condition in sync with DUMP-1-VAR
(large-fixnums (>= (integer-length most-positive-fixnum) 62))
(sc+offset (if deleted 0
(if large-fixnums (ldb (byte 27 8) flags) (geti))))
(save-sc+offset (and save
(if large-fixnums (ldb (byte 27 35) flags) (geti))))
(indirect-sc+offset (and indirect-p
(geti))))
(aver (not (and args-minimal (not minimal))))
(cond ((and prev-name (string= prev-name symbol))
(incf id))
(t
(setf id 0
prev-name symbol)))
(vector-push-extend (make-compiled-debug-var
(if (stringp symbol) (make-symbol symbol) symbol)
id
live
sc+offset
save-sc+offset
indirect-sc+offset
(cond (more-context-p :more-context)
(more-count-p :more-count)))
buffer)))))))
;;;; 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.
;;; 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.
(defun code-location-unknown-p (basic-code-location)
(ecase (code-location-%unknown-p basic-code-location)
((t) t)
((nil) nil)
(:unsure
(setf (code-location-%unknown-p basic-code-location)
(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)
(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))
;; (There used to be more cases back before sbcl-0.7.0, when
;; we did special tricks to debug the IR1 interpreter.)
)
block)))
;;; Store and return BASIC-CODE-LOCATION's debug-block. We determines
;;; 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
;;; pc. If we get to the last block, then the code-location is either
;;; in the second to last block or the last block, and we have to be
;;; careful in determining this since the last block could be code at
;;; the end of the function. We have to check for the last block being
;;; 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-fun (code-location-debug-fun
basic-code-location))
(blocks (debug-fun-debug-blocks debug-fun))
(len (length blocks)))
(declare (simple-vector blocks))
(setf (code-location-%debug-block basic-code-location)
(if (= len 1)
(svref blocks 0)
(do ((i 1 (1+ i))
(end (1- len)))
((= i end)
(let ((last (svref blocks end)))
(cond
((debug-block-elsewhere-p last)
(if (< pc
(sb-c::compiled-debug-fun-elsewhere-pc
(compiled-debug-fun-compiler-debug-fun
debug-fun)))
(svref blocks (1- end))
last))
((< pc
(compiled-code-location-pc
(svref (compiled-debug-block-code-locations last)
0)))
(svref blocks (1- end)))
(t last))))
(declare (type index i end))
(when (< pc
(compiled-code-location-pc
(svref (compiled-debug-block-code-locations
(svref blocks i))
0)))
(return (svref blocks (1- i)))))))))
;;; Return the CODE-LOCATION's DEBUG-SOURCE.
(defun code-location-debug-source (code-location)
(let ((info (compiled-debug-fun-debug-info
(code-location-debug-fun code-location))))
(or (sb-c::debug-info-source info)
(debug-signal 'no-debug-blocks :debug-fun
(code-location-debug-fun code-location)))))
;;; Returns the number of top level forms before the one containing
;;; CODE-LOCATION as seen by the compiler in some compilation unit. (A
;;; compilation unit is not necessarily a single file, see the section
;;; on debug-sources.)
(defun code-location-toplevel-form-offset (code-location)
(let ((di (compiled-debug-fun-debug-info
(code-location-debug-fun code-location))))
(sb-c::compiled-debug-info-tlf-number di)))
;;; 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)
(when (code-location-unknown-p code-location)
(error 'unknown-code-location :code-location code-location))
(let ((form-num (code-location-%form-number code-location)))
(cond ((eq form-num :unparsed)
(etypecase code-location
(compiled-code-location
(unless (fill-in-code-location code-location)
;; This check should be unnecessary. We're missing
;; debug info the compiler should have dumped.
(bug "unknown code location"))
(code-location-%form-number 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)
(when (code-location-unknown-p code-location)
(error 'unknown-code-location :code-location code-location))
(etypecase code-location
(compiled-code-location
(let ((kind (compiled-code-location-kind code-location)))
(cond ((not (eq kind :unparsed)) kind)
((not (fill-in-code-location code-location))
;; This check should be unnecessary. We're missing
;; debug info the compiler should have dumped.
(bug "unknown code location"))
(t
(compiled-code-location-kind code-location)))))
;; (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.
(defun compiled-code-location-live-set (code-location)
(if (code-location-unknown-p code-location)
nil
(let ((live-set (compiled-code-location-%live-set code-location)))
(fill-in-code-location 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.
;;
;; FIXME: This error and comment happen over and over again.
;; Make them a shared function.
(bug "unknown code location"))
(compiled-code-location-%live-set code-location))
(t live-set)))))
(defun code-location-context (code-location)
(unless (code-location-unknown-p code-location)
(let ((context (compiled-code-location-context code-location)))
(cond ((eq context :unparsed)
(etypecase code-location
(compiled-code-location
(unless (fill-in-code-location code-location)
(bug "unknown code location"))
(compiled-code-location-context code-location))))
(t context)))))
(defun error-context (&optional (frame sb-debug:*stack-top-hint*))
(when frame
(code-location-context (frame-code-location frame))))
(defun decode-arithmetic-error-operands (context)
(let* ((alien-context (sb-alien:sap-alien context (* os-context-t)))
(fp (int-sap (context-register alien-context
sb-vm::cfp-offset)))
(sb-debug:*stack-top-hint* (find-interrupted-frame))
(error-context (error-context)))
(and error-context
(values (car error-context)
(loop for x in (cdr error-context)
collect (if (integerp x)
(sub-access-debug-var-slot
fp x alien-context)
x))))))
;;; true if OBJ1 and OBJ2 are the same place in the code
(defun code-location= (obj1 obj2)
(etypecase obj1
(compiled-code-location
(etypecase obj2
(compiled-code-location
(and (eq (code-location-debug-fun obj1)
(code-location-debug-fun obj2))
(sub-compiled-code-location= obj1 obj2)))
;; (There used to be more cases back before sbcl-0.7.0,,
;; when we did special tricks to debug the IR1
;; interpreter.)
))
;; (There used to be more cases back before sbcl-0.7.0,,
;; when we did special tricks to debug IR1-interpreted code.)
))
(defun sub-compiled-code-location= (obj1 obj2)
(= (compiled-code-location-pc obj1)
(compiled-code-location-pc obj2)))
;;; Fill in CODE-LOCATION's :UNPARSED slots, returning T or NIL
;;; depending on whether the code-location was known in its
;;; 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-fun (code-location-debug-fun code-location))
(blocks (debug-fun-debug-blocks debug-fun))
(found))
(declare (simple-vector blocks))
(dotimes (i (length blocks) nil)
(let* ((block (svref blocks i))
(locations (compiled-debug-block-code-locations block)))
(declare (simple-vector locations))
(dotimes (j (length locations))
(let ((loc (svref locations j)))
(when (sub-compiled-code-location= code-location loc)
(unless found
(setf found loc))
;; There may be multiple locations in multiple blocks at a given PC, prefer
;; the :internal-error ones.
(when (eq (compiled-code-location-kind loc) :internal-error)
(setf found loc)
(return)))))))
(when found
(setf (code-location-%debug-block code-location)
(code-location-%debug-block found))
(setf (code-location-%form-number code-location)
(code-location-%form-number found))
(setf (compiled-code-location-%live-set code-location)
(compiled-code-location-%live-set found))
(setf (compiled-code-location-kind code-location)
(compiled-code-location-kind found))
(setf (compiled-code-location-step-info code-location)
(compiled-code-location-step-info found))
(setf (compiled-code-location-context code-location)
(compiled-code-location-context found))
t)))
;;;; operations on DEBUG-BLOCKs
;;; 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)
(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) ,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-fun-name (debug-block)
(etypecase debug-block
(compiled-debug-block
(let ((code-locs (compiled-debug-block-code-locations debug-block)))
(declare (simple-vector code-locs))
(if (zerop (length code-locs))
"??? Can't get name of debug-block's function."
(debug-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))
;; (There used to be more cases back before sbcl-0.7.0, when we
;; did special tricks to debug the IR1 interpreter.)
))
;;;; operations on debug variables
(defun debug-var-symbol-name (debug-var)
(symbol-name (debug-var-symbol debug-var)))
;;; FIXME: Make sure that this isn't called anywhere that it wouldn't
;;; be acceptable to have NIL returned, or that it's only called on
;;; DEBUG-VARs whose symbols have non-NIL packages.
(defun debug-var-package-name (debug-var)
(package-name (sb-xc: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)
(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)
(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)
(let ((escaped (compiled-frame-escaped frame)))
(cond ((compiled-debug-var-indirect-sc+offset debug-var)
(sub-access-debug-var-slot
;; Indirect are accessed through a frame pointer of the parent.
(descriptor-sap
(sub-access-debug-var-slot
(frame-pointer frame)
(if escaped
(compiled-debug-var-sc+offset debug-var)
(or
(compiled-debug-var-save-sc+offset debug-var)
(compiled-debug-var-sc+offset debug-var)))
escaped))
(compiled-debug-var-indirect-sc+offset debug-var)
escaped))
(escaped
(sub-access-debug-var-slot
(frame-pointer frame)
(compiled-debug-var-sc+offset debug-var)
escaped))
(t
(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.
;;;
;;; (Such values can arise in registers on machines with conservative
;;; GC, and might also arise in debug variable locations when
;;; those variables are invalid.)
;;;
;;; NOTE for precisely GC'd platforms:
;;; this function is not GC-safe in the slightest when creating
;;; a pointer to an object in dynamic space. If a GC occurs between
;;; the start of the call to VALID-LISP-POINTER-P and the end of
;;; %MAKE-LISP-OBJ then the object could move before the boxed pointer
;;; is constructed. This can happen on CHENEYGC if an asynchronous
;;; interrupt occurs within the window. This can happen on GENCGC
;;; under the same circumstances, but is more likely due to all GENCGC
;;; platforms supporting threaded operation.
;;; On x86oids we are able to eliminate the vulnerable window
;;; by conservatively pinning an object (i.e. storing a bit pattern
;;; that would be the address of an object, assuming it is an object)
;;; whether or not there is actually an object to pin.
;;; To see the GC-safeness problem without WITH-PINNED-OBJECTS, consider
;;; the following sequence of events, and suppose for the sake of argument
;;; that tagged pointer #x104003 is valid at the moment of call.
;;; Assume 1 low zero bit in a fixnum, so the register contains #x208006.
;;; 1. move-to-word: arg-passing-reg <- #x104003 ; implicit pin
;;; /* at this point the fixnum whose representation is #x208006
;;; was spilled to stack prior to call, *and* the descriptor bits
;;; are also in a register. The fixnum pins nothing as it does not
;;; have Lisp pointer nature. The passing reg pins something */
;;; 2. call C : will return true, and assume that the arg-passing-reg
;;; gets clobbered. The return-reg contains 1 for true.
;;; 3. -- GC triggered by other thread
;;; transport the object that was #x104003 to somewhere new
;;; 4. now %MAKE-LISP-OBJ creates a bogus pointer.
;;; By preemptively using (WITH-PINNED-OBJECTS ((%MAKE-LISP-OBJ)))
;;; we ensure that the bit pattern #x104003 is on the stack for root scan.
;;; Unfortunately, WITH-PINNED-OBJECTS can not be used with precise GC
;;; because random trash is not allowed in a descriptor register.
;;; If we really wanted to make this safe for precise GC, we could use a
;;; new special binding, something like *PINNED-WORDS* which would be a list
;;; of INTEGERs, each of which, _if_ its bit pattern is that of an object
;;; descriptor, would pin the corresponding object. On the lisp side
;;; the cons cell in the list would hold the supplied VAL directly.
(defun make-lisp-obj (val &optional (errorp t))
(if (or
;; fixnum
(zerop (logand val sb-vm:fixnum-tag-mask))
;; immediate single float, 64-bit only
#+64-bit
(= (logand val #xff) sb-vm:single-float-widetag)
;; character
(and (zerop (logandc2 val #x1fffffff)) ; Top bits zero
(= (logand val #xff) sb-vm:character-widetag)) ; char tag
;; unbound marker
(= val sb-vm:unbound-marker-widetag))
(values (%make-lisp-obj val) t)
;; To mitigate the danger of GC running in between testing pointer
;; validity and returning the object, we must pin a potentially
;; non-object which is harmless on the conservative backends
;; but harmful on precise GC.
(macrolet ((possibly-pin (form)
#+(or x86 x86-64)
`(with-pinned-objects ((%make-lisp-obj val)) ,form)
#-(or x86 x86-64) form))
(let ((obj (if (and (typep val 'word) (is-lisp-pointer val))
(possibly-pin
(if (= (valid-lisp-pointer-p (int-sap val)) 0)
0
(%make-lisp-obj val)))
0)))
(cond ((not (eql obj 0)) (values obj t))
(errorp
(error "~S is not a valid argument to ~S"
val 'make-lisp-obj))
(t
(values (make-unprintable-object
(format nil "invalid object #x~X" val))
nil)))))))
(defun sub-access-debug-var-slot (fp sc+offset &optional escaped)
;; NOTE: The long-float support in here is obviously decayed. When
;; the x86oid and non-x86oid versions of this function were unified,
;; the behavior of long-floats was preserved, which only served to
;; highlight its brokenness.
(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-boxed-value ()
`(if escaped
(boxed-context-register
escaped
(sb-c:sc+offset-offset sc+offset))
: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)
;; x86oids have no separate number stack, so dummy it
;; up for them.
#+c-stack-is-control-stack
`(let ((,var fp))
,@body)
#-c-stack-is-control-stack
`(let ((,var (if escaped
(int-sap
(sb-vm:context-register escaped
sb-vm::nfp-offset))
(sap-ref-sap fp (* nfp-save-offset
sb-vm:n-word-bytes)))))
,@body))
(number-stack-offset (&optional (offset 0))
#+(or x86 x86-64)
`(+ (sb-vm::frame-byte-offset (sb-c:sc+offset-offset sc+offset))
,offset)
#-(or x86 x86-64)
`(+ (* (sb-c:sc+offset-offset sc+offset) sb-vm:n-word-bytes)
,offset)))
(ecase (sb-c:sc+offset-scn sc+offset)
((#.sb-vm:any-reg-sc-number
#.sb-vm:descriptor-reg-sc-number)
(escaped-boxed-value))
(#.sb-vm:character-reg-sc-number
(with-escaped-value (val)
(code-char val)))
(#.sb-vm:sap-reg-sc-number
(with-escaped-value (val)
(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))
#-(or x86 x86-64)
(#.sb-vm:non-descriptor-reg-sc-number
(error "Local non-descriptor register access?"))
#-(or x86 x86-64)
(#.sb-vm:interior-reg-sc-number
(error "Local interior register access?"))
#+sb-simd-pack
((#.sb-vm::sse-reg-sc-number #.sb-vm::int-sse-reg-sc-number)
(escaped-float-value simd-pack-int))
#+sb-simd-pack
((#.sb-vm::single-sse-reg-sc-number)
(escaped-float-value simd-pack-single))
#+sb-simd-pack
((#.sb-vm::double-sse-reg-sc-number)
(escaped-float-value simd-pack-double))
#+sb-simd-pack
((#.sb-vm::int-sse-stack-sc-number)
(with-nfp (nfp)
(%make-simd-pack-ub64
(sap-ref-64 nfp (number-stack-offset 0))
(sap-ref-64 nfp (number-stack-offset 8)))))
#+sb-simd-pack
((#.sb-vm::single-sse-stack-sc-number)
(with-nfp (nfp)
(%make-simd-pack-single
(sap-ref-single nfp (number-stack-offset 0))
(sap-ref-single nfp (number-stack-offset 4))
(sap-ref-single nfp (number-stack-offset 8))
(sap-ref-single nfp (number-stack-offset 12)))))
#+sb-simd-pack
((#.sb-vm::double-sse-stack-sc-number)
(with-nfp (nfp)
(%make-simd-pack-double
(sap-ref-double nfp (number-stack-offset 0))
(sap-ref-double nfp (number-stack-offset 8)))))
#+sb-simd-pack-256
((#.sb-vm::ymm-reg-sc-number #.sb-vm::int-avx2-reg-sc-number)
(escaped-float-value simd-pack-256-int))
#+sb-simd-pack-256
((#.sb-vm::single-avx2-reg-sc-number)
(escaped-float-value simd-pack-256-single))
#+sb-simd-pack-256
((#.sb-vm::double-avx2-reg-sc-number)
(escaped-float-value simd-pack-256-double))
#+sb-simd-pack-256
((#.sb-vm::int-avx2-stack-sc-number)
(with-nfp (nfp)
(%make-simd-pack-256-ub64
(sap-ref-64 nfp (number-stack-offset 0))
(sap-ref-64 nfp (number-stack-offset 8))
(sap-ref-64 nfp (number-stack-offset 16))
(sap-ref-64 nfp (number-stack-offset 24)))))
#+sb-simd-pack-256
((#.sb-vm::single-avx2-stack-sc-number)
(with-nfp (nfp)
(%make-simd-pack-256-single
(sap-ref-single nfp (number-stack-offset 0))
(sap-ref-single nfp (number-stack-offset 4))
(sap-ref-single nfp (number-stack-offset 8))
(sap-ref-single nfp (number-stack-offset 12))
(sap-ref-single nfp (number-stack-offset 16))
(sap-ref-single nfp (number-stack-offset 20))
(sap-ref-single nfp (number-stack-offset 24))
(sap-ref-single nfp (number-stack-offset 28)))))
#+sb-simd-pack-256
((#.sb-vm::double-avx2-stack-sc-number)
(with-nfp (nfp)
(%make-simd-pack-256-double
(sap-ref-double nfp (number-stack-offset 0))
(sap-ref-double nfp (number-stack-offset 8))
(sap-ref-double nfp (number-stack-offset 16))
(sap-ref-double nfp (number-stack-offset 24)))))
(#.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
(escaped-float-value complex-single-float))
(#.sb-vm:complex-double-reg-sc-number
(escaped-float-value complex-double-float))
#+long-float
(#.sb-vm:complex-long-reg-sc-number
(escaped-float-value sb-kernel::complex-long-float))
(#.sb-vm:single-stack-sc-number
(with-nfp (nfp)
(sap-ref-single nfp (number-stack-offset))))
(#.sb-vm:double-stack-sc-number
(with-nfp (nfp)
(sap-ref-double nfp (number-stack-offset))))
#+long-float
(#.sb-vm:long-stack-sc-number
(with-nfp (nfp)
(sap-ref-long nfp (number-stack-offset))))
(#.sb-vm:complex-single-stack-sc-number
(with-nfp (nfp)
(complex
(sap-ref-single nfp (number-stack-offset))
(sap-ref-single nfp (number-stack-offset 4)))))
(#.sb-vm:complex-double-stack-sc-number
(with-nfp (nfp)
(complex
(sap-ref-double nfp (number-stack-offset))
(sap-ref-double nfp (number-stack-offset 8)))))
#+long-float
(#.sb-vm:complex-long-stack-sc-number
(with-nfp (nfp)
(complex
(sap-ref-long nfp (number-stack-offset))
(sap-ref-long nfp
(number-stack-offset #+sparc 4
#+(or x86 x86-64) 3)))))
(#.sb-vm:control-stack-sc-number
(stack-ref fp (sb-c:sc+offset-offset sc+offset)))
(#.sb-vm:character-stack-sc-number
(with-nfp (nfp)
(code-char (sap-ref-word nfp (number-stack-offset)))))
(#.sb-vm:unsigned-stack-sc-number
(with-nfp (nfp)
(sap-ref-word nfp (number-stack-offset))))
(#.sb-vm:signed-stack-sc-number
(with-nfp (nfp)
(signed-sap-ref-word nfp (number-stack-offset))))
(#.sb-vm:sap-stack-sc-number
(with-nfp (nfp)
(sap-ref-sap nfp (number-stack-offset))))
(#.constant-sc-number
(if escaped
(let ((code (code-header-from-pc (sb-vm:context-pc escaped))))
(if code
(code-header-ref code (sb-c:sc+offset-offset sc+offset))
:invalid-code-object-at-pc))
:invalid-value-for-unescaped-register-storage))
(#.immediate-sc-number
(sb-c:sc+offset-offset sc+offset)))))
;;; 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.
(defun (setf debug-var-value) (new-value debug-var frame)
(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.
(defun set-compiled-debug-var-slot (debug-var frame value)
(let ((escaped (compiled-frame-escaped frame)))
(if escaped
(sub-set-debug-var-slot (frame-pointer frame)
(compiled-debug-var-sc+offset debug-var)
value escaped)
(sub-set-debug-var-slot
(frame-pointer frame)
(or (compiled-debug-var-save-sc+offset debug-var)
(compiled-debug-var-sc+offset debug-var))
value))))
(defun sub-set-debug-var-slot (fp sc+offset value &optional escaped)
;; Like sub-access-debug-var-slot, this is the unification of two
;; divergent copy-pasted functions. The astute reviewer will notice
;; that long-floats are messed up here as well, that x86oids
;; apparently don't support accessing float values that are in
;; registers, and that non-x86oids store the real part of a float
;; for both the real and imaginary parts of a complex on the stack
;; (but not in registers, oddly enough). Some research has
;; indicated that the different forms of THE used for validating the
;; type of complex float components between x86oid and non-x86oid
;; systems are only significant in the case of using a non-complex
;; number as input (as the non-x86oid case effectively converts
;; non-complex numbers to complex ones and the x86oid case will
;; error out). That said, the error message from entering a value
;; of the wrong type will be slightly easier to understand on x86oid
;; systems.
(macrolet ((set-escaped-value (val)
`(if escaped
(setf (sb-vm:context-register
escaped
(sb-c:sc+offset-offset sc+offset))
,val)
value))
(set-escaped-boxed-value (val)
`(if escaped
(setf (boxed-context-register
escaped
(sb-c:sc+offset-offset sc+offset))
,val)
value))
(set-escaped-float-value (format val)
`(if escaped
(setf (sb-vm:context-float-register
escaped
(sb-c:sc+offset-offset sc+offset)
',format)
,val)
value))
(with-nfp ((var) &body body)
;; x86oids have no separate number stack, so dummy it
;; up for them.
#+c-stack-is-control-stack
`(let ((,var fp))
,@body)
#-c-stack-is-control-stack
`(let ((,var (if escaped
(int-sap
(sb-vm:context-register escaped
sb-vm::nfp-offset))
(sap-ref-sap fp
(* nfp-save-offset
sb-vm:n-word-bytes)))))
,@body))
(number-stack-offset (&optional (offset 0))
#+(or x86 x86-64)
`(+ (sb-vm::frame-byte-offset (sb-c:sc+offset-offset sc+offset))
,offset)
#-(or x86 x86-64)
`(+ (* (sb-c:sc+offset-offset sc+offset) sb-vm:n-word-bytes)
,offset)))
(ecase (sb-c:sc+offset-scn sc+offset)
((#.sb-vm:any-reg-sc-number
#.sb-vm:descriptor-reg-sc-number)
(set-escaped-boxed-value value))
(#.sb-vm:character-reg-sc-number
(set-escaped-value (char-code value)))
(#.sb-vm:sap-reg-sc-number
(set-escaped-value (sap-int value)))
(#.sb-vm:signed-reg-sc-number
(set-escaped-value (logand value most-positive-word)))
(#.sb-vm:unsigned-reg-sc-number
(set-escaped-value value))
#-(or x86 x86-64)
(#.sb-vm:non-descriptor-reg-sc-number
(error "Local non-descriptor register access?"))
#-(or x86 x86-64)
(#.sb-vm:interior-reg-sc-number
(error "Local interior register access?"))
#+sb-simd-pack
((#.sb-vm::sse-reg-sc-number #.sb-vm::int-sse-reg-sc-number)
(set-escaped-float-value simd-pack-int value))
#+sb-simd-pack
((#.sb-vm::single-sse-reg-sc-number)
(set-escaped-float-value simd-pack-single value))
#+sb-simd-pack
((#.sb-vm::double-sse-reg-sc-number)
(set-escaped-float-value simd-pack-double value))
#+sb-simd-pack
((#.sb-vm::int-sse-stack-sc-number)
(multiple-value-bind (a b) (%simd-pack-ub64s value)
(with-nfp (nfp)
(setf (sap-ref-64 nfp (number-stack-offset 0)) a
(sap-ref-64 nfp (number-stack-offset 8)) b))))
#+sb-simd-pack
((#.sb-vm::single-sse-stack-sc-number)
(multiple-value-bind (a b c d) (%simd-pack-singles value)
(with-nfp (nfp)
(setf (sap-ref-single nfp (number-stack-offset 0)) a
(sap-ref-single nfp (number-stack-offset 4)) b
(sap-ref-single nfp (number-stack-offset 8)) c
(sap-ref-single nfp (number-stack-offset 12)) d))))
#+sb-simd-pack
((#.sb-vm::double-sse-stack-sc-number)
(multiple-value-bind (a b) (%simd-pack-doubles value)
(with-nfp (nfp)
(setf (sap-ref-double nfp (number-stack-offset 0)) a
(sap-ref-double nfp (number-stack-offset 8)) b))))
#+sb-simd-pack-256
((#.sb-vm::ymm-reg-sc-number #.sb-vm::int-avx2-reg-sc-number)
(set-escaped-float-value simd-pack-256-int value))
#+sb-simd-pack-256
((#.sb-vm::single-avx2-reg-sc-number)
(set-escaped-float-value simd-pack-256-single value))
#+sb-simd-pack-256
((#.sb-vm::double-avx2-reg-sc-number)
(set-escaped-float-value simd-pack-256-double value))
#+sb-simd-pack-256
((#.sb-vm::int-avx2-stack-sc-number)
(with-nfp (nfp)
(multiple-value-bind (a b c d) (%simd-pack-256-ub64s value)
(setf (sap-ref-64 nfp (number-stack-offset 0)) a
(sap-ref-64 nfp (number-stack-offset 8)) b
(sap-ref-64 nfp (number-stack-offset 16)) c
(sap-ref-64 nfp (number-stack-offset 24)) d))))
#+sb-simd-pack-256
((#.sb-vm::single-avx2-stack-sc-number)
(multiple-value-bind (a b c d e f g h) (%simd-pack-256-singles value)
(with-nfp (nfp)
(setf (sap-ref-single nfp (number-stack-offset 0)) a
(sap-ref-single nfp (number-stack-offset 4)) b
(sap-ref-single nfp (number-stack-offset 8)) c
(sap-ref-single nfp (number-stack-offset 12)) d
(sap-ref-single nfp (number-stack-offset 16)) e
(sap-ref-single nfp (number-stack-offset 20)) f
(sap-ref-single nfp (number-stack-offset 24)) g
(sap-ref-single nfp (number-stack-offset 28)) h))))
#+sb-simd-pack-256
((#.sb-vm::double-avx2-stack-sc-number)
(multiple-value-bind (a b c d) (%simd-pack-256-doubles value)
(with-nfp (nfp)
(setf (sap-ref-double nfp (number-stack-offset 0)) a
(sap-ref-double nfp (number-stack-offset 8)) b
(sap-ref-double nfp (number-stack-offset 16)) c
(sap-ref-double nfp (number-stack-offset 24)) d))))
(#.sb-vm:single-reg-sc-number
#-(or x86 x86-64) ;; don't have escaped floats.
(set-escaped-float-value single-float value))
(#.sb-vm:double-reg-sc-number
(set-escaped-float-value double-float value))
#+long-float
(#.sb-vm:long-reg-sc-number
(set-escaped-float-value long-float value))
(#.sb-vm:complex-single-reg-sc-number
(set-escaped-float-value complex-single-float value))
(#.sb-vm:complex-double-reg-sc-number
(set-escaped-float-value complex-double-float value))
#+long-float
(#.sb-vm:complex-long-reg-sc-number
(set-escaped-float-value complex-long-float))
(#.sb-vm:single-stack-sc-number
(with-nfp (nfp)
(setf (sap-ref-single nfp (number-stack-offset))
(the single-float value))))
(#.sb-vm:double-stack-sc-number
(with-nfp (nfp)
(setf (sap-ref-double nfp (number-stack-offset))
(the double-float value))))
#+long-float
(#.sb-vm:long-stack-sc-number
(with-nfp (nfp)
(setf (sap-ref-long nfp (number-stack-offset))
(the long-float value))))
(#.sb-vm:complex-single-stack-sc-number
(with-nfp (nfp)
(setf (sap-ref-single nfp (number-stack-offset))
#+(or x86 x86-64)
(realpart (the (complex single-float) value))
#-(or x86 x86-64)
(the single-float (realpart value)))
(setf (sap-ref-single nfp (number-stack-offset 4))
#+(or x86 x86-64)
(imagpart (the (complex single-float) value))
#-(or x86 x86-64)
(the single-float (realpart value)))))
(#.sb-vm:complex-double-stack-sc-number
(with-nfp (nfp)
(setf (sap-ref-double nfp (number-stack-offset))
#+(or x86 x86-64)
(realpart (the (complex double-float) value))
#-(or x86 x86-64)
(the double-float (realpart value)))
(setf (sap-ref-double nfp (number-stack-offset 8))
#+(or x86 x86-64)
(imagpart (the (complex double-float) value))
#-(or x86 x86-64)
(the double-float (realpart value)))))
#+long-float
(#.sb-vm:complex-long-stack-sc-number
(with-nfp (nfp)
(setf (sap-ref-long
nfp (number-stack-offset))
#+(or x86 x86-64)
(realpart (the (complex long-float) value))
#-(or x86 x86-64)
(the long-float (realpart value)))
(setf (sap-ref-long
nfp (number-stack-offset #+sparc 4
#+(or x86 x86-64) 3))
#+(or x86 x86-64)
(imagpart (the (complex long-float) value))
#-(or x86 x86-64)
(the long-float (realpart value)))))
(#.sb-vm:control-stack-sc-number
(%set-stack-ref fp (sb-c:sc+offset-offset sc+offset) value)
value) ; I doubt that the return value matters, but who knows ...
(#.sb-vm:character-stack-sc-number
(with-nfp (nfp)
(setf (sap-ref-word nfp (number-stack-offset 0))
(char-code (the character value)))))
(#.sb-vm:unsigned-stack-sc-number
(with-nfp (nfp)
(setf (sap-ref-word nfp (number-stack-offset 0)) (the word value))))
(#.sb-vm:signed-stack-sc-number
(with-nfp (nfp)
(setf (signed-sap-ref-word nfp (number-stack-offset))
(the signed-word value))))
(#.sb-vm:sap-stack-sc-number
(with-nfp (nfp)
(setf (sap-ref-sap nfp (number-stack-offset))
(the system-area-pointer value)))))))
;;; The method for setting and accessing COMPILED-DEBUG-VAR values use
;;; this to determine if the value stored is the actual value or an
;;; indirection cell.
(defun indirect-value-cell-p (x)
(and (%other-pointer-p x)
(eql (%other-pointer-widetag x) sb-vm:value-cell-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)
(compiled-debug-var-validity debug-var basic-code-location))
(defun debug-var-info (debug-var)
(compiled-debug-var-info debug-var))
;;; 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)
(declare (type compiled-code-location basic-code-location))
(cond ((debug-var-alive-p debug-var)
(let ((debug-fun (code-location-debug-fun basic-code-location)))
(if (>= (compiled-code-location-pc basic-code-location)
(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-fun-debug-vars
(code-location-debug-fun
basic-code-location)))))
(unless pos
(error 'unknown-debug-var
:debug-var debug-var
: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)
pos))
:invalid
:valid)))))
;;;; sources
;;; This code produces and uses what we call source-paths. A
;;; source-path is a list whose first element is a form number as
;;; returned by CODE-LOCATION-FORM-NUMBER and whose last element is a
;;; top level form number as returned by
;;; CODE-LOCATION-TOPLEVEL-FORM-NUMBER. The elements from the last to
;;; the first, exclusively, are the numbered subforms into which to
;;; descend. For example:
;;; (defun foo (x)
;;; (let ((a (aref x 3)))
;;; (cons a 3)))
;;; The call to AREF in this example is form number 5. Assuming this
;;; DEFUN is the 11'th top level form, the source-path for the AREF
;;; call is as follows:
;;; (5 1 0 1 3 11)
;;; Given the DEFUN, 3 gets you the LET, 1 gets you the bindings, 0
;;; gets the first binding, and 1 gets the AREF form.
;;; This returns a table mapping form numbers to source-paths. A
;;; source-path indicates a descent into the TOPLEVEL-FORM form,
;;; going directly to the subform corressponding to the form number.
;;;
;;; The vector elements are in the same format as the compiler's
;;; NODE-SOURCE-PATH; that is, the first element is the form number and
;;; the last is the TOPLEVEL-FORM number.
;;;
;;; This should be synchronized with SB-C::SUB-FIND-SOURCE-PATHS
(defun form-number-translations (form tlf-number)
(let ((seen nil)
(translations (make-array 12 :fill-pointer 0 :adjustable t)))
(labels ((translate1 (form path)
(unless (member form seen)
(push form seen)
(vector-push-extend (cons (fill-pointer translations) path)
translations)
(let ((pos 0)
(subform form)
(trail form))
(declare (fixnum pos))
(macrolet ((frob ()
'(progn
(when (atom subform) (return))
(let ((fm (car subform)))
(when (comma-p fm)
(setf fm (comma-expr fm)))
(cond ((consp fm)
(translate1 fm (cons pos path)))
((eq 'quote fm)
;; Don't look into quoted constants.
(return)))
(incf pos))
(setq subform (cdr subform))
(when (eq subform trail) (return)))))
(loop
(frob)
(frob)
(setq trail (cdr trail))))))))
(translate1 form (list tlf-number)))
(coerce translations 'simple-vector)))
;;; 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)
(declare (type unsigned-byte context))
;; Get to the form indicated by path or the enclosing form indicated
;; by context and path.
(let ((path (reverse (butlast (cdr path)))))
(dotimes (i (- (length path) context))
(let ((index (first path)))
(unless (and (listp form) (< index (length form)))
(error "Source path no longer exists."))
(setq form (elt form index))
(setq path (rest path))))
;; Recursively rebuild the source form resulting from the above
;; descent, copying the beginning of each subform up to the next
;; subform we descend into according to path. At the bottom of the
;; recursion, we return the form indicated by path preceded by our
;; marker, and this gets spliced into the resulting list structure
;; on the way back up.
(labels ((frob (form path level)
(if (or (zerop level) (null path))
(if (zerop context)
form
`(#:***here*** ,form))
(let ((n (first path)))
(unless (and (listp form) (< n (length form)))
(error "Source path no longer exists."))
(let ((res (frob (elt form n) (rest path) (1- level))))
(nconc (subseq form 0 n)
(cons res (nthcdr (1+ n) form))))))))
(frob form path context))))
;;; Given a code location, return the associated form-number
;;; translations and the actual top level form.
;;; Note that functions compiled to memory (via COMPILE or implicitly
;;; via LOAD if *EVALUATOR-MODE* = :COMPILE) do not save their source form
;;; in the DEBUG-SOURCE corresponding to their code-component. Instead the
;;; form hangs off the %SIMPLE-FUN-INFO slot, so that we can get an accurate
;;; depiction of the source form for any lambda no matter where from.
(defun get-toplevel-form (location)
(let ((d-source (code-location-debug-source location)))
(let* ((offset (code-location-toplevel-form-offset location))
(res
(cond ((and (core-debug-source-p d-source)
(core-debug-source-form d-source)))
((debug-source-namestring d-source)
(get-file-toplevel-form location))
(t (bug "Don't know how to use a DEBUG-SOURCE without ~
a namestring or a form.")))))
(values (form-number-translations res offset) res))))
;;; To suppress the read-time evaluation #. macro during source read,
;;; *READTABLE* is modified.
;;;
;;; FIXME: This breaks #+#.(cl:if ...) Maybe we need a SAFE-READ-EVAL, which
;;; this code can use for side- effect free #. calls?
;;;
;;; FIXME: This also knows nothing of custom readtables. The assumption
;;; is that the current readtable is a decent approximation for what
;;; we want, but that's lossy.
(defun safe-readtable ()
(let ((rt (copy-readtable)))
(set-dispatch-macro-character
#\# #\. (lambda (stream sub-char &rest rest)
(declare (ignore rest sub-char))
(let ((token (read stream t nil t)))
(format nil "#.~S" token)))
rt)
rt))
;;; Locate the source file (if it still exists) and grab the top level
;;; form. If the file is modified, we use the top level form offset
;;; instead of the recorded character offset.
(defun get-file-toplevel-form (location)
(let* ((d-source (code-location-debug-source location))
(di (compiled-debug-fun-debug-info
(code-location-debug-fun location)))
(tlf-offset (sb-c::compiled-debug-info-tlf-number di))
(char-offset (sb-c::compiled-debug-info-char-offset di))
(namestring (debug-source-namestring d-source)))
;; FIXME: External format?
(with-open-file (f namestring :if-does-not-exist nil)
(when f
(let ((*readtable* (safe-readtable)))
(cond ((eql (debug-source-created d-source) (file-write-date f))
(file-position f char-offset))
(t
(format *debug-io*
"~%; File has been modified since compilation:~%; ~A~@
; Using form offset instead of character position.~%"
namestring)
(let ((*read-suppress* t))
(loop repeat tlf-offset
do (read f)))))
(read f))))))
;;;; PREPROCESS-FOR-EVAL
;;; Return a function of one argument that evaluates form in the
;;; lexical context of the BASIC-CODE-LOCATION LOC, or signal a
;;; NO-DEBUG-VARS condition when the LOC's DEBUG-FUN has no
;;; DEBUG-VAR information available.
;;;
;;; The returned function takes the frame to get values from as its
;;; argument, and it returns the values of FORM. The returned function
;;; can signal the following conditions: INVALID-VALUE,
;;; AMBIGUOUS-VAR-NAME, and FRAME-FUN-MISMATCH.
(defun preprocess-for-eval (form loc)
(declare (type code-location loc))
(let ((n-frame (gensym))
(fun (code-location-debug-fun loc))
(more-context nil)
(more-count nil))
(unless (debug-var-info-available fun)
(debug-signal 'no-debug-vars :debug-fun fun))
(collect ((binds)
(specs))
(do-debug-fun-vars (var fun)
(let ((validity (debug-var-validity var loc)))
(unless (eq validity :invalid)
(case (debug-var-info var)
(:more-context
(setf more-context var))
(:more-count
(setf more-count var))
(t
(let* ((sym (debug-var-symbol var))
(found (assoc sym (binds))))
(cond ((not sym))
(found
(setf (second found) :ambiguous))
(t
(binds (list sym validity var))))))))))
(when (and more-context more-count)
(let ((more (assoc 'sb-debug::more (binds))))
(if more
(setf (second more) :ambiguous)
(binds (list 'sb-debug::more :more more-context more-count)))))
(dolist (bind (binds))
(let ((name (first bind))
(var (third bind)))
(unless (eq (info :variable :kind name) :special)
(ecase (second bind)
(:valid
(specs `(,name (debug-var-value ',var ,n-frame))))
(:more
(let ((count-var (fourth bind)))
(specs `(,name (multiple-value-list
(sb-c:%more-arg-values (debug-var-value ',var ,n-frame)
0
(debug-var-value ',count-var ,n-frame)))))))
(:unknown
(specs `(,name (debug-signal 'invalid-value
:debug-var ',var
:frame ,n-frame))))
(:ambiguous
(specs `(,name (debug-signal 'ambiguous-var-name
:name ',name
:frame ,n-frame))))))))
;; Process the symbol macros outside of the function to avoid
;; all those symbol-macrolets from showing in the sources if
;; there is a problem evaluating this form
(let ((res (let ((sb-c:*lexenv* (make-null-lexenv)))
(sb-c::funcall-in-symbol-macrolet-lexenv
(specs)
(lambda (&optional vars)
(declare (ignore vars))
(eval-in-lexenv `(lambda (,n-frame)
(declare (ignorable ,n-frame))
(progn ,form))
sb-c:*lexenv*))
:eval))))
(lambda (frame)
;; 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-FUN is the
;; same as LOC's.
(unless (code-location= (frame-code-location frame) loc)
(debug-signal 'frame-fun-mismatch
:code-location loc :form form :frame frame))
(funcall res frame))))))
;;; EVAL-IN-FRAME
(defun eval-in-frame (frame form)
(declare (type frame frame))
"Evaluate FORM in the lexical context of FRAME's current code location,
returning the results of the evaluation."
(funcall (preprocess-for-eval form (frame-code-location frame)) frame))
;;;; breakpoints
;;;; user-visible interface
;;; Create and return a breakpoint. When program execution encounters
;;; the breakpoint, the system calls HOOK-FUN. HOOK-FUN 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-FUN. 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-FUN 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-fun what
&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))
(aver (eq kind :code-location))
(let ((bpt (%make-breakpoint hook-fun what kind info)))
(etypecase what
(compiled-code-location
;; This slot is filled in due to calling CODE-LOCATION-UNKNOWN-P.
(when (eq (compiled-code-location-kind what) :unknown-return)
(let ((other-bpt (%make-breakpoint hook-fun what
:unknown-return-partner
info)))
(setf (breakpoint-unknown-return-partner bpt) other-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-fun
(ecase kind
(:fun-start
(%make-breakpoint hook-fun what kind info))
(:fun-end
(unless (eq (sb-c::compiled-debug-fun-returns
(compiled-debug-fun-compiler-debug-fun what))
:standard)
(error ":FUN-END breakpoints are currently unsupported ~
for the known return convention."))
(let* ((bpt (%make-breakpoint hook-fun what kind info))
(starter (compiled-debug-fun-end-starter what)))
(unless starter
(setf starter (%make-breakpoint #'list what :fun-start nil))
(setf (breakpoint-hook-fun 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) fun-end-cookie)
bpt))))))
;;; These are unique objects created upon entry into a function by a
;;; :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 (fun-end-cookie
(:print-object (lambda (obj str)
(print-unreadable-object (obj str :type t))))
(:constructor make-fun-end-cookie (bpt-lra debug-fun))
(:copier nil))
;; a pointer to the bpt-lra created for :FUN-END breakpoints
(bpt-lra nil :read-only t)
;; the DEBUG-FUN associated with this cookie
(debug-fun nil :read-only t))
;;; This maps bpt-lra objects to cookies, so that
;;; HANDLE-FUN-END-BREAKPOINT can find the appropriate cookie for the
;;; breakpoint hook.
;;; FIXME: assuming the preceding comment is correct, this seems an incredibly bad
;;; way to store the data. Why not just allocate an additional boxed slot in every
;;; bpt-lra object to store its cookies? Why use a hash table?
(define-load-time-global *fun-end-cookies*
(make-hash-table :test 'eq :synchronized t))
;;; This returns a hook function for the start helper breakpoint
;;; 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 fun-end-starter-hook (starter-bpt debug-fun)
(declare (type breakpoint starter-bpt)
(type compiled-debug-fun debug-fun))
(lambda (frame breakpoint)
(declare (ignore breakpoint)
(type frame frame))
(multiple-value-bind (lra component offset)
(make-bpt-lra (frame-saved-lra frame debug-fun))
(setf (frame-saved-lra frame debug-fun) lra)
(let ((end-bpts (breakpoint-%info starter-bpt)))
(let ((data (breakpoint-data component offset)))
(setf (breakpoint-data-breakpoints data) end-bpts)
(dolist (bpt end-bpts)
(setf (breakpoint-internal-data bpt) data)))
(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)))))))))
;;; 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-bpt-lra cookie)))
(do ((frame frame (frame-down frame)))
((not frame) nil)
(when (and (compiled-frame-p frame)
(#-(or x86 x86-64) eq #+(or x86 x86-64) sap=
lra
(frame-saved-lra frame (frame-debug-fun frame))))
(return t)))))
;;;; ACTIVATE-BREAKPOINT
;;; Cause the system to invoke the breakpoint's hook function until
;;; the next call to DEACTIVATE-BREAKPOINT or DELETE-BREAKPOINT. The
;;; system invokes breakpoint hook functions in the opposite order
;;; that you activate them.
(defun activate-breakpoint (breakpoint)
(when (eq (breakpoint-status breakpoint) :deleted)
(error "cannot activate a deleted breakpoint: ~S" breakpoint))
(unless (eq (breakpoint-status breakpoint) :active)
(ecase (breakpoint-kind breakpoint)
(:code-location
(let ((loc (breakpoint-what breakpoint)))
(etypecase loc
(compiled-code-location
(activate-compiled-code-location-breakpoint breakpoint)
(let ((other (breakpoint-unknown-return-partner breakpoint)))
(when other
(activate-compiled-code-location-breakpoint other))))
;; (There used to be more cases back before sbcl-0.7.0, when
;; we did special tricks to debug the IR1 interpreter.)
)))
(:fun-start
(etypecase (breakpoint-what breakpoint)
(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-fun
(let ((starter (breakpoint-start-helper breakpoint)))
(unless (eq (breakpoint-status starter) :active)
;; may already be active by some other :FUN-END breakpoint
(activate-compiled-fun-start-breakpoint starter)))
(setf (breakpoint-status breakpoint) :active))
;; (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 breakpoint breakpoint))
(let ((loc (breakpoint-what breakpoint)))
(declare (type compiled-code-location loc))
(sub-activate-breakpoint
breakpoint
(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)
(eq (compiled-code-location-kind loc)
:single-value-return))
sb-vm:single-value-return-byte-offset
0))))))
(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-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)
(declare (type breakpoint breakpoint)
(type breakpoint-data data))
(setf (breakpoint-status breakpoint) :active)
(without-interrupts
(unless (breakpoint-data-breakpoints data)
(let ((code (breakpoint-data-component data)))
(with-pinned-objects (code)
(setf (breakpoint-data-instruction data)
(breakpoint-install (get-lisp-obj-address code)
(breakpoint-data-offset data))))))
(setf (breakpoint-data-breakpoints data)
(append (breakpoint-data-breakpoints data) (list breakpoint)))
(setf (breakpoint-internal-data breakpoint) data)))
;;;; DEACTIVATE-BREAKPOINT
;;; Stop the system from invoking the breakpoint's hook function.
(defun deactivate-breakpoint (breakpoint)
(when (eq (breakpoint-status breakpoint) :active)
(without-interrupts
(let ((loc (breakpoint-what breakpoint)))
(etypecase loc
((or compiled-code-location compiled-debug-fun)
(deactivate-compiled-breakpoint breakpoint)
(let ((other (breakpoint-unknown-return-partner breakpoint)))
(when 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) :fun-end)
(let ((starter (breakpoint-start-helper breakpoint)))
(unless (find-if (lambda (bpt)
(and (not (eq bpt breakpoint))
(eq (breakpoint-status bpt) :active)))
(breakpoint-%info starter))
(deactivate-compiled-breakpoint starter)))
(let* ((data (breakpoint-internal-data breakpoint))
(bpts (delete breakpoint (breakpoint-data-breakpoints data))))
(setf (breakpoint-internal-data breakpoint) nil)
(setf (breakpoint-data-breakpoints data) bpts)
(unless bpts
(let ((code (breakpoint-data-component data)))
(with-pinned-objects (code)
(breakpoint-remove (get-lisp-obj-address code)
(breakpoint-data-offset data)
(breakpoint-data-instruction data))))
(delete-breakpoint-data data))))
(setf (breakpoint-status breakpoint) :inactive)
breakpoint)
;;;; BREAKPOINT-INFO
;;; Return the user-maintained info associated with breakpoint. This
;;; is SETF'able.
(defun breakpoint-info (breakpoint)
(breakpoint-%info breakpoint))
(defun (setf breakpoint-info) (value breakpoint)
(setf (breakpoint-%info breakpoint) value)
(let ((other (breakpoint-unknown-return-partner breakpoint)))
(when other
(setf (breakpoint-%info other) value)))
value)
;;;; BREAKPOINT-ACTIVE-P and DELETE-BREAKPOINT
(defun breakpoint-active-p (breakpoint)
(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)
(let ((status (breakpoint-status breakpoint)))
(unless (eq status :deleted)
(when (eq status :active)
(deactivate-breakpoint breakpoint))
(setf (breakpoint-status breakpoint) :deleted)
(let ((other (breakpoint-unknown-return-partner breakpoint)))
(when other
(setf (breakpoint-status other) :deleted)))
(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-fun-end-starter
(breakpoint-what breakpoint))
nil))))))
breakpoint)
;;;; C call out stubs
;;; This actually installs the break instruction in the component. It
;;; returns the overwritten bits. You must call this in a context in
;;; which GC is disabled, so that Lisp doesn't move objects around
;;; that C is pointing to.
(sb-alien:define-alien-routine "breakpoint_install" sb-alien:unsigned-int
(code-obj sb-alien:unsigned)
(pc-offset sb-alien:int))
;;; This removes the break instruction and replaces the original
;;; instruction. You must call this in a context in which GC is disabled
;;; so Lisp doesn't move objects around that C is pointing to.
(sb-alien:define-alien-routine "breakpoint_remove" sb-alien:void
(code-obj sb-alien:unsigned)
(pc-offset sb-alien:int)
(old-inst sb-alien:unsigned-int))
(sb-alien:define-alien-routine "breakpoint_do_displaced_inst" sb-alien:void
(scp (* os-context-t))
(orig-inst sb-alien:unsigned-int))
;;;; breakpoint handlers (layer between C and exported interface)
;;; This maps components to a mapping of offsets to BREAKPOINT-DATAs.
(define-load-time-global *component-breakpoint-offsets*
(make-hash-table :test 'eq :synchronized t))
;;; This returns the BREAKPOINT-DATA object associated with component cross
;;; offset. If none exists, this makes one, installs it, and returns it.
(defun breakpoint-data (component offset &optional (create t))
(aver component)
(flet ((install-breakpoint-data ()
;; Well, this has at least these three problems if not more:
;; 1. For the double-checked lock pattern to be correct we have to
;; re-check whether a key is in the table within the scope of the lock.
;; 2. The push should probably be a PUSHNEW, but even better, it too
;; needs to be locked or else dups can occur. Maybe use our newfangled
;; ordered lockfree linked lists.
;; 3. The hash-table should probably be weak keyed
(when create
(let ((data (make-breakpoint-data component offset)))
(push (cons offset data)
(gethash component *component-breakpoint-offsets*))
data))))
(let ((offsets (gethash component *component-breakpoint-offsets*)))
(if offsets
(let ((data (assoc offset offsets)))
(if data
(cdr data)
(install-breakpoint-data)))
(install-breakpoint-data)))))
;;; We use this when there are no longer any active breakpoints
;;; corresponding to DATA.
(defun delete-breakpoint-data (data)
;; Again, this looks brittle. Is there no danger of being interrupted
;; here?
(let* ((component (breakpoint-data-component data))
(offsets (delete (breakpoint-data-offset data)
(gethash component *component-breakpoint-offsets*)
:key #'car)))
(if offsets
(setf (gethash component *component-breakpoint-offsets*) offsets)
(remhash component *component-breakpoint-offsets*)))
(values))
;;; The C handler for interrupts calls this when it has a
;;; debugging-tool break instruction. This does *not* handle all
;;; breaks; for example, it does not handle breaks for internal
;;; errors.
(defun handle-breakpoint (offset component signal-context)
(let ((data (breakpoint-data component offset nil)))
(unless data
(error "unknown breakpoint in ~S at offset ~S"
(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)) :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. 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-FUN :FUN-START
;;; breakpoints.
(defun handle-breakpoint-aux (breakpoints data offset component signal-context)
(unless breakpoints
(bug "breakpoint that nobody wants"))
(unless (member data *executing-breakpoint-hooks*)
(let ((*executing-breakpoint-hooks* (cons data
*executing-breakpoint-hooks*)))
(invoke-breakpoint-hooks breakpoints signal-context)))
;; At this point breakpoints may not hold the same list as
;; BREAKPOINT-DATA-BREAKPOINTS since invoking hooks may have allowed
;; a breakpoint deactivation. In fact, if all breakpoints were
;; deactivated then data is invalid since it was deleted and so the
;; correct one must be looked up if it is to be used. If there are
;; no more breakpoints active at this location, then the normal
;; instruction has been put back, and we do not need to
;; DO-DISPLACED-INST.
(setf data (breakpoint-data component offset nil))
(when (and data (breakpoint-data-breakpoints data))
;; The breakpoint is still active, so we need to execute the
;; displaced instruction and leave the breakpoint instruction
;; behind. The best way to do this is different on each machine,
;; so we just leave it up to the C code.
(breakpoint-do-displaced-inst signal-context
(breakpoint-data-instruction data))
;; Some platforms have no usable sigreturn() call. If your
;; implementation of arch_do_displaced_inst() _does_ sigreturn(),
;; it's polite to warn here
#+(and sparc solaris)
(error "BREAKPOINT-DO-DISPLACED-INST returned?")))
(defun invoke-breakpoint-hooks (breakpoints signal-context)
(let* ((frame (signal-context-frame signal-context)))
(dolist (bpt breakpoints)
(funcall (breakpoint-hook-fun bpt)
frame
;; If this is an :UNKNOWN-RETURN-PARTNER, then pass the
;; hook function the original breakpoint, so that users
;; aren't forced to confront the fact that some
;; breakpoints really are two.
(if (eq (breakpoint-kind bpt) :unknown-return-partner)
(breakpoint-unknown-return-partner bpt)
bpt)))))
(defun signal-context-frame (signal-context)
(let* ((scp (sb-alien:sap-alien signal-context (* os-context-t)))
(cfp (int-sap (sb-vm:context-register scp sb-vm::cfp-offset))))
(compute-calling-frame cfp
;; KLUDGE: This argument is ignored on
;; x86oids in this scenario, but is
;; declared to be a SAP.
#+(or x86 x86-64) (sb-vm:context-pc scp)
#-(or x86 x86-64) nil
nil)))
(defun handle-fun-end-breakpoint (offset component context)
(let ((data (breakpoint-data component offset nil)))
(unless data
(error "unknown breakpoint in ~S at offset ~S"
(debug-fun-name (debug-fun-from-pc component offset))
offset))
(let ((breakpoints (breakpoint-data-breakpoints data)))
(when breakpoints
(aver (eq (breakpoint-kind (car breakpoints)) :fun-end))
(handle-fun-end-breakpoint-aux breakpoints data context)))))
;;; 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-fun-end-breakpoint-aux (breakpoints data signal-context)
;; FIXME: This looks brittle: what if we are interrupted somewhere
;; here? ...or do we have interrupts disabled here?
(delete-breakpoint-data data)
(let* ((scp (sb-alien:sap-alien signal-context (* os-context-t)))
(frame (signal-context-frame signal-context))
(component (breakpoint-data-component data))
(cookie (gethash component *fun-end-cookies*)))
(remhash component *fun-end-cookies*)
(dolist (bpt breakpoints)
(funcall (breakpoint-hook-fun bpt)
frame bpt
(get-fun-end-breakpoint-values scp)
cookie))))
(defun get-fun-end-breakpoint-values (scp)
(let ((ocfp (int-sap (sb-vm:context-register
scp
#-(or x86 x86-64) sb-vm::ocfp-offset
#+x86-64 sb-vm::rbx-offset
#+x86 sb-vm::ebx-offset)))
(nargs (boxed-context-register scp sb-vm::nargs-offset))
(reg-arg-offsets '#.sb-vm::*register-arg-offsets*)
(results nil))
(dotimes (arg-num nargs)
(push (if reg-arg-offsets
(boxed-context-register scp (pop reg-arg-offsets))
(stack-ref ocfp (+ arg-num
#+(or x86 x86-64) sb-vm::sp->fp-offset)))
results))
(nreverse results)))
;;;; MAKE-BPT-LRA (used for :FUN-END breakpoints)
;;; Make a breakpoint 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 new LRA object, the code component it is part of,
;;; and the PC offset for the trap instruction.
;;; Note: you can't cache these, because object identity confers a full dynamic
;;; state of the program, not merely a return PC location.
;;; (I tried changing this to DEFUN-CACHED, which failed a regression test)
(defun make-bpt-lra (real-lra)
(declare (type #-(or x86 x86-64 arm64) lra #+(or x86 x86-64 arm64) system-area-pointer real-lra))
real-lra
#+arm64 (error "Breakpoints do not work on ARM64")
#-arm64
(macrolet ((symbol-addr (name)
`(find-dynamic-foreign-symbol-address ,name))
(trap-offset ()
`(- (symbol-addr "fun_end_breakpoint_trap") src-start)))
;; These are really code labels, not variables: but this way we get
;; their addresses.
(let* ((src-start (symbol-addr "fun_end_breakpoint_guts"))
(length (the index (- (symbol-addr "fun_end_breakpoint_end")
src-start)))
(code-object
(sb-c:allocate-code-object
nil 0
;; For non-x86: a single boxed constant holds the true LRA.
;; For x86[-64]: one boxed constant holds the code object to which
;; to return, and one holds the displacement into that object.
;; Ensure required boxed header alignment.
(align-up (+ sb-vm:code-constants-offset 1 #+(or x86-64 x86) 1)
sb-c::code-boxed-words-align)
(+ length
sb-vm:n-word-bytes ; Jump Table prefix word
;; Alignment padding, LRA header
#-(or x86 x86-64) (* 2 sb-vm:n-word-bytes)
;; 2 extra raw bytes represent CODE-N-ENTRIES (which is zero)
2))))
(setf (%code-debug-info code-object) :bpt-lra)
(with-pinned-objects (code-object)
#+(or x86 x86-64 arm64)
(let ((instructions ; Don't touch the jump table prefix word
(sap+ (code-instructions code-object) sb-vm:n-word-bytes)))
(multiple-value-bind (offset code) (compute-lra-data-from-pc real-lra)
(setf (code-header-ref code-object real-lra-slot) code
(code-header-ref code-object (1+ real-lra-slot)) offset)
(system-area-ub8-copy (int-sap src-start) 0 instructions 0 length)
;; CODE-OBJECT is implicitly pinned after leaving WITH-PINNED-OBJECTS
;; (and would be pinned even if the W-P-O were deleted), so we're OK
;; to return a SAP to the instructions.
;; TRAP-OFFSET is the distance from CODE-INSTRUCTIONS to the trapping
;; opcode, for which we have to account for the jump table prefix word.
(values instructions code-object (+ (trap-offset) sb-vm:n-word-bytes))))
#-(or x86 x86-64 arm64)
(let* ((lra-header-addr
;; Skip over the jump table prefix, and align properly for LRA header
(sap+ (code-instructions code-object) (* 2 sb-vm:n-word-bytes)))
;; Compute the LRA->code backpointer in words
(delta (ash (sap- lra-header-addr
(int-sap (logandc2 (get-lisp-obj-address code-object)
sb-vm:lowtag-mask)))
(- sb-vm:word-shift))))
(setf (code-header-ref code-object real-lra-slot) real-lra)
(setf (sap-ref-word lra-header-addr 0)
(logior (ash delta sb-vm:n-widetag-bits) sb-vm:return-pc-widetag))
(system-area-ub8-copy (int-sap src-start) 0
(sap+ lra-header-addr sb-vm:n-word-bytes)
0 length)
(values (%make-lisp-obj (logior (sap-int lra-header-addr) sb-vm:other-pointer-lowtag))
(sb-vm:sanctify-for-execution code-object)
(+ (trap-offset) (* 3 sb-vm:n-word-bytes))))))))
;;;; miscellaneous
;;; This appears here because it cannot go with the DEBUG-FUN
;;; interface since DO-DEBUG-BLOCK-LOCATIONS isn't defined until after
;;; the DEBUG-FUN routines.
;;; Return a code-location before the body of a function and after all
;;; the arguments are in place; or if that location can't be
;;; determined due to a lack of debug information, return NIL.
(defun debug-fun-start-location (debug-fun)
(etypecase debug-fun
(compiled-debug-fun
(code-location-from-pc debug-fun
(sb-c::compiled-debug-fun-start-pc
(compiled-debug-fun-compiler-debug-fun
debug-fun))
nil))
;; (There used to be more cases back before sbcl-0.7.0, when
;; we did special tricks to debug the IR1 interpreter.)
))
;;;; Single-stepping
;;; The single-stepper works by inserting conditional trap instructions
;;; into the generated code (see src/compiler/*/call.lisp), currently:
;;;
;;; 1) Before the code generated for a function call that was
;;; translated to a VOP
;;; 2) Just before the call instruction for a full call
;;;
;;; In both cases, the trap will only be executed if stepping has been
;;; enabled, in which case it'll ultimately be handled by
;;; HANDLE-SINGLE-STEP-TRAP, which will either signal a stepping condition,
;;; or replace the function that's about to be called with a wrapper
;;; which will signal the condition.
(defun handle-single-step-trap (kind callee-register-offset)
(let ((context (nth-interrupt-context (1- *free-interrupt-context-index*))))
;; The following calls must get tail-call eliminated for
;; *STEP-FRAME* to get set correctly on non-x86.
(if (= kind single-step-before-trap)
(handle-single-step-before-trap context)
(handle-single-step-around-trap context callee-register-offset))))
(defvar *step-frame* nil)
(defun handle-single-step-before-trap (context)
(let ((step-info (single-step-info-from-context context)))
;; If there was not enough debug information available, there's no
;; sense in signaling the condition.
(when step-info
(let ((*step-frame*
(signal-context-frame (sb-alien:alien-sap context))))
(sb-impl::step-form step-info
;; We could theoretically store information in
;; the debug-info about to determine the
;; arguments here, but for now let's just pass
;; on it.
:unknown)))))
;;; This function will replace the fdefn / function that was in the
;;; register at CALLEE-REGISTER-OFFSET with a wrapper function. To
;;; ensure that the full call will use the wrapper instead of the
;;; original, conditional trap must be emitted before the fdefn /
;;; function is converted into a raw address.
(defun handle-single-step-around-trap (context callee-register-offset)
;; Fetch the function / fdefn we're about to call from the
;; appropriate register.
(let* ((callee
;; FIXME: this could handle static calls, but needs some
;; help from the backends
(make-lisp-obj
(cond #+immobile-space
((eql (sap-ref-8 (context-pc context) 0) #xB8) ; MOV EAX,imm
;; Construct a properly tagged FDEFN given the value
;; that machine code references it by for purposes
;; of the ensuing CALL instruction.
;; FIXME: this ought to go in {target}-vm.lisp as
;; something like GET-FDEFN-FOR-SINGLE-STEP
(+ (sap-ref-32 (context-pc context) 1) -2 other-pointer-lowtag))
(t
(context-register context callee-register-offset)))))
(step-info (single-step-info-from-context context)))
;; If there was not enough debug information available, there's no
;; sense in signaling the condition.
(unless step-info
(return-from handle-single-step-around-trap))
(let* ((fun (lambda (&rest args)
(flet ((call ()
(apply (typecase callee
(fdefn (fdefn-fun callee))
(function callee))
args)))
;; Signal a step condition
(let* ((step-in
(let ((*step-frame* (frame-down (top-frame))))
(sb-impl::step-form step-info args))))
;; And proceed based on its return value.
(if step-in
;; STEP-INTO was selected. Use *STEP-OUT* to
;; let the stepper know that selecting the
;; STEP-OUT restart is valid inside this
(let ((sb-impl::*step-out* :maybe))
;; Pass the return values of the call to
;; STEP-VALUES, which will signal a
;; condition with them in the VALUES slot.
(unwind-protect
(multiple-value-call #'sb-impl::step-values
step-info
(call))
;; If the user selected the STEP-OUT
;; restart during the call, resume
;; stepping
(when (eq sb-impl::*step-out* t)
(sb-impl::enable-stepping))))
;; STEP-NEXT / CONTINUE / OUT selected:
;; Disable the stepper for the duration of
;; the call.
(sb-impl::with-stepping-disabled
(call)))))))
(new-callee (etypecase callee
(fdefn
(let ((fdefn (make-fdefn (gensym))))
(setf (fdefn-fun fdefn) fun)
fdefn))
(function fun))))
;; And then store the wrapper in the same place.
(with-pinned-objects (new-callee)
;; %SET-CONTEXT-REGISTER is a function, so the address of
;; NEW-CALLEE gets converted to a fixnum before passing, which
;; won't keep NEW-CALLEE pinned down. Once it's inside
;; CONTEXT, which is registered in thread->interrupt_contexts,
;; it will properly point to NEW-CALLEE.
(cond
#+immobile-code
((fdefn-p callee) ; as above, should be in {target}-vm.lisp
;; Store into RAX the necessary value for issuing a CALL to the JMP
;; opcode in the FDEFN header.
(setf (context-register context callee-register-offset)
(sb-vm::fdefn-entry-address new-callee))
;; And skip over the MOV EAX, imm instruction.
(sb-vm::incf-context-pc context 5))
(t
(setf (context-register context callee-register-offset)
(get-lisp-obj-address new-callee))))))))
;;; Given a signal context, fetch the step-info that's been stored in
;;; the debug info at the trap point.
(defun single-step-info-from-context (context)
(multiple-value-bind (code pc-offset)
(escaped-frame-from-context context)
(let* ((debug-fun (debug-fun-from-pc code pc-offset))
(location (code-location-from-pc debug-fun
pc-offset
nil)))
(handler-case
(progn
(fill-in-code-location location)
(code-location-debug-source location)
(compiled-code-location-step-info location))
(debug-condition ()
nil)))))
;;; Return the frame that triggered a single-step condition. Used to
;;; provide a *STACK-TOP-HINT*.
(defun find-stepped-frame ()
(or *step-frame*
(top-frame)))
;;;; fetching errorful function name
;;; This flag is used to prevent infinite recursive lossage when
;;; we can't find the caller for some reason.
(defvar *finding-frame* nil)
(defun find-caller-frame ()
(unless *finding-frame*
(handler-case
(let* ((*finding-frame* t)
(frame (frame-down (frame-down (top-frame)))))
(flush-frames-above frame)
frame)
((or error debug-condition) ()))))
(defun find-interrupted-frame ()
(when (plusp *free-interrupt-context-index*)
(handler-case
(signal-context-frame
(sb-alien:alien-sap
(nth-interrupt-context (1- *free-interrupt-context-index*))))
((or error debug-condition) ()))))
(defun find-caller-of-named-frame (name)
(unless *finding-frame*
(handler-case
(let ((*finding-frame* t))
(do ((frame (top-frame) (frame-down frame)))
((null frame))
(when (and (compiled-frame-p frame)
(eq name (debug-fun-name
(frame-debug-fun frame))))
(let ((caller (frame-down frame)))
(flush-frames-above caller)
(return caller)))))
((or error debug-condition) ()))))