(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."
+ the debug information lacks details about returning ~
+ values here."
fun)))))
(define-condition no-debug-blocks (debug-condition)
(invalid-value-debug-var condition)
(invalid-value-frame condition)))))
-(define-condition ambiguous-variable-name (debug-condition)
- ((name :reader ambiguous-variable-name-name :initarg :name)
- (frame :reader ambiguous-variable-name-frame :initarg :frame))
+(define-condition ambiguous-var-name (debug-condition)
+ ((name :reader ambiguous-var-name-name :initarg :name)
+ (frame :reader ambiguous-var-name-frame :initarg :frame))
(:report (lambda (condition stream)
(format stream "~&~S names more than one valid variable in ~S."
- (ambiguous-variable-name-name condition)
- (ambiguous-variable-name-frame condition)))))
+ (ambiguous-var-name-name condition)
+ (ambiguous-var-name-frame condition)))))
\f
;;;; errors and DEBUG-SIGNAL
(defstruct (debug-var (:constructor nil)
(:copier nil))
;; the name of the variable
- (symbol (required-argument) :type symbol)
+ (symbol (missing-arg) :type symbol)
;; a unique integer identification relative to other variables with the same
;; symbol
- (id 0 :type sb!c::index)
+ (id 0 :type index)
;; Does the variable always have a valid value?
(alive-p nil :type boolean))
(def!method print-object ((debug-var debug-var) stream)
(print-unreadable-object (debug-var stream :type t :identity t)
(format stream
- "~S ~D"
+ "~S ~W"
(debug-var-symbol debug-var)
(debug-var-id debug-var))))
(symbol id alive-p sc-offset save-sc-offset))
(:copier nil))
;; storage class and offset (unexported)
- (sc-offset nil :type sb!c::sc-offset)
+ (sc-offset nil :type sb!c:sc-offset)
;; storage class and offset when saved somewhere
- (save-sc-offset nil :type (or sb!c::sc-offset null)))
+ (save-sc-offset nil :type (or sb!c:sc-offset null)))
;;;; frames
(compiler-debug-fun nil :type sb!c::compiled-debug-fun)
;; code object (unexported).
component
- ;; the :FUNCTION-START breakpoint (if any) used to facilitate
+ ;; the :FUN-START breakpoint (if any) used to facilitate
;; function end breakpoints
(end-starter nil :type (or null breakpoint)))
(defstruct (bogus-debug-fun
(:include debug-fun)
(:constructor make-bogus-debug-fun
- (%name &aux (%lambda-list nil) (%debug-vars nil)
- (blocks nil) (%function nil)))
+ (%name &aux
+ (%lambda-list nil)
+ (%debug-vars nil)
+ (blocks nil)
+ (%function nil)))
(:copier nil))
%name)
(elsewhere-p nil :type boolean))
(def!method print-object ((obj debug-block) str)
(print-unreadable-object (obj str :type t)
- (prin1 (debug-block-function-name obj) str)))
+ (prin1 (debug-block-fun-name obj) str)))
#!+sb-doc
(setf (fdocumentation 'debug-block-successors 'function)
;; This is the component in which the breakpoint lies.
component
;; This is the byte offset into the component.
- (offset nil :type sb!c::index)
+ (offset nil :type index)
;; The original instruction replaced by the breakpoint.
(instruction nil :type (or null (unsigned-byte 32)))
;; A list of user breakpoints at this location.
(breakpoint-data-offset obj))))
(defstruct (breakpoint (:constructor %make-breakpoint
- (hook-function what kind %info))
+ (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 :FUNCTION-END breakpoints
- ;; as values to return for the function containing the breakpoint.
- ;; :FUNCTION-END breakpoint hook-functions also take a cookie
- ;; argument. See COOKIE-FUN slot.
- (hook-function nil :type function)
+ ;; 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))
- ;; :CODE-LOCATION, :FUNCTION-START, or :FUNCTION-END for that kind
+ ;; :CODE-LOCATION, :FUN-START, or :FUN-END for that kind
;; of breakpoint. :UNKNOWN-RETURN-PARTNER if this is the partner of
;; a :code-location breakpoint at an :UNKNOWN-RETURN code-location.
- (kind nil :type (member :code-location :function-start :function-end
+ (kind nil :type (member :code-location :fun-start :fun-end
:unknown-return-partner))
;; Status helps the user and the implementation.
(status :inactive :type (member :active :inactive :deleted))
;; breakpoint for the other one, or NIL if this isn't at an
;; :UNKNOWN-RETURN code location.
(unknown-return-partner nil :type (or null breakpoint))
- ;; :FUNCTION-END breakpoints use a breakpoint at the :FUNCTION-START
+ ;; :FUN-END breakpoints use a breakpoint at the :FUN-START
;; to establish the end breakpoint upon function entry. We do this
;; by frobbing the LRA to jump to a special piece of code that
;; breaks and provides the return values for the returnee. This slot
;; and delete it.
(start-helper nil :type (or null breakpoint))
;; This is a hook users supply to get a dynamically unique cookie
- ;; for identifying :FUNCTION-END breakpoint executions. That is, if
- ;; there is one :FUNCTION-END breakpoint, but there may be multiple
+ ;; for identifying :FUN-END breakpoint executions. That is, if
+ ;; there is one :FUN-END breakpoint, but there may be multiple
;; pending calls of its function on the stack. This function takes
- ;; the cookie, and the hook-function takes the cookie too.
+ ;; 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)
;; the DEBUG-FUN containing this CODE-LOCATION
(debug-fun nil :type debug-fun)
;; This is initially :UNSURE. Upon first trying to access an
- ;; :unparsed slot, if the data is unavailable, then this becomes t,
+ ;; :UNPARSED slot, if the data is unavailable, then this becomes T,
;; and the code-location is unknown. If the data is available, this
- ;; becomes nil, a known location. We can't use a separate type
+ ;; becomes NIL, a known location. We can't use a separate type
;; code-location for this since we must return code-locations before
;; we can tell whether they're known or unknown. For example, when
;; parsing the stack, we don't want to unpack all the variables and
;; out and just find it in the blocks cache in DEBUG-FUN.
(%debug-block :unparsed :type (or debug-block (member :unparsed)))
;; This is the number of forms processed by the compiler or loader
- ;; before the top-level form containing this code-location.
- (%tlf-offset :unparsed :type (or sb!c::index (member :unparsed)))
+ ;; before the top level form containing this code-location.
+ (%tlf-offset :unparsed :type (or index (member :unparsed)))
;; This is the depth-first number of the node that begins
- ;; code-location within its top-level form.
- (%form-number :unparsed :type (or sb!c::index (member :unparsed))))
+ ;; code-location within its top level form.
+ (%form-number :unparsed :type (or index (member :unparsed))))
(def!method print-object ((obj code-location) str)
(print-unreadable-object (obj str :type t)
(prin1 (debug-fun-name (code-location-debug-fun obj))
(:constructor make-compiled-code-location (pc debug-fun))
(:copier nil))
;; an index into DEBUG-FUN's component slot
- (pc nil :type sb!c::index)
+ (pc nil :type index)
;; a bit-vector indexed by a variable's position in
;; DEBUG-FUN-DEBUG-VARS indicating whether the variable has a
;; valid value at this code-location. (unexported).
\f
;;;; DEBUG-SOURCEs
-;;; Return the number of top-level forms processed by the compiler
+;;; Return the number of top level forms processed by the compiler
;;; before compiling this source. If this source is uncompiled, this
;;; is zero. This may be zero even if the source is compiled since the
;;; first form in the first file compiled in one compilation, for
;;; example, must have a root number of zero -- the compiler saw no
-;;; other top-level forms before it.
+;;; other top level forms before it.
(defun debug-source-root-number (debug-source)
(sb!c::debug-source-source-root debug-source))
\f
;;;; frames
;;; This is used in FIND-ESCAPED-FRAME and with the bogus components
-;;; and LRAs used for :function-end breakpoints. When a components
-;;; debug-info slot is :bogus-lra, then the real-lra-slot contains the
+;;; and LRAs used for :FUN-END breakpoints. When a component's
+;;; debug-info slot is :BOGUS-LRA, then the REAL-LRA-SLOT contains the
;;; real component to continue executing, as opposed to the bogus
;;; component which appeared in some frame's LRA location.
(defconstant real-lra-slot sb!vm:code-constants-offset)
(defun current-fp () (current-fp))
(defun stack-ref (s n) (stack-ref s n))
(defun %set-stack-ref (s n value) (%set-stack-ref s n value))
-(defun function-code-header (fun) (function-code-header fun))
+(defun fun-code-header (fun) (fun-code-header fun))
(defun lra-code-header (lra) (lra-code-header lra))
(defun make-lisp-obj (value) (make-lisp-obj value))
(defun get-lisp-obj-address (thing) (get-lisp-obj-address thing))
-(defun function-word-offset (fun) (function-word-offset fun))
+(defun fun-word-offset (fun) (fun-word-offset fun))
-#!-sb-fluid (declaim (inline cstack-pointer-valid-p))
-(defun cstack-pointer-valid-p (x)
+#!-sb-fluid (declaim (inline control-stack-pointer-valid-p))
+(defun control-stack-pointer-valid-p (x)
(declare (type system-area-pointer x))
- #!-x86 ; stack grows toward high address values
- (and (sap< x (current-sp))
- (sap<= (int-sap control-stack-start)
- x)
- (zerop (logand (sap-int x) #b11)))
- #!+x86 ; stack grows toward low address values
- (and (sap>= x (current-sp))
- (sap> (int-sap control-stack-end) x)
- (zerop (logand (sap-int x) #b11))))
-
-#!+x86
-(sb!alien:def-alien-routine component-ptr-from-pc (system-area-pointer)
+ (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)
+ (zerop (logand (sap-int x) #b11)))
+ #!+stack-grows-downward-not-upward
+ (and (sap>= x (current-sp))
+ (sap> control-stack-end x)
+ (zerop (logand (sap-int x) #b11)))))
+
+(sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer)
(pc system-area-pointer))
-#!+x86
(defun component-from-component-ptr (component-ptr)
(declare (type system-area-pointer component-ptr))
(make-lisp-obj (logior (sap-int component-ptr)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
;;;; X86 support
(let ((component-ptr (component-ptr-from-pc pc)))
(unless (sap= component-ptr (int-sap #x0))
(let* ((code (component-from-component-ptr component-ptr))
- (code-header-len (* (get-header-data code) sb!vm:word-bytes))
+ (code-header-len (* (get-header-data code) sb!vm:n-word-bytes))
(pc-offset (- (sap-int pc)
(- (get-lisp-obj-address code)
- sb!vm:other-pointer-type)
+ sb!vm:other-pointer-lowtag)
code-header-len)))
; (format t "c-lra-fpc ~A ~A ~A~%" pc code pc-offset)
(values pc-offset code)))))
(defun ra-pointer-valid-p (ra)
(declare (type system-area-pointer ra))
(and
- ;; Not the first page which is unmapped.
+ ;; 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 (cstack-pointer-valid-p ra))))
+ ;; 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
(fixnum depth))
;;(format t "*CC ~S ~S~%" fp depth)
(cond
- ((not (cstack-pointer-valid-p fp))
+ ((not (control-stack-pointer-valid-p fp))
#+nil (format t "debug invalid fp ~S~%" fp)
nil)
(t
;; Check the two possible frame pointers.
- (let ((lisp-ocfp (sap-ref-sap fp (- (* (1+ sb!vm::ocfp-save-offset) 4))))
- (lisp-ra (sap-ref-sap fp (- (* (1+ sb!vm::return-pc-save-offset)
+ (let ((lisp-ocfp (sap-ref-sap fp (- (* (1+ ocfp-save-offset) 4))))
+ (lisp-ra (sap-ref-sap fp (- (* (1+ return-pc-save-offset)
4))))
- (c-ocfp (sap-ref-sap fp (* 0 sb!vm:word-bytes)))
- (c-ra (sap-ref-sap fp (* 1 sb!vm:word-bytes))))
- (cond ((and (sap> lisp-ocfp fp) (cstack-pointer-valid-p lisp-ocfp)
+ (c-ocfp (sap-ref-sap fp (* 0 sb!vm:n-word-bytes)))
+ (c-ra (sap-ref-sap fp (* 1 sb!vm:n-word-bytes))))
+ (cond ((and (sap> lisp-ocfp fp) (control-stack-pointer-valid-p lisp-ocfp)
(ra-pointer-valid-p lisp-ra)
- (sap> c-ocfp fp) (cstack-pointer-valid-p c-ocfp)
+ (sap> c-ocfp fp) (control-stack-pointer-valid-p c-ocfp)
(ra-pointer-valid-p c-ra))
#+nil (format t
"*C Both valid ~S ~S ~S ~S~%"
(format t
"debug: both still valid ~S ~S ~S ~S~%"
lisp-ocfp lisp-ra c-ocfp c-ra))
- #+freebsd
+ #!+freebsd
(if (sap> lisp-ocfp c-ocfp)
(values lisp-ra lisp-ocfp)
(values c-ra c-ocfp))
- #-freebsd
+ #!-freebsd
(values lisp-ra lisp-ocfp))
(lisp-path-fp
;; The lisp convention is looking good.
#+nil (format t "debug: no valid2 fp found ~S ~S~%"
lisp-ocfp c-ocfp)
nil))))
- ((and (sap> lisp-ocfp fp) (cstack-pointer-valid-p lisp-ocfp)
+ ((and (sap> lisp-ocfp fp) (control-stack-pointer-valid-p lisp-ocfp)
(ra-pointer-valid-p lisp-ra))
;; The lisp convention is looking good.
#+nil (format t "*C lisp-ocfp ~S ~S~%" lisp-ocfp lisp-ra)
(values lisp-ra lisp-ocfp))
- ((and (sap> c-ocfp fp) (cstack-pointer-valid-p c-ocfp)
+ ((and (sap> c-ocfp fp) (control-stack-pointer-valid-p c-ocfp)
#!-linux (ra-pointer-valid-p c-ra))
;; The C convention is looking good.
#+nil (format t "*C c-ocfp ~S ~S~%" c-ocfp c-ra)
;;; Return the top frame of the control stack as it was before calling
;;; this function.
(defun top-frame ()
- (/show0 "entering TOP-FRAME")
+ (/noshow0 "entering TOP-FRAME")
(multiple-value-bind (fp pc) (%caller-frame-and-pc)
(compute-calling-frame (descriptor-sap fp) pc nil)))
;;; Return the frame immediately below FRAME on the stack; or when
;;; FRAME is the bottom of the stack, return NIL.
(defun frame-down (frame)
- (/show0 "entering FRAME-DOWN")
+ (/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)))
- (/show0 "in DOWN :UNPARSED case")
+ (/noshow0 "in DOWN :UNPARSED case")
(setf (frame-%down frame)
(etypecase debug-fun
(compiled-debug-fun
(compute-calling-frame
(descriptor-sap
(get-context-value
- frame sb!vm::ocfp-save-offset
+ frame ocfp-save-offset
(sb!c::compiled-debug-fun-old-fp c-d-f)))
(get-context-value
- frame sb!vm::lra-save-offset
+ frame lra-save-offset
(sb!c::compiled-debug-fun-return-pc c-d-f))
frame)))
(bogus-debug-fun
(let ((fp (frame-pointer frame)))
- (when (cstack-pointer-valid-p fp)
+ (when (control-stack-pointer-valid-p fp)
#!+x86
(multiple-value-bind (ra ofp) (x86-call-context fp)
- (compute-calling-frame ofp ra frame))
+ (and ra (compute-calling-frame ofp ra frame)))
#!-x86
(compute-calling-frame
#!-alpha
- (sap-ref-sap fp (* sb!vm::ocfp-save-offset
- sb!vm:word-bytes))
+ (sap-ref-sap fp (* ocfp-save-offset
+ sb!vm:n-word-bytes))
#!+alpha
(int-sap
- (sap-ref-32 fp (* sb!vm::ocfp-save-offset
- sb!vm:word-bytes)))
+ (sap-ref-32 fp (* ocfp-save-offset
+ sb!vm:n-word-bytes)))
- (stack-ref fp sb!vm::lra-save-offset)
+ (stack-ref fp lra-save-offset)
frame)))))))
down)))
#!-x86
(defun get-context-value (frame stack-slot loc)
(declare (type compiled-frame frame) (type unsigned-byte stack-slot)
- (type sb!c::sc-offset loc))
+ (type sb!c:sc-offset loc))
(let ((pointer (frame-pointer frame))
(escaped (compiled-frame-escaped frame)))
(if escaped
#!+x86
(defun get-context-value (frame stack-slot loc)
(declare (type compiled-frame frame) (type unsigned-byte stack-slot)
- (type sb!c::sc-offset loc))
+ (type sb!c:sc-offset loc))
(let ((pointer (frame-pointer frame))
(escaped (compiled-frame-escaped frame)))
(if escaped
(sub-access-debug-var-slot pointer loc escaped)
(ecase stack-slot
- (#.sb!vm::ocfp-save-offset
+ (#.ocfp-save-offset
(stack-ref pointer stack-slot))
- (#.sb!vm::lra-save-offset
+ (#.lra-save-offset
(sap-ref-sap pointer (- (* (1+ stack-slot) 4))))))))
#!-x86
(defun (setf get-context-value) (value frame stack-slot loc)
(declare (type compiled-frame frame) (type unsigned-byte stack-slot)
- (type sb!c::sc-offset loc))
+ (type sb!c:sc-offset loc))
(let ((pointer (frame-pointer frame))
(escaped (compiled-frame-escaped frame)))
(if escaped
#!+x86
(defun (setf get-context-value) (value frame stack-slot loc)
(declare (type compiled-frame frame) (type unsigned-byte stack-slot)
- (type sb!c::sc-offset loc))
+ (type sb!c:sc-offset loc))
(let ((pointer (frame-pointer frame))
(escaped (compiled-frame-escaped frame)))
(if escaped
(sub-set-debug-var-slot pointer loc value escaped)
(ecase stack-slot
- (#.sb!vm::ocfp-save-offset
+ (#.ocfp-save-offset
(setf (stack-ref pointer stack-slot) value))
- (#.sb!vm::lra-save-offset
+ (#.lra-save-offset
(setf (sap-ref-sap pointer (- (* (1+ stack-slot) 4))) value))))))
+(defun foreign-function-backtrace-name (sap)
+ (let ((name (foreign-symbol-in-address 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 nil when
+;;; down frame, this returns NIL for the bottom of the stack. UP-FRAME
+;;; is the up link for the resulting frame object, and it is null when
;;; we call this to get the top of the stack.
;;;
;;; The current frame contains the pointer to the temporally previous
#!-x86
(defun compute-calling-frame (caller lra up-frame)
(declare (type system-area-pointer caller))
- (when (cstack-pointer-valid-p caller)
+ (when (control-stack-pointer-valid-p caller)
(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
- (stack-ref fp (1+ sb!vm::lra-save-offset))))
+ (stack-ref fp (1+ lra-save-offset))))
(values (get-header-data lra)
(lra-code-header lra)))
(if code
(values code
(* (1+ (- word-offset (get-header-data code)))
- sb!vm:word-bytes)
+ sb!vm:n-word-bytes)
nil)
(values :foreign-function
0
"undefined function"))
(:foreign-function
(make-bogus-debug-fun
- "foreign function call land"))
+ (foreign-function-backtrace-name
+ (int-sap (get-lisp-obj-address lra)))))
((nil)
(make-bogus-debug-fun
"bogus stack frame"))
escaped)
(if up-frame (1+ (frame-number up-frame)) 0)
escaped))))))
-
#!+x86
(defun compute-calling-frame (caller ra up-frame)
(declare (type system-area-pointer caller ra))
- (/show0 "entering COMPUTE-CALLING-FRAME")
- (when (cstack-pointer-valid-p caller)
- (/show0 "in WHEN")
+ (/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) (find-escaped-frame caller)
- (/show0 "at COND")
+ (/noshow0 "at COND")
(cond (code
- (/show0 "in CODE clause")
+ (/noshow0 "in CODE clause")
;; If it's escaped it may be a function end breakpoint trap.
(when (and (code-component-p code)
(eq (%code-debug-info code) :bogus-lra))
(setq code (code-header-ref code real-lra-slot))
(aver code)))
(t
- (/show0 "in T clause")
+ (/noshow0 "in T clause")
;; not escaped
(multiple-value-setq (pc-offset code)
(compute-lra-data-from-pc ra))
"undefined function"))
(:foreign-function
(make-bogus-debug-fun
- "foreign function call land"))
+ (foreign-function-backtrace-name ra)))
((nil)
(make-bogus-debug-fun
"bogus stack frame"))
(t
(debug-fun-from-pc code pc-offset)))))
- (/show0 "returning MAKE-COMPILED-FRAME from COMPUTE-CALLING-FRAME")
+ (/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)))))
+(defun nth-interrupt-context (n)
+ (declare (type (unsigned-byte 32) n)
+ (optimize (speed 3) (safety 0)))
+ (sb!alien:sap-alien (sb!vm::current-thread-offset-sap
+ (+ sb!vm::thread-interrupt-contexts-offset n))
+ (* os-context-t)))
+
#!+x86
(defun find-escaped-frame (frame-pointer)
(declare (type system-area-pointer frame-pointer))
- (/show0 "entering FIND-ESCAPED-FRAME")
+ (/noshow0 "entering FIND-ESCAPED-FRAME")
(dotimes (index *free-interrupt-context-index* (values nil 0 nil))
- (sb!alien:with-alien
- ((lisp-interrupt-contexts (array (* os-context-t) nil) :extern))
- (/show0 "at head of WITH-ALIEN")
- (let ((context (sb!alien:deref lisp-interrupt-contexts index)))
- (/show0 "got CONTEXT")
+ (/noshow0 "at head of WITH-ALIEN")
+ (let ((context (nth-interrupt-context index)))
+ (/noshow0 "got CONTEXT")
(when (= (sap-int frame-pointer)
(sb!vm:context-register context sb!vm::cfp-offset))
(without-gcing
- (/show0 "in WITHOUT-GCING")
+ (/noshow0 "in WITHOUT-GCING")
(let* ((component-ptr (component-ptr-from-pc
(sb!vm:context-pc context)))
(code (unless (sap= component-ptr (int-sap #x0))
(component-from-component-ptr component-ptr))))
- (/show0 "got CODE")
+ (/noshow0 "got CODE")
(when (null code)
(return (values code 0 context)))
(let* ((code-header-len (* (get-header-data code)
- sb!vm:word-bytes))
+ sb!vm:n-word-bytes))
(pc-offset
(- (sap-int (sb!vm:context-pc context))
(- (get-lisp-obj-address code)
- sb!vm:other-pointer-type)
+ sb!vm:other-pointer-lowtag)
code-header-len)))
- (/show "got PC-OFFSET")
+ (/noshow "got PC-OFFSET")
(unless (<= 0 pc-offset
(* (code-header-ref code sb!vm:code-code-size-slot)
- sb!vm:word-bytes))
+ sb!vm:n-word-bytes))
;; We were in an assembly routine. Therefore, use the
;; LRA as the pc.
;;
;; FIXME: Should this be WARN or ERROR or what?
(format t "** pc-offset ~S not in code obj ~S?~%"
pc-offset code))
- (/show0 "returning from FIND-ESCAPED-FRAME")
+ (/noshow0 "returning from FIND-ESCAPED-FRAME")
(return
- (values code pc-offset context))))))))))
+ (values code pc-offset context)))))))))
#!-x86
(defun find-escaped-frame (frame-pointer)
(declare (type system-area-pointer frame-pointer))
(dotimes (index *free-interrupt-context-index* (values nil 0 nil))
- (sb!alien:with-alien
- ((lisp-interrupt-contexts (array (* os-context-t) nil) :extern))
- (let ((scp (sb!alien:deref lisp-interrupt-contexts index)))
- (when (= (sap-int frame-pointer)
- (sb!vm:context-register scp sb!vm::cfp-offset))
- (without-gcing
- (let ((code (code-object-from-bits
- (sb!vm:context-register scp sb!vm::code-offset))))
- (when (symbolp code)
- (return (values code 0 scp)))
- (let* ((code-header-len (* (get-header-data code)
- sb!vm:word-bytes))
- (pc-offset
- (- (sap-int (sb!vm:context-pc scp))
- (- (get-lisp-obj-address code)
- sb!vm:other-pointer-type)
- code-header-len)))
- ;; Check to see whether we were executing in a branch
- ;; delay slot.
- #!+(or pmax sgi) ; pmax only (and broken anyway)
- (when (logbitp 31 (sb!alien:slot scp '%mips::sc-cause))
- (incf pc-offset sb!vm:word-bytes))
- (unless (<= 0 pc-offset
- (* (code-header-ref code sb!vm:code-code-size-slot)
- sb!vm:word-bytes))
- ;; We were in an assembly routine. Therefore, use the
- ;; LRA as the pc.
- (setf pc-offset
- (- (sb!vm:context-register scp sb!vm::lra-offset)
- (get-lisp-obj-address code)
- code-header-len)))
- (return
- (if (eq (%code-debug-info code) :bogus-lra)
- (let ((real-lra (code-header-ref code
- real-lra-slot)))
- (values (lra-code-header real-lra)
- (get-header-data real-lra)
- nil))
- (values code pc-offset scp)))))))))))
+ (let ((scp (nth-interrupt-context index)))
+ (when (= (sap-int frame-pointer)
+ (sb!vm:context-register scp sb!vm::cfp-offset))
+ (without-gcing
+ (let ((code (code-object-from-bits
+ (sb!vm:context-register scp sb!vm::code-offset))))
+ (when (symbolp code)
+ (return (values code 0 scp)))
+ (let* ((code-header-len (* (get-header-data code)
+ sb!vm:n-word-bytes))
+ (pc-offset
+ (- (sap-int (sb!vm:context-pc scp))
+ (- (get-lisp-obj-address code)
+ sb!vm:other-pointer-lowtag)
+ code-header-len)))
+ ;; Check to see whether we were executing in a branch
+ ;; delay slot.
+ #!+(or pmax sgi) ; pmax only (and broken anyway)
+ (when (logbitp 31 (sb!alien:slot scp '%mips::sc-cause))
+ (incf pc-offset sb!vm:n-word-bytes))
+ (let ((code-size (* (code-header-ref code
+ sb!vm:code-code-size-slot)
+ sb!vm:n-word-bytes)))
+ (unless (<= 0 pc-offset code-size)
+ ;; We were in an assembly routine.
+ (multiple-value-bind (new-pc-offset computed-return)
+ (find-pc-from-assembly-fun code scp)
+ (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 (sb!vm:context-pc scp))
+ code
+ (%code-entry-points code)
+ (sb!vm:context-register scp sb!vm::lra-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)))))
+ (return
+ (if (eq (%code-debug-info code) :bogus-lra)
+ (let ((real-lra (code-header-ref code
+ real-lra-slot)))
+ (values (lra-code-header real-lra)
+ (get-header-data real-lra)
+ nil))
+ (values code pc-offset scp))))))))))
+
+#!-x86
+(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."
+ (let ((return-machine-address (sb!vm::return-machine-address scp))
+ (code-header-len (* (get-header-data 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
(declare (type (unsigned-byte 32) bits))
(let ((object (make-lisp-obj bits)))
(if (functionp object)
- (or (function-code-header object)
+ (or (fun-code-header object)
:undefined-function)
- (let ((lowtag (get-lowtag object)))
- (if (= lowtag sb!vm:other-pointer-type)
- (let ((type (get-type object)))
- (cond ((= type sb!vm:code-header-type)
+ (let ((lowtag (lowtag-of object)))
+ (if (= lowtag sb!vm:other-pointer-lowtag)
+ (let ((widetag (widetag-of object)))
+ (cond ((= widetag sb!vm:code-header-widetag)
object)
- ((= type sb!vm:return-pc-header-type)
+ ((= widetag sb!vm:return-pc-header-widetag)
(lra-code-header object))
(t
nil))))))))
\f
;;;; frame utilities
-;;; This returns a COMPILED-DEBUG-FUN for code and pc. We fetch
-;;; the SB!C::DEBUG-INFO and run down its function-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
+;;; This returns a COMPILED-DEBUG-FUN for COMPONENT and PC. We fetch the
+;;; SB!C::DEBUG-INFO and run down its FUN-MAP to get a
+;;; SB!C::COMPILED-DEBUG-FUN from the PC. The result only needs to
+;;; reference the COMPONENT, for function constants, and the
;;; SB!C::COMPILED-DEBUG-FUN.
(defun debug-fun-from-pc (component pc)
(let ((info (%code-debug-info component)))
((eq info :bogus-lra)
(make-bogus-debug-fun "function end breakpoint"))
(t
- (let* ((function-map (get-debug-info-function-map info))
- (len (length function-map)))
- (declare (simple-vector function-map))
+ (let* ((fun-map (sb!c::compiled-debug-info-fun-map info))
+ (len (length fun-map)))
+ (declare (type simple-vector fun-map))
(if (= len 1)
- (make-compiled-debug-fun (svref function-map 0) component)
+ (make-compiled-debug-fun (svref fun-map 0) component)
(let ((i 1)
(elsewhere-p
(>= pc (sb!c::compiled-debug-fun-elsewhere-pc
- (svref function-map 0)))))
+ (svref fun-map 0)))))
(declare (type sb!int:index i))
(loop
(when (or (= i len)
(< pc (if elsewhere-p
(sb!c::compiled-debug-fun-elsewhere-pc
- (svref function-map (1+ i)))
- (svref function-map i))))
+ (svref fun-map (1+ i)))
+ (svref fun-map i))))
(return (make-compiled-debug-fun
- (svref function-map (1- i))
+ (svref fun-map (1- i))
component)))
(incf i 2)))))))))
;;; 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*))
- (res nil)
+ (let ((catch (descriptor-sap sb!vm:*current-catch-block*))
+ (reversed-result nil)
(fp (frame-pointer frame)))
- (loop
- (when (zerop (sap-int catch)) (return (nreverse res)))
- (when (sap= fp
- #!-alpha
- (sap-ref-sap catch
- (* sb!vm:catch-block-current-cont-slot
- sb!vm:word-bytes))
- #!+alpha
- (:int-sap
- (sap-ref-32 catch
- (* sb!vm:catch-block-current-cont-slot
- sb!vm:word-bytes))))
- (let* (#!-x86
- (lra (stack-ref catch sb!vm:catch-block-entry-pc-slot))
- #!+x86
- (ra (sap-ref-sap
- catch (* sb!vm:catch-block-entry-pc-slot
- sb!vm:word-bytes)))
- #!-x86
- (component
- (stack-ref catch sb!vm:catch-block-current-code-slot))
- #!+x86
- (component (component-from-component-ptr
- (component-ptr-from-pc ra)))
- (offset
- #!-x86
- (* (- (1+ (get-header-data lra))
- (get-header-data component))
- sb!vm:word-bytes)
- #!+x86
- (- (sap-int ra)
- (- (get-lisp-obj-address component)
- sb!vm:other-pointer-type)
- (* (get-header-data component) sb!vm:word-bytes))))
- (push (cons #!-x86
- (stack-ref catch sb!vm:catch-block-tag-slot)
- #!+x86
- (make-lisp-obj
- (sap-ref-32 catch (* sb!vm:catch-block-tag-slot
- sb!vm:word-bytes)))
- (make-compiled-code-location
- offset (frame-debug-fun frame)))
- res)))
- (setf catch
- #!-alpha
- (sap-ref-sap catch
- (* sb!vm:catch-block-previous-catch-slot
- sb!vm:word-bytes))
- #!+alpha
- (:int-sap
- (sap-ref-32 catch
- (* sb!vm:catch-block-previous-catch-slot
- sb!vm:word-bytes)))))))
+ (loop until (zerop (sap-int catch))
+ finally (return (nreverse reversed-result))
+ do
+ (when (sap= fp
+ #!-alpha
+ (sap-ref-sap catch
+ (* sb!vm:catch-block-current-cont-slot
+ sb!vm:n-word-bytes))
+ #!+alpha
+ (int-sap
+ (sap-ref-32 catch
+ (* sb!vm:catch-block-current-cont-slot
+ sb!vm:n-word-bytes))))
+ (let* (#!-x86
+ (lra (stack-ref catch sb!vm:catch-block-entry-pc-slot))
+ #!+x86
+ (ra (sap-ref-sap
+ catch (* sb!vm:catch-block-entry-pc-slot
+ sb!vm:n-word-bytes)))
+ #!-x86
+ (component
+ (stack-ref catch sb!vm:catch-block-current-code-slot))
+ #!+x86
+ (component (component-from-component-ptr
+ (component-ptr-from-pc ra)))
+ (offset
+ #!-x86
+ (* (- (1+ (get-header-data lra))
+ (get-header-data component))
+ sb!vm:n-word-bytes)
+ #!+x86
+ (- (sap-int ra)
+ (- (get-lisp-obj-address component)
+ sb!vm:other-pointer-lowtag)
+ (* (get-header-data component) sb!vm:n-word-bytes))))
+ (push (cons #!-x86
+ (stack-ref catch sb!vm:catch-block-tag-slot)
+ #!+x86
+ (make-lisp-obj
+ (sap-ref-32 catch (* sb!vm:catch-block-tag-slot
+ sb!vm:n-word-bytes)))
+ (make-compiled-code-location
+ offset (frame-debug-fun frame)))
+ reversed-result)))
+ (setf catch
+ #!-alpha
+ (sap-ref-sap catch
+ (* sb!vm:catch-block-previous-catch-slot
+ sb!vm:n-word-bytes))
+ #!+alpha
+ (int-sap
+ (sap-ref-32 catch
+ (* sb!vm:catch-block-previous-catch-slot
+ sb!vm:n-word-bytes)))))))
\f
;;;; operations on DEBUG-FUNs
;;; nil). This may iterate over only some of DEBUG-FUN's variables or
;;; none depending on debug policy; for example, possibly the
;;; compilation only preserved argument information.
-(defmacro do-debug-fun-variables ((var debug-fun &optional result)
- &body body)
+(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)))
(sb!c::compiled-debug-fun-start-pc
(compiled-debug-fun-compiler-debug-fun debug-fun))))
(do ((entry (%code-entry-points component)
- (%function-next entry)))
+ (%simple-fun-next entry)))
((null entry) nil)
(when (= start-pc
(sb!c::compiled-debug-fun-start-pc
;;; Return the name of the function represented by DEBUG-FUN. This may
;;; be a string or a cons; do not assume it is a symbol.
(defun debug-fun-name (debug-fun)
+ (declare (type debug-fun debug-fun))
(etypecase debug-fun
(compiled-debug-fun
(sb!c::compiled-debug-fun-name
;;; Return a DEBUG-FUN that represents debug information for FUN.
(defun fun-debug-fun (fun)
(declare (type function fun))
- (ecase (get-type fun)
- (#.sb!vm:closure-header-type
- (fun-debug-fun (%closure-function fun)))
- (#.sb!vm:funcallable-instance-header-type
- (fun-debug-fun (funcallable-instance-function fun)))
- ((#.sb!vm:function-header-type #.sb!vm:closure-function-header-type)
- (let* ((name (%function-name fun))
- (component (function-code-header fun))
+ (ecase (widetag-of fun)
+ (#.sb!vm:closure-header-widetag
+ (fun-debug-fun (%closure-fun fun)))
+ (#.sb!vm:funcallable-instance-header-widetag
+ (fun-debug-fun (funcallable-instance-fun fun)))
+ (#.sb!vm:simple-fun-header-widetag
+ (let* ((name (%simple-fun-name fun))
+ (component (fun-code-header fun))
(res (find-if
(lambda (x)
(and (sb!c::compiled-debug-fun-p x)
(eq (sb!c::compiled-debug-fun-name x) name)
(eq (sb!c::compiled-debug-fun-kind x) nil)))
- (get-debug-info-function-map
+ (sb!c::compiled-debug-info-fun-map
(%code-debug-info component)))))
(if res
(make-compiled-debug-fun res component)
;; works for all named functions anyway.
;; -- WHN 20000120
(debug-fun-from-pc component
- (* (- (function-word-offset fun)
+ (* (- (fun-word-offset fun)
(get-header-data component))
- sb!vm:word-bytes)))))))
+ sb!vm:n-word-bytes)))))))
;;; Return the kind of the function, which is one of :OPTIONAL,
-;;; :EXTERNAL, TOP-level, :CLEANUP, or NIL.
+;;; :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
;;; as symbol. The result of this function is limited to the
;;; availability of variable information in DEBUG-FUN; for
;;; example, possibly DEBUG-FUN only knows about its arguments.
-(defun debug-fun-symbol-variables (debug-fun symbol)
+(defun debug-fun-symbol-vars (debug-fun symbol)
(let ((vars (ambiguous-debug-vars debug-fun (symbol-name symbol)))
(package (and (symbol-package symbol)
(package-name (symbol-package symbol)))))
(if variables
(let* ((len (length variables))
(prefix-len (length name-prefix-string))
- (pos (find-variable name-prefix-string variables len))
+ (pos (find-var name-prefix-string variables len))
(res nil))
(when pos
;; Find names from pos to variable's len that contain prefix.
(setq res (nreverse res)))
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-variable (name variables &optional end)
+;;; 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))))
+ :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
(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.
+;;; 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)
(make-array 20 :adjustable t :fill-pointer t))
(defvar *other-parsing-buffer*
(make-array 20 :adjustable t :fill-pointer t))
-;;; PARSE-DEBUG-BLOCKS, PARSE-DEBUG-VARS and UNCOMPACT-FUNCTION-MAP
+;;; PARSE-DEBUG-BLOCKS and PARSE-DEBUG-VARS
;;; use this to unpack binary encoded information. It returns the
;;; values returned by the last form in body.
;;;
(debug-signal 'no-debug-blocks
:debug-fun debug-fun)))))
-;;; This returns a SIMPLE-VECTOR of DEBUG-BLOCKs or NIL. NIL indicates
-;;; there was no basic block information.
+;;; 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
;;; This does some of the work of PARSE-DEBUG-BLOCKS.
(defun parse-compiled-debug-blocks (debug-fun)
- (let* ((debug-fun (compiled-debug-fun-compiler-debug-fun
- debug-fun))
- (var-count (length (debug-fun-debug-vars debug-fun)))
- (blocks (sb!c::compiled-debug-fun-blocks debug-fun))
+ (let* ((var-count (length (debug-fun-debug-vars debug-fun)))
+ (compiler-debug-fun (compiled-debug-fun-compiler-debug-fun
+ debug-fun))
+ (blocks (sb!c::compiled-debug-fun-blocks compiler-debug-fun))
;; KLUDGE: 8 is a hard-wired constant in the compiler for the
;; element size of the packed binary representation of the
;; blocks data.
(live-set-len (ceiling var-count 8))
- (tlf-number (sb!c::compiled-debug-fun-tlf-number debug-fun)))
- (unless blocks (return-from parse-compiled-debug-blocks nil))
+ (tlf-number (sb!c::compiled-debug-fun-tlf-number compiler-debug-fun)))
+ (unless blocks
+ (return-from parse-compiled-debug-blocks nil))
(macrolet ((aref+ (a i) `(prog1 (aref ,a ,i) (incf ,i))))
(with-parsing-buffer (blocks-buffer locations-buffer)
(let ((i 0)
(list successors))
(dotimes (k (ldb sb!c::compiled-debug-block-nsucc-byte
succ-and-flags))
- (push (sb!c::read-var-integer blocks i) successors))
+ (push (sb!c:read-var-integer blocks i) successors))
(let* ((locations
- (dotimes (k (sb!c::read-var-integer blocks i)
+ (dotimes (k (sb!c:read-var-integer blocks i)
(result locations-buffer))
(let ((kind (svref sb!c::*compiled-code-location-kinds*
(aref+ blocks i)))
(pc (+ last-pc
- (sb!c::read-var-integer blocks i)))
+ (sb!c:read-var-integer blocks i)))
(tlf-offset (or tlf-number
- (sb!c::read-var-integer blocks
- i)))
- (form-number (sb!c::read-var-integer blocks i))
- (live-set (sb!c::read-packed-bit-vector
+ (sb!c:read-var-integer blocks i)))
+ (form-number (sb!c:read-var-integer blocks i))
+ (live-set (sb!c:read-packed-bit-vector
live-set-len blocks i)))
(vector-push-extend (make-known-code-location
pc debug-fun tlf-offset
(defun assign-minimal-var-names (vars)
(declare (simple-vector vars))
(let* ((len (length vars))
- (width (length (format nil "~D" (1- len)))))
+ (width (length (format nil "~W" (1- len)))))
(dotimes (i len)
- (setf (compiled-debug-var-symbol (svref vars i))
- (intern (format nil "ARG-~V,'0D" width i)
- ;; KLUDGE: It's somewhat nasty to have a bare
- ;; package name string here. It would be
- ;; nicer to have #.(FIND-PACKAGE "SB!DEBUG")
- ;; instead, since then at least it would transform
- ;; correctly under package renaming and stuff.
- ;; However, genesis can't handle dumped packages..
- ;; -- WHN 20000129
- ;;
- ;; FIXME: Maybe this could be fixed by moving the
- ;; whole debug-int.lisp file to warm init? (after
- ;; which dumping a #.(FIND-PACKAGE ..) expression
- ;; would work fine) If this is possible, it would
- ;; probably be a good thing, since minimizing the
- ;; amount of stuff in cold init is basically good.
- (or (find-package "SB-DEBUG")
- (find-package "SB!DEBUG")))))))
+ (without-package-locks
+ (setf (compiled-debug-var-symbol (svref vars i))
+ (intern (format nil "ARG-~V,'0D" width i)
+ ;; KLUDGE: It's somewhat nasty to have a bare
+ ;; package name string here. It would be
+ ;; nicer to have #.(FIND-PACKAGE "SB!DEBUG")
+ ;; instead, since then at least it would transform
+ ;; correctly under package renaming and stuff.
+ ;; However, genesis can't handle dumped packages..
+ ;; -- WHN 20000129
+ ;;
+ ;; FIXME: Maybe this could be fixed by moving the
+ ;; whole debug-int.lisp file to warm init? (after
+ ;; which dumping a #.(FIND-PACKAGE ..) expression
+ ;; would work fine) If this is possible, it would
+ ;; probably be a good thing, since minimizing the
+ ;; amount of stuff in cold init is basically good.
+ (or (find-package "SB-DEBUG")
+ (find-package "SB!DEBUG"))))))))
;;; Parse the packed representation of DEBUG-VARs from
;;; DEBUG-FUN's SB!C::COMPILED-DEBUG-FUN, returning a vector
(defun parse-compiled-debug-vars (debug-fun)
(let* ((cdebug-fun (compiled-debug-fun-compiler-debug-fun
debug-fun))
- (packed-vars (sb!c::compiled-debug-fun-variables cdebug-fun))
+ (packed-vars (sb!c::compiled-debug-fun-vars cdebug-fun))
(args-minimal (eq (sb!c::compiled-debug-fun-arguments cdebug-fun)
:minimal)))
(when packed-vars
save-sc-offset)
buffer)))))))
\f
-;;;; unpacking minimal debug functions
-
-(eval-when (:compile-toplevel :execute)
-
-;;; sleazoid "macro" to keep our indentation sane in UNCOMPACT-FUNCTION-MAP
-(sb!xc:defmacro make-uncompacted-debug-fun ()
- '(sb!c::make-compiled-debug-fun
- :name
- (let ((base (ecase (ldb sb!c::minimal-debug-fun-name-style-byte
- options)
- (#.sb!c::minimal-debug-fun-name-symbol
- (intern (sb!c::read-var-string map i)
- (sb!c::compiled-debug-info-package info)))
- (#.sb!c::minimal-debug-fun-name-packaged
- (let ((pkg (sb!c::read-var-string map i)))
- (intern (sb!c::read-var-string map i) pkg)))
- (#.sb!c::minimal-debug-fun-name-uninterned
- (make-symbol (sb!c::read-var-string map i)))
- (#.sb!c::minimal-debug-fun-name-component
- (sb!c::compiled-debug-info-name info)))))
- (if (logtest flags sb!c::minimal-debug-fun-setf-bit)
- `(setf ,base)
- base))
- :kind (svref sb!c::*minimal-debug-fun-kinds*
- (ldb sb!c::minimal-debug-fun-kind-byte options))
- :variables
- (when vars-p
- (let ((len (sb!c::read-var-integer map i)))
- (prog1 (subseq map i (+ i len))
- (incf i len))))
- :arguments (when vars-p :minimal)
- :returns
- (ecase (ldb sb!c::minimal-debug-fun-returns-byte options)
- (#.sb!c::minimal-debug-fun-returns-standard
- :standard)
- (#.sb!c::minimal-debug-fun-returns-fixed
- :fixed)
- (#.sb!c::minimal-debug-fun-returns-specified
- (with-parsing-buffer (buf)
- (dotimes (idx (sb!c::read-var-integer map i))
- (vector-push-extend (sb!c::read-var-integer map i) buf))
- (result buf))))
- :return-pc (sb!c::read-var-integer map i)
- :old-fp (sb!c::read-var-integer map i)
- :nfp (when (logtest flags sb!c::minimal-debug-fun-nfp-bit)
- (sb!c::read-var-integer map i))
- :start-pc
- (progn
- (setq code-start-pc (+ code-start-pc (sb!c::read-var-integer map i)))
- (+ code-start-pc (sb!c::read-var-integer map i)))
- :elsewhere-pc
- (setq elsewhere-pc (+ elsewhere-pc (sb!c::read-var-integer map i)))))
-
-) ; EVAL-WHEN
-
-;;; Return a normal function map derived from a minimal debug info
-;;; function map. This involves looping parsing MINIMAL-DEBUG-FUNs and
-;;; then building a vector out of them.
-;;;
-;;; FIXME: This and its helper macro just above become dead code now
-;;; that we no longer use compacted function maps.
-(defun uncompact-function-map (info)
- (declare (type sb!c::compiled-debug-info info))
-
- ;; (This is stubified until we solve the problem of representing
- ;; debug information in a way which plays nicely with package renaming.)
- (error "FIXME: dead code UNCOMPACT-FUNCTION-MAP (was stub)")
-
- (let* ((map (sb!c::compiled-debug-info-function-map info))
- (i 0)
- (len (length map))
- (code-start-pc 0)
- (elsewhere-pc 0))
- (declare (type (simple-array (unsigned-byte 8) (*)) map))
- (sb!int:collect ((res))
- (loop
- (when (= i len) (return))
- (let* ((options (prog1 (aref map i) (incf i)))
- (flags (prog1 (aref map i) (incf i)))
- (vars-p (logtest flags
- sb!c::minimal-debug-fun-variables-bit))
- (dfun (make-uncompacted-debug-fun)))
- (res code-start-pc)
- (res dfun)))
-
- (coerce (cdr (res)) 'simple-vector))))
-
-;;; a map from minimal DEBUG-INFO function maps to unpacked
-;;; versions thereof
-(defvar *uncompacted-function-maps* (make-hash-table :test 'eq))
-
-;;; Return a FUNCTION-MAP for a given COMPILED-DEBUG-info object. If
-;;; the info is minimal, and has not been parsed, then parse it.
-;;;
-;;; FIXME: Now that we no longer use the MINIMAL-DEBUG-FUN
-;;; representation, calls to this function can be replaced by calls to
-;;; the bare COMPILED-DEBUG-INFO-FUNCTION-MAP slot accessor function,
-;;; and this function and everything it calls become dead code which
-;;; can be deleted.
-(defun get-debug-info-function-map (info)
- (declare (type sb!c::compiled-debug-info info))
- (let ((map (sb!c::compiled-debug-info-function-map info)))
- (if (simple-vector-p map)
- map
- (or (gethash map *uncompacted-function-maps*)
- (setf (gethash map *uncompacted-function-maps*)
- (uncompact-function-map info))))))
-\f
;;;; CODE-LOCATIONs
;;; If we're sure of whether code-location is known, return T or NIL.
0)))
(svref blocks (1- end)))
(t last))))
- (declare (type sb!c::index i end))
+ (declare (type index i end))
(when (< pc
(compiled-code-location-pc
(svref (compiled-debug-block-code-locations
(car sources)
(do ((prev sources src)
(src (cdr sources) (cdr src))
- (offset (code-location-top-level-form-offset code-location)))
+ (offset (code-location-toplevel-form-offset code-location)))
((null src) (car prev))
(when (< offset (sb!c::debug-source-source-root (car src)))
(return (car prev)))))))
;; did special tricks to debug the IR1 interpreter.)
))
-;;; Returns the number of top-level forms before the one containing
+;;; Returns the number of top level forms before the one containing
;;; CODE-LOCATION as seen by the compiler in some compilation unit. (A
;;; compilation unit is not necessarily a single file, see the section
;;; on debug-sources.)
-(defun code-location-top-level-form-offset (code-location)
+(defun code-location-toplevel-form-offset (code-location)
(when (code-location-unknown-p code-location)
(error 'unknown-code-location :code-location code-location))
(let ((tlf-offset (code-location-%tlf-offset code-location)))
(unless (fill-in-code-location code-location)
;; This check should be unnecessary. We're missing
;; debug info the compiler should have dumped.
- (error "internal error: unknown code location"))
+ (bug "unknown code location"))
(code-location-%tlf-offset code-location))
;; (There used to be more cases back before sbcl-0.7.0,,
;; when we did special tricks to debug the IR1
(t tlf-offset))))
;;; Return the number of the form corresponding to CODE-LOCATION. The
-;;; form number is derived by a walking the subforms of a top-level
+;;; form 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)
(unless (fill-in-code-location code-location)
;; This check should be unnecessary. We're missing
;; debug info the compiler should have dumped.
- (error "internal error: unknown code location"))
+ (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
((not (fill-in-code-location code-location))
;; This check should be unnecessary. We're missing
;; debug info the compiler should have dumped.
- (error "internal error: unknown code location"))
+ (bug "unknown code location"))
(t
(compiled-code-location-kind code-location)))))
;; (There used to be more cases back before sbcl-0.7.0,,
;;
;; FIXME: This error and comment happen over and over again.
;; Make them a shared function.
- (error "internal error: unknown code location"))
+ (bug "unknown code location"))
(compiled-code-location-%live-set code-location))
(t live-set)))))
;; interpreter.)
))
;; (There used to be more cases back before sbcl-0.7.0,,
- ;; when we did special tricks to debug the IR1
- ;; interpreter.)
+ ;; when we did special tricks to debug IR1-interpreted code.)
))
(defun sub-compiled-code-location= (obj1 obj2)
(= (compiled-code-location-pc obj1)
;;; Return the name of the function represented by DEBUG-FUN.
;;; This may be a string or a cons; do not assume it is a symbol.
-(defun debug-block-function-name (debug-block)
+(defun debug-block-fun-name (debug-block)
(etypecase debug-block
(compiled-debug-block
(let ((code-locs (compiled-debug-block-code-locations debug-block)))
;;; GC, and might also arise in debug variable locations when
;;; those variables are invalid.)
(defun make-valid-lisp-obj (val)
- (/show0 "entering MAKE-VALID-LISP-OBJ, VAL=..")
- #!+sb-show (/hexstr val)
(if (or
;; fixnum
(zerop (logand val 3))
;; character
(and (zerop (logand val #xffff0000)) ; Top bits zero
- (= (logand val #xff) sb!vm:base-char-type)) ; Char tag
+ (= (logand val #xff) sb!vm:character-widetag)) ; char tag
;; unbound marker
- (= val sb!vm:unbound-marker-type)
+ (= val sb!vm:unbound-marker-widetag)
;; pointer
(and (logand val 1)
;; Check that the pointer is valid. XXX Could do a better
;; routine in the C runtime support code
(or (< sb!vm:read-only-space-start val
(* sb!vm:*read-only-space-free-pointer*
- sb!vm:word-bytes))
+ sb!vm:n-word-bytes))
(< sb!vm:static-space-start val
(* sb!vm:*static-space-free-pointer*
- sb!vm:word-bytes))
+ sb!vm:n-word-bytes))
(< sb!vm:dynamic-space-start val
(sap-int (dynamic-space-free-pointer))))))
(make-lisp-obj val)
(sb!vm:context-register escaped
sb!vm::nfp-offset))
#!-alpha
- (sb!sys:sap-ref-sap fp (* sb!vm::nfp-save-offset
- sb!vm:word-bytes))
+ (sb!sys:sap-ref-sap fp (* nfp-save-offset
+ sb!vm:n-word-bytes))
#!+alpha
(sb!vm::make-number-stack-pointer
- (sb!sys:sap-ref-32 fp (* sb!vm::nfp-save-offset
- sb!vm:word-bytes))))))
+ (sb!sys:sap-ref-32 fp (* nfp-save-offset
+ sb!vm:n-word-bytes))))))
,@body)))
(ecase (sb!c:sc-offset-scn sc-offset)
((#.sb!vm:any-reg-sc-number
(sb!sys:without-gcing
(with-escaped-value (val) (sb!kernel:make-lisp-obj val))))
- (#.sb!vm:base-char-reg-sc-number
+ (#.sb!vm:character-reg-sc-number
(with-escaped-value (val)
(code-char val)))
(#.sb!vm:sap-reg-sc-number
(sb!sys:int-sap val)))
(#.sb!vm:signed-reg-sc-number
(with-escaped-value (val)
- (if (logbitp (1- sb!vm:word-bits) val)
- (logior val (ash -1 sb!vm:word-bits))
+ (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)
(sb!vm:context-float-register
escaped (sb!c:sc-offset-offset sc-offset) 'double-float)
(sb!vm:context-float-register
- escaped (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 2 #-sparc 1)
+ escaped (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 2 #!-sparc 1)
'double-float))
:invalid-value-for-unescaped-register-storage))
#!+long-float
(#.sb!vm:single-stack-sc-number
(with-nfp (nfp)
(sb!sys:sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset)
- sb!vm:word-bytes))))
+ sb!vm:n-word-bytes))))
(#.sb!vm:double-stack-sc-number
(with-nfp (nfp)
(sb!sys:sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset)
- sb!vm:word-bytes))))
+ sb!vm:n-word-bytes))))
#!+long-float
(#.sb!vm:long-stack-sc-number
(with-nfp (nfp)
(sb!sys:sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset)
- sb!vm:word-bytes))))
+ sb!vm:n-word-bytes))))
(#.sb!vm:complex-single-stack-sc-number
(with-nfp (nfp)
(complex
(sb!sys:sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset)
- sb!vm:word-bytes))
+ sb!vm:n-word-bytes))
(sb!sys:sap-ref-single nfp (* (1+ (sb!c:sc-offset-offset sc-offset))
- sb!vm:word-bytes)))))
+ sb!vm:n-word-bytes)))))
(#.sb!vm:complex-double-stack-sc-number
(with-nfp (nfp)
(complex
(sb!sys:sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset)
- sb!vm:word-bytes))
+ sb!vm:n-word-bytes))
(sb!sys:sap-ref-double nfp (* (+ (sb!c:sc-offset-offset sc-offset) 2)
- sb!vm:word-bytes)))))
+ sb!vm:n-word-bytes)))))
#!+long-float
(#.sb!vm:complex-long-stack-sc-number
(with-nfp (nfp)
(complex
(sb!sys:sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset)
- sb!vm:word-bytes))
+ sb!vm:n-word-bytes))
(sb!sys:sap-ref-long nfp (* (+ (sb!c:sc-offset-offset sc-offset)
#!+sparc 4)
- sb!vm:word-bytes)))))
+ sb!vm:n-word-bytes)))))
(#.sb!vm:control-stack-sc-number
(sb!kernel:stack-ref fp (sb!c:sc-offset-offset sc-offset)))
- (#.sb!vm:base-char-stack-sc-number
+ (#.sb!vm:character-stack-sc-number
(with-nfp (nfp)
(code-char (sb!sys:sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
- sb!vm:word-bytes)))))
+ sb!vm:n-word-bytes)))))
(#.sb!vm:unsigned-stack-sc-number
(with-nfp (nfp)
(sb!sys:sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
- sb!vm:word-bytes))))
+ sb!vm:n-word-bytes))))
(#.sb!vm:signed-stack-sc-number
(with-nfp (nfp)
(sb!sys:signed-sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
- sb!vm:word-bytes))))
+ sb!vm:n-word-bytes))))
(#.sb!vm:sap-stack-sc-number
(with-nfp (nfp)
(sb!sys:sap-ref-sap nfp (* (sb!c:sc-offset-offset sc-offset)
- sb!vm:word-bytes)))))))
+ sb!vm:n-word-bytes)))))))
#!+x86
(defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
(declare (type system-area-pointer fp))
- (/show0 "entering SUB-ACCESS-DEBUG-VAR-SLOT, FP,SC-OFFSET,ESCAPED=..")
- (/hexstr fp) (/hexstr sc-offset) (/hexstr escaped)
(macrolet ((with-escaped-value ((var) &body forms)
`(if escaped
(let ((,var (sb!vm:context-register
escaped
(sb!c:sc-offset-offset sc-offset))))
- (/show0 "in escaped case, ,VAR value=..")
- (/hexstr ,var)
,@forms)
:invalid-value-for-unescaped-register-storage))
(escaped-float-value (format)
:invalid-value-for-unescaped-register-storage)))
(ecase (sb!c:sc-offset-scn sc-offset)
((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number)
- (/show0 "case of ANY-REG-SC-NUMBER or DESCRIPTOR-REG-SC-NUMBER")
(without-gcing
(with-escaped-value (val)
- (/show0 "VAL=..")
- (/hexstr val)
(make-valid-lisp-obj val))))
- (#.sb!vm:base-char-reg-sc-number
- (/show0 "case of BASE-CHAR-REG-SC-NUMBER")
+ (#.sb!vm:character-reg-sc-number
(with-escaped-value (val)
(code-char val)))
(#.sb!vm:sap-reg-sc-number
- (/show0 "case of SAP-REG-SC-NUMBER")
(with-escaped-value (val)
(int-sap val)))
(#.sb!vm:signed-reg-sc-number
- (/show0 "case of SIGNED-REG-SC-NUMBER")
(with-escaped-value (val)
- (if (logbitp (1- sb!vm:word-bits) val)
- (logior val (ash -1 sb!vm:word-bits))
+ (if (logbitp (1- sb!vm:n-word-bits) val)
+ (logior val (ash -1 sb!vm:n-word-bits))
val)))
(#.sb!vm:unsigned-reg-sc-number
- (/show0 "case of UNSIGNED-REG-SC-NUMBER")
(with-escaped-value (val)
val))
(#.sb!vm:single-reg-sc-number
- (/show0 "case of SINGLE-REG-SC-NUMBER")
(escaped-float-value single-float))
(#.sb!vm:double-reg-sc-number
- (/show0 "case of DOUBLE-REG-SC-NUMBER")
(escaped-float-value double-float))
#!+long-float
(#.sb!vm:long-reg-sc-number
- (/show0 "case of LONG-REG-SC-NUMBER")
(escaped-float-value long-float))
(#.sb!vm:complex-single-reg-sc-number
- (/show0 "case of COMPLEX-SINGLE-REG-SC-NUMBER")
(escaped-complex-float-value single-float))
(#.sb!vm:complex-double-reg-sc-number
- (/show0 "case of COMPLEX-DOUBLE-REG-SC-NUMBER")
(escaped-complex-float-value double-float))
#!+long-float
(#.sb!vm:complex-long-reg-sc-number
- (/show0 "case of COMPLEX-LONG-REG-SC-NUMBER")
(escaped-complex-float-value long-float))
(#.sb!vm:single-stack-sc-number
- (/show0 "case of SINGLE-STACK-SC-NUMBER")
(sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
- sb!vm:word-bytes))))
+ sb!vm:n-word-bytes))))
(#.sb!vm:double-stack-sc-number
- (/show0 "case of DOUBLE-STACK-SC-NUMBER")
(sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
- sb!vm:word-bytes))))
+ sb!vm:n-word-bytes))))
#!+long-float
(#.sb!vm:long-stack-sc-number
- (/show0 "case of LONG-STACK-SC-NUMBER")
(sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
- sb!vm:word-bytes))))
+ sb!vm:n-word-bytes))))
(#.sb!vm:complex-single-stack-sc-number
- (/show0 "case of COMPLEX-STACK-SC-NUMBER")
(complex
(sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
- sb!vm:word-bytes)))
+ sb!vm:n-word-bytes)))
(sap-ref-single fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
- sb!vm:word-bytes)))))
+ sb!vm:n-word-bytes)))))
(#.sb!vm:complex-double-stack-sc-number
- (/show0 "case of COMPLEX-DOUBLE-STACK-SC-NUMBER")
(complex
(sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
- sb!vm:word-bytes)))
+ sb!vm:n-word-bytes)))
(sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 4)
- sb!vm:word-bytes)))))
+ sb!vm:n-word-bytes)))))
#!+long-float
(#.sb!vm:complex-long-stack-sc-number
- (/show0 "case of COMPLEX-LONG-STACK-SC-NUMBER")
(complex
(sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
- sb!vm:word-bytes)))
+ sb!vm:n-word-bytes)))
(sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 6)
- sb!vm:word-bytes)))))
+ sb!vm:n-word-bytes)))))
(#.sb!vm:control-stack-sc-number
- (/show0 "case of CONTROL-STACK-SC-NUMBER")
(stack-ref fp (sb!c:sc-offset-offset sc-offset)))
- (#.sb!vm:base-char-stack-sc-number
- (/show0 "case of BASE-CHAR-STACK-SC-NUMBER")
+ (#.sb!vm:character-stack-sc-number
(code-char
(sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
- sb!vm:word-bytes)))))
+ sb!vm:n-word-bytes)))))
(#.sb!vm:unsigned-stack-sc-number
- (/show0 "case of UNSIGNED-STACK-SC-NUMBER")
(sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
- sb!vm:word-bytes))))
+ sb!vm:n-word-bytes))))
(#.sb!vm:signed-stack-sc-number
- (/show0 "case of SIGNED-STACK-SC-NUMBER")
(signed-sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
- sb!vm:word-bytes))))
+ sb!vm:n-word-bytes))))
(#.sb!vm:sap-stack-sc-number
- (/show0 "case of SAP-STACK-SC-NUMBER")
(sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
- sb!vm:word-bytes)))))))
+ sb!vm:n-word-bytes)))))))
;;; This stores value as the value of DEBUG-VAR in FRAME. In the
;;; COMPILED-DEBUG-VAR case, access the current value to determine if
sb!vm::nfp-offset))
#!-alpha
(sap-ref-sap fp
- (* sb!vm::nfp-save-offset
- sb!vm:word-bytes))
+ (* nfp-save-offset
+ sb!vm:n-word-bytes))
#!+alpha
(sb!vm::make-number-stack-pointer
(sap-ref-32 fp
- (* sb!vm::nfp-save-offset
- sb!vm:word-bytes))))))
+ (* nfp-save-offset
+ sb!vm:n-word-bytes))))))
,@body)))
(ecase (sb!c:sc-offset-scn sc-offset)
((#.sb!vm:any-reg-sc-number
(without-gcing
(set-escaped-value
(get-lisp-obj-address value))))
- (#.sb!vm:base-char-reg-sc-number
+ (#.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 (1- (ash 1 sb!vm:word-bits)))))
+ (set-escaped-value (logand value (1- (ash 1 sb!vm:n-word-bits)))))
(#.sb!vm:unsigned-reg-sc-number
(set-escaped-value value))
(#.sb!vm:non-descriptor-reg-sc-number
(#.sb!vm:single-stack-sc-number
(with-nfp (nfp)
(setf (sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset)
- sb!vm:word-bytes))
+ sb!vm:n-word-bytes))
(the single-float value))))
(#.sb!vm:double-stack-sc-number
(with-nfp (nfp)
(setf (sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset)
- sb!vm:word-bytes))
+ sb!vm:n-word-bytes))
(the double-float value))))
#!+long-float
(#.sb!vm:long-stack-sc-number
(with-nfp (nfp)
(setf (sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset)
- sb!vm:word-bytes))
+ sb!vm:n-word-bytes))
(the long-float value))))
(#.sb!vm:complex-single-stack-sc-number
(with-nfp (nfp)
(setf (sap-ref-single
- nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:word-bytes))
+ nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes))
(the single-float (realpart value)))
(setf (sap-ref-single
nfp (* (1+ (sb!c:sc-offset-offset sc-offset))
- sb!vm:word-bytes))
+ sb!vm:n-word-bytes))
(the single-float (realpart value)))))
(#.sb!vm:complex-double-stack-sc-number
(with-nfp (nfp)
(setf (sap-ref-double
- nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:word-bytes))
+ nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes))
(the double-float (realpart value)))
(setf (sap-ref-double
nfp (* (+ (sb!c:sc-offset-offset sc-offset) 2)
- sb!vm:word-bytes))
+ sb!vm:n-word-bytes))
(the double-float (realpart value)))))
#!+long-float
(#.sb!vm:complex-long-stack-sc-number
(with-nfp (nfp)
(setf (sap-ref-long
- nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:word-bytes))
+ nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes))
(the long-float (realpart value)))
(setf (sap-ref-long
nfp (* (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4)
- sb!vm:word-bytes))
+ sb!vm:n-word-bytes))
(the long-float (realpart value)))))
(#.sb!vm:control-stack-sc-number
(setf (stack-ref fp (sb!c:sc-offset-offset sc-offset)) value))
- (#.sb!vm:base-char-stack-sc-number
+ (#.sb!vm:character-stack-sc-number
(with-nfp (nfp)
(setf (sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
- sb!vm:word-bytes))
+ sb!vm:n-word-bytes))
(char-code (the character value)))))
(#.sb!vm:unsigned-stack-sc-number
(with-nfp (nfp)
(setf (sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
- sb!vm:word-bytes))
+ sb!vm:n-word-bytes))
(the (unsigned-byte 32) value))))
(#.sb!vm:signed-stack-sc-number
(with-nfp (nfp)
(setf (signed-sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
- sb!vm:word-bytes))
+ sb!vm:n-word-bytes))
(the (signed-byte 32) value))))
(#.sb!vm:sap-stack-sc-number
(with-nfp (nfp)
(setf (sap-ref-sap nfp (* (sb!c:sc-offset-offset sc-offset)
- sb!vm:word-bytes))
+ sb!vm:n-word-bytes))
(the system-area-pointer value)))))))
#!+x86
(without-gcing
(set-escaped-value
(get-lisp-obj-address value))))
- (#.sb!vm:base-char-reg-sc-number
+ (#.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 (1- (ash 1 sb!vm:word-bits)))))
+ (set-escaped-value (logand value (1- (ash 1 sb!vm:n-word-bits)))))
(#.sb!vm:unsigned-reg-sc-number
(set-escaped-value value))
(#.sb!vm:single-reg-sc-number
(#.sb!vm:single-stack-sc-number
(setf (sap-ref-single
fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
- sb!vm:word-bytes)))
+ sb!vm:n-word-bytes)))
(the single-float value)))
(#.sb!vm:double-stack-sc-number
(setf (sap-ref-double
fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
- sb!vm:word-bytes)))
+ sb!vm:n-word-bytes)))
(the double-float value)))
#!+long-float
(#.sb!vm:long-stack-sc-number
(setf (sap-ref-long
fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
- sb!vm:word-bytes)))
+ sb!vm:n-word-bytes)))
(the long-float value)))
(#.sb!vm:complex-single-stack-sc-number
(setf (sap-ref-single
fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
- sb!vm:word-bytes)))
+ sb!vm:n-word-bytes)))
(realpart (the (complex single-float) value)))
(setf (sap-ref-single
fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
- sb!vm:word-bytes)))
+ sb!vm:n-word-bytes)))
(imagpart (the (complex single-float) value))))
(#.sb!vm:complex-double-stack-sc-number
(setf (sap-ref-double
fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
- sb!vm:word-bytes)))
+ sb!vm:n-word-bytes)))
(realpart (the (complex double-float) value)))
(setf (sap-ref-double
fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 4)
- sb!vm:word-bytes)))
+ sb!vm:n-word-bytes)))
(imagpart (the (complex double-float) value))))
#!+long-float
(#.sb!vm:complex-long-stack-sc-number
(setf (sap-ref-long
fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
- sb!vm:word-bytes)))
+ sb!vm:n-word-bytes)))
(realpart (the (complex long-float) value)))
(setf (sap-ref-long
fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 6)
- sb!vm:word-bytes)))
+ sb!vm:n-word-bytes)))
(imagpart (the (complex long-float) value))))
(#.sb!vm:control-stack-sc-number
(setf (stack-ref fp (sb!c:sc-offset-offset sc-offset)) value))
- (#.sb!vm:base-char-stack-sc-number
+ (#.sb!vm:character-stack-sc-number
(setf (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
- sb!vm:word-bytes)))
+ sb!vm:n-word-bytes)))
(char-code (the character value))))
(#.sb!vm:unsigned-stack-sc-number
(setf (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
- sb!vm:word-bytes)))
+ sb!vm:n-word-bytes)))
(the (unsigned-byte 32) value)))
(#.sb!vm:signed-stack-sc-number
(setf (signed-sap-ref-32
- fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) sb!vm:word-bytes)))
+ fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
+ sb!vm:n-word-bytes)))
(the (signed-byte 32) value)))
(#.sb!vm:sap-stack-sc-number
(setf (sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
- sb!vm:word-bytes)))
+ sb!vm:n-word-bytes)))
(the system-area-pointer value))))))
;;; The method for setting and accessing COMPILED-DEBUG-VAR values use
;;; this to determine if the value stored is the actual value or an
;;; indirection cell.
(defun indirect-value-cell-p (x)
- (and (= (get-lowtag x) sb!vm:other-pointer-type)
- (= (get-type x) sb!vm:value-cell-header-type)))
+ (and (= (lowtag-of x) sb!vm:other-pointer-lowtag)
+ (= (widetag-of x) sb!vm:value-cell-header-widetag)))
;;; Return three values reflecting the validity of DEBUG-VAR's value
;;; at BASIC-CODE-LOCATION:
;;; This code produces and uses what we call source-paths. A
;;; source-path is a list whose first element is a form number as
;;; returned by CODE-LOCATION-FORM-NUMBER and whose last element is a
-;;; top-level-form number as returned by
-;;; CODE-LOCATION-TOP-LEVEL-FORM-NUMBER. The elements from the last to
+;;; top level form number as returned by
+;;; CODE-LOCATION-TOPLEVEL-FORM-NUMBER. The elements from the last to
;;; the first, exclusively, are the numbered subforms into which to
;;; descend. For example:
;;; (defun foo (x)
;;; (let ((a (aref x 3)))
;;; (cons a 3)))
;;; The call to AREF in this example is form number 5. Assuming this
-;;; DEFUN is the 11'th top-level-form, the source-path for the AREF
+;;; DEFUN is the 11'th top level form, the source-path for the AREF
;;; call is as follows:
;;; (5 1 0 1 3 11)
;;; Given the DEFUN, 3 gets you the LET, 1 gets you the bindings, 0
;;; table used to detect CAR circularities in FORM-NUMBER-TRANSLATIONS
(defvar *form-number-circularity-table* (make-hash-table :test 'eq))
-;;; This returns a table mapping form numbers to source-paths. A source-path
-;;; indicates a descent into the top-level-form form, going directly to the
-;;; subform corressponding to the form number.
+;;; 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 top-level-form number.
+;;; the last is the TOPLEVEL-FORM number.
(defun form-number-translations (form tlf-number)
(clrhash *form-number-circularity-table*)
(setf (fill-pointer *form-number-temp*) 0)
(frob)
(setq trail (cdr trail)))))))
-;;; FORM is a top-level form, and path is a source-path into it. This
+;;; 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
;;; The returned function takes the frame to get values from as its
;;; argument, and it returns the values of FORM. The returned function
;;; can signal the following conditions: INVALID-VALUE,
-;;; AMBIGUOUS-VARIABLE-NAME, and FRAME-FUN-MISMATCH.
+;;; AMBIGUOUS-VAR-NAME, and FRAME-FUN-MISMATCH.
(defun preprocess-for-eval (form loc)
(declare (type code-location loc))
(let ((n-frame (gensym))
(debug-signal 'no-debug-vars :debug-fun fun))
(sb!int:collect ((binds)
(specs))
- (do-debug-fun-variables (var fun)
+ (do-debug-fun-vars (var fun)
(let ((validity (debug-var-validity var loc)))
(unless (eq validity :invalid)
(let* ((sym (debug-var-symbol var))
(:valid
(specs `(,name (debug-var-value ',var ,n-frame))))
(:unknown
- (specs `(,name (debug-signal 'invalid-value :debug-var ',var
+ (specs `(,name (debug-signal 'invalid-value
+ :debug-var ',var
:frame ,n-frame))))
(:ambiguous
- (specs `(,name (debug-signal 'ambiguous-variable-name :name ',name
+ (specs `(,name (debug-signal 'ambiguous-var-name
+ :name ',name
:frame ,n-frame)))))))
(let ((res (coerce `(lambda (,n-frame)
(declare (ignorable ,n-frame))
(symbol-macrolet ,(specs) ,form))
'function)))
- #'(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))))))
+ (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))))))
\f
;;;; breakpoints
;;;; user-visible interface
;;; Create and return a breakpoint. When program execution encounters
-;;; the breakpoint, the system calls HOOK-FUNCTION. HOOK-FUNCTION takes the
-;;; current frame for the function in which the program is running and the
-;;; breakpoint object.
+;;; 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-FUNCTION. WHAT is either a code-location or a DEBUG-FUN.
-;;; KIND is one of :CODE-LOCATION, :FUNCTION-START, or :FUNCTION-END.
-;;; Since the starts and ends of functions may not have code-locations
-;;; representing them, designate these places by supplying WHAT as a
-;;; DEBUG-FUN and KIND indicating the :FUNCTION-START or
-;;; :FUNCTION-END. When WHAT is a DEBUG-FUN and kind is
-;;; :FUNCTION-END, then hook-function must take two additional
-;;; arguments, a list of values returned by the function and a
-;;; FUNCTION-END-COOKIE.
+;;; 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.
;;;
-;;; FUNCTION-END-COOKIE is a function. To implement :FUNCTION-END
+;;; FUN-END-COOKIE is a function. To implement :FUN-END
;;; breakpoints, the system uses starter breakpoints to establish the
-;;; :FUNCTION-END breakpoint for each invocation of the function. Upon
+;;; :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 :FUNCTION-END breakpoint hook on the same
+;;; system later invokes the :FUN-END breakpoint hook on the same
;;; cookie. The user may save the cookie for comparison in the hook
;;; function.
;;;
;;; Signal an error if WHAT is an unknown code-location.
-(defun make-breakpoint (hook-function what
- &key (kind :code-location) info function-end-cookie)
+(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-function what kind info)))
+ (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-function what
+ (let ((other-bpt (%make-breakpoint hook-fun what
:unknown-return-partner
info)))
(setf (breakpoint-unknown-return-partner bpt) other-bpt)
bpt))
(compiled-debug-fun
(ecase kind
- (:function-start
- (%make-breakpoint hook-function what kind info))
- (:function-end
+ (: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 ":FUNCTION-END breakpoints are currently unsupported ~
- for the known return convention."))
+ (error ":FUN-END breakpoints are currently unsupported ~
+ for the known return convention."))
- (let* ((bpt (%make-breakpoint hook-function what kind info))
+ (let* ((bpt (%make-breakpoint hook-fun what kind info))
(starter (compiled-debug-fun-end-starter what)))
(unless starter
- (setf starter (%make-breakpoint #'list what :function-start nil))
- (setf (breakpoint-hook-function starter)
- (function-end-starter-hook starter what))
+ (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) function-end-cookie)
+ (setf (breakpoint-cookie-fun bpt) fun-end-cookie)
bpt))))))
;;; These are unique objects created upon entry into a function by a
-;;; :FUNCTION-END breakpoint's starter hook. These are only created
-;;; when users supply :FUNCTION-END-COOKIE to MAKE-BREAKPOINT. Also,
-;;; the :FUNCTION-END breakpoint's hook is called on the same cookie
+;;; :FUN-END breakpoint's starter hook. These are only created
+;;; when users supply :FUN-END-COOKIE to MAKE-BREAKPOINT. Also,
+;;; the :FUN-END breakpoint's hook is called on the same cookie
;;; when it is created.
-(defstruct (function-end-cookie
+(defstruct (fun-end-cookie
(:print-object (lambda (obj str)
(print-unreadable-object (obj str :type t))))
- (:constructor make-function-end-cookie (bogus-lra debug-fun))
+ (:constructor make-fun-end-cookie (bogus-lra debug-fun))
(:copier nil))
- ;; a pointer to the bogus-lra created for :FUNCTION-END breakpoints
+ ;; a pointer to the bogus-lra created for :FUN-END breakpoints
bogus-lra
;; the DEBUG-FUN associated with this cookie
debug-fun)
;;; This maps bogus-lra-components to cookies, so that
-;;; HANDLE-FUNCTION-END-BREAKPOINT can find the appropriate cookie for the
+;;; HANDLE-FUN-END-BREAKPOINT can find the appropriate cookie for the
;;; breakpoint hook.
-(defvar *function-end-cookies* (make-hash-table :test 'eq))
+(defvar *fun-end-cookies* (make-hash-table :test 'eq))
;;; This returns a hook function for the start helper breakpoint
-;;; associated with a :FUNCTION-END breakpoint. The returned function
+;;; associated with a :FUN-END breakpoint. The returned function
;;; makes a fake LRA that all returns go through, and this piece of
;;; fake code actually breaks. Upon return from the break, the code
;;; provides the returnee with any values. Since the returned function
;;; effectively activates FUN-END-BPT on each entry to DEBUG-FUN's
;;; function, we must establish breakpoint-data about FUN-END-BPT.
-(defun function-end-starter-hook (starter-bpt debug-fun)
+(defun fun-end-starter-hook (starter-bpt debug-fun)
(declare (type breakpoint starter-bpt)
(type compiled-debug-fun debug-fun))
- #'(lambda (frame breakpoint)
- (declare (ignore breakpoint)
- (type frame frame))
- (let ((lra-sc-offset
- (sb!c::compiled-debug-fun-return-pc
- (compiled-debug-fun-compiler-debug-fun debug-fun))))
- (multiple-value-bind (lra component offset)
- (make-bogus-lra
- (get-context-value frame
- sb!vm::lra-save-offset
- lra-sc-offset))
- (setf (get-context-value frame
- sb!vm::lra-save-offset
- lra-sc-offset)
- 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-function-end-cookie lra debug-fun)))
- (setf (gethash component *function-end-cookies*) cookie)
- (dolist (bpt end-bpts)
- (let ((fun (breakpoint-cookie-fun bpt)))
- (when fun (funcall fun frame cookie))))))))))
-
-;;; This takes a FUNCTION-END-COOKIE and a frame, and it returns
+ (lambda (frame breakpoint)
+ (declare (ignore breakpoint)
+ (type frame frame))
+ (let ((lra-sc-offset
+ (sb!c::compiled-debug-fun-return-pc
+ (compiled-debug-fun-compiler-debug-fun debug-fun))))
+ (multiple-value-bind (lra component offset)
+ (make-bogus-lra
+ (get-context-value frame
+ lra-save-offset
+ lra-sc-offset))
+ (setf (get-context-value frame
+ lra-save-offset
+ lra-sc-offset)
+ 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
-;;; :FUNCTION-END breakpoint hooks didn't run due to THROW'ing.
+;;; :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 function-end-cookie-valid-p (frame cookie)
- (let ((lra (function-end-cookie-bogus-lra cookie))
+(defun fun-end-cookie-valid-p (frame cookie)
+ (let ((lra (fun-end-cookie-bogus-lra cookie))
(lra-sc-offset (sb!c::compiled-debug-fun-return-pc
(compiled-debug-fun-compiler-debug-fun
- (function-end-cookie-debug-fun cookie)))))
+ (fun-end-cookie-debug-fun cookie)))))
(do ((frame frame (frame-down frame)))
((not frame) nil)
(when (and (compiled-frame-p frame)
- (eq lra
- (get-context-value frame
- sb!vm::lra-save-offset
- lra-sc-offset)))
+ (#!-x86 eq #!+x86 sap=
+ lra
+ (get-context-value frame lra-save-offset lra-sc-offset)))
(return t)))))
\f
;;;; ACTIVATE-BREAKPOINT
-;;; Cause the system to invoke the breakpoint's hook-function until
+;;; 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.
;; (There used to be more cases back before sbcl-0.7.0, when
;; we did special tricks to debug the IR1 interpreter.)
)))
- (:function-start
+ (:fun-start
(etypecase (breakpoint-what breakpoint)
(compiled-debug-fun
- (activate-compiled-function-start-breakpoint breakpoint))
+ (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.)
))
- (:function-end
+ (: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 :FUNCTION-END breakpoint
- (activate-compiled-function-start-breakpoint starter)))
+ ;; may already be active by some other :FUN-END breakpoint
+ (activate-compiled-fun-start-breakpoint starter)))
(setf (breakpoint-status breakpoint) :active))
;; (There used to be more cases back before sbcl-0.7.0, when
;; we did special tricks to debug the IR1 interpreter.)
sb!vm:single-value-return-byte-offset
0))))))
-(defun activate-compiled-function-start-breakpoint (breakpoint)
+(defun activate-compiled-fun-start-breakpoint (breakpoint)
(declare (type breakpoint breakpoint))
(let ((debug-fun (breakpoint-what breakpoint)))
(sub-activate-breakpoint
\f
;;;; DEACTIVATE-BREAKPOINT
-;;; Stop the system from invoking the breakpoint's hook-function.
+;;; Stop the system from invoking the breakpoint's hook function.
(defun deactivate-breakpoint (breakpoint)
(when (eq (breakpoint-status breakpoint) :active)
(without-interrupts
breakpoint)
(defun deactivate-compiled-breakpoint (breakpoint)
- (if (eq (breakpoint-kind breakpoint) :function-end)
+ (if (eq (breakpoint-kind breakpoint) :fun-end)
(let ((starter (breakpoint-start-helper breakpoint)))
- (unless (find-if #'(lambda (bpt)
- (and (not (eq bpt breakpoint))
- (eq (breakpoint-status bpt) :active)))
+ (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))
(let ((other (breakpoint-unknown-return-partner breakpoint)))
(when other
(setf (breakpoint-status other) :deleted)))
- (when (eq (breakpoint-kind breakpoint) :function-end)
+ (when (eq (breakpoint-kind breakpoint) :fun-end)
(let* ((starter (breakpoint-start-helper breakpoint))
(breakpoints (delete breakpoint
(the list (breakpoint-info starter)))))
;;; returns the overwritten bits. You must call this in a context in
;;; which GC is disabled, so that Lisp doesn't move objects around
;;; that C is pointing to.
-(sb!alien:def-alien-routine "breakpoint_install" sb!c-call:unsigned-long
- (code-obj sb!c-call:unsigned-long)
- (pc-offset sb!c-call:int))
+(sb!alien:define-alien-routine "breakpoint_install" sb!alien:unsigned-long
+ (code-obj sb!alien:unsigned-long)
+ (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:def-alien-routine "breakpoint_remove" sb!c-call:void
- (code-obj sb!c-call:unsigned-long)
- (pc-offset sb!c-call:int)
- (old-inst sb!c-call:unsigned-long))
+(sb!alien:define-alien-routine "breakpoint_remove" sb!alien:void
+ (code-obj sb!alien:unsigned-long)
+ (pc-offset sb!alien:int)
+ (old-inst sb!alien:unsigned-long))
-(sb!alien:def-alien-routine "breakpoint_do_displaced_inst" sb!c-call:void
+(sb!alien:define-alien-routine "breakpoint_do_displaced_inst" sb!alien:void
(scp (* os-context-t))
- (orig-inst sb!c-call:unsigned-long))
+ (orig-inst sb!alien:unsigned-long))
;;;; breakpoint handlers (layer between C and exported interface)
-;;; This maps components to a mapping of offsets to breakpoint-datas.
+;;; This maps components to a mapping of offsets to BREAKPOINT-DATAs.
(defvar *component-breakpoint-offsets* (make-hash-table :test 'eq))
-;;; This returns the breakpoint-data associated with component cross
+;;; This returns the BREAKPOINT-DATA object associated with component cross
;;; offset. If none exists, this makes one, installs it, and returns it.
(defun breakpoint-data (component offset &optional (create t))
(flet ((install-breakpoint-data ()
(install-breakpoint-data)))))
;;; We use this when there are no longer any active breakpoints
-;;; corresponding to data.
+;;; corresponding to DATA.
(defun delete-breakpoint-data (data)
(let* ((component (breakpoint-data-component data))
(offsets (delete (breakpoint-data-offset data)
(values))
;;; The C handler for interrupts calls this when it has a
-;;; debugging-tool break instruction. This does NOT handle all breaks;
-;;; for example, it does not handle breaks for internal errors.
+;;; debugging-tool break instruction. This does *not* handle all
+;;; breaks; for example, it does not handle breaks for internal
+;;; errors.
(defun handle-breakpoint (offset component signal-context)
- (/show0 "entering HANDLE-BREAKPOINT")
(let ((data (breakpoint-data component offset nil)))
(unless data
(error "unknown breakpoint in ~S at offset ~S"
offset))
(let ((breakpoints (breakpoint-data-breakpoints data)))
(if (or (null breakpoints)
- (eq (breakpoint-kind (car breakpoints)) :function-end))
- (handle-function-end-breakpoint-aux breakpoints data signal-context)
+ (eq (breakpoint-kind (car breakpoints)) :fun-end))
+ (handle-fun-end-breakpoint-aux breakpoints data signal-context)
(handle-breakpoint-aux breakpoints data
offset component signal-context)))))
;;; This holds breakpoint-datas while invoking the breakpoint hooks
;;; associated with that particular component and location. While they
;;; are executing, if we hit the location again, we ignore the
-;;; breakpoint to avoid infinite recursion. Function-end breakpoints
+;;; breakpoint to avoid infinite recursion. fun-end breakpoints
;;; must work differently since the breakpoint-data is unique for each
;;; invocation.
(defvar *executing-breakpoint-hooks* nil)
-;;; This handles code-location and DEBUG-FUN :FUNCTION-START
+;;; This handles code-location and DEBUG-FUN :FUN-START
;;; breakpoints.
(defun handle-breakpoint-aux (breakpoints data offset component signal-context)
- (/show0 "entering HANDLE-BREAKPOINT-AUX")
(unless breakpoints
- (error "internal error: breakpoint that nobody wants"))
+ (bug "breakpoint that nobody wants"))
(unless (member data *executing-breakpoint-hooks*)
(let ((*executing-breakpoint-hooks* (cons data
*executing-breakpoint-hooks*)))
(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() doesn't sigreturn(),
- ;; add it to this list.
- #!-(or hpux irix x86 alpha)
+ ;; 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 component offset)
(frame (do ((f (top-frame) (frame-down f)))
((eq debug-fun (frame-debug-fun f)) f))))
(dolist (bpt breakpoints)
- (funcall (breakpoint-hook-function bpt)
+ (funcall (breakpoint-hook-fun bpt)
frame
;; If this is an :UNKNOWN-RETURN-PARTNER, then pass the
;; hook function the original breakpoint, so that users
(breakpoint-unknown-return-partner bpt)
bpt)))))
-(defun handle-function-end-breakpoint (offset component context)
- (/show0 "entering HANDLE-FUNCTION-END-BREAKPOINT")
+(defun handle-fun-end-breakpoint (offset component context)
(let ((data (breakpoint-data component offset nil)))
(unless data
(error "unknown breakpoint in ~S at offset ~S"
offset))
(let ((breakpoints (breakpoint-data-breakpoints data)))
(when breakpoints
- (aver (eq (breakpoint-kind (car breakpoints)) :function-end))
- (handle-function-end-breakpoint-aux breakpoints data context)))))
+ (aver (eq (breakpoint-kind (car breakpoints)) :fun-end))
+ (handle-fun-end-breakpoint-aux breakpoints data context)))))
-;;; Either HANDLE-BREAKPOINT calls this for :FUNCTION-END breakpoints
-;;; [old C code] or HANDLE-FUNCTION-END-BREAKPOINT calls this directly
+;;; Either HANDLE-BREAKPOINT calls this for :FUN-END breakpoints
+;;; [old C code] or HANDLE-FUN-END-BREAKPOINT calls this directly
;;; [new C code].
-(defun handle-function-end-breakpoint-aux (breakpoints data signal-context)
- (/show0 "entering HANDLE-FUNCTION-END-BREAKPOINT-AUX")
+(defun handle-fun-end-breakpoint-aux (breakpoints data signal-context)
(delete-breakpoint-data data)
(let* ((scp
(locally
(frame (do ((cfp (sb!vm:context-register scp sb!vm::cfp-offset))
(f (top-frame) (frame-down f)))
((= cfp (sap-int (frame-pointer f))) f)
- (declare (type (unsigned-byte #.sb!vm:word-bits) cfp))))
+ (declare (type (unsigned-byte #.sb!vm:n-word-bits) cfp))))
(component (breakpoint-data-component data))
- (cookie (gethash component *function-end-cookies*)))
- (remhash component *function-end-cookies*)
+ (cookie (gethash component *fun-end-cookies*)))
+ (remhash component *fun-end-cookies*)
(dolist (bpt breakpoints)
- (funcall (breakpoint-hook-function bpt)
+ (funcall (breakpoint-hook-fun bpt)
frame bpt
- (get-function-end-breakpoint-values scp)
+ (get-fun-end-breakpoint-values scp)
cookie))))
-(defun get-function-end-breakpoint-values (scp)
+(defun get-fun-end-breakpoint-values (scp)
(let ((ocfp (int-sap (sb!vm:context-register
scp
#!-x86 sb!vm::ocfp-offset
results)))
(nreverse results)))
\f
-;;;; MAKE-BOGUS-LRA (used for :FUNCTION-END breakpoints)
+;;;; MAKE-BOGUS-LRA (used for :FUN-END breakpoints)
(defconstant bogus-lra-constants
#!-x86 2 #!+x86 3)
;;; instruction.
(defun make-bogus-lra (real-lra &optional known-return-p)
(without-gcing
- (let* ((src-start (foreign-symbol-address "function_end_breakpoint_guts"))
- (src-end (foreign-symbol-address "function_end_breakpoint_end"))
- (trap-loc (foreign-symbol-address "function_end_breakpoint_trap"))
+ ;; These are really code labels, not variables: but this way we get
+ ;; their addresses.
+ (let* ((src-start (foreign-symbol-address "fun_end_breakpoint_guts"))
+ (src-end (foreign-symbol-address "fun_end_breakpoint_end"))
+ (trap-loc (foreign-symbol-address "fun_end_breakpoint_trap"))
(length (sap- src-end src-start))
(code-object
- (%primitive
- #!-(and x86 gencgc) sb!c:allocate-code-object
- #!+(and x86 gencgc) sb!c::allocate-dynamic-code-object
- (1+ bogus-lra-constants)
- length))
+ (%primitive sb!c:allocate-code-object (1+ bogus-lra-constants)
+ length))
(dst-start (code-instructions code-object)))
(declare (type system-area-pointer
src-start src-end dst-start trap-loc)
(setf (code-header-ref code-object (1+ real-lra-slot)) offset))
(setf (code-header-ref code-object known-return-p-slot)
known-return-p)
- (system-area-copy src-start 0 dst-start 0 (* length sb!vm:byte-bits))
+ (system-area-copy src-start 0 dst-start 0 (* length sb!vm:n-byte-bits))
(sb!vm:sanctify-for-execution code-object)
#!+x86
(values dst-start code-object (sap- trap-loc src-start))
#!-x86
(let ((new-lra (make-lisp-obj (+ (sap-int dst-start)
- sb!vm:other-pointer-type))))
+ sb!vm:other-pointer-lowtag))))
(set-header-data
new-lra
(logandc2 (+ sb!vm:code-constants-offset bogus-lra-constants 1)
;; (There used to be more cases back before sbcl-0.7.0, when
;; we did special tricks to debug the IR1 interpreter.)
))
-
-(defun print-code-locations (function)
- (let ((debug-fun (fun-debug-fun function)))
- (do-debug-fun-blocks (block debug-fun)
- (do-debug-block-locations (loc block)
- (fill-in-code-location loc)
- (format t "~S code location at ~D"
- (compiled-code-location-kind loc)
- (compiled-code-location-pc loc))
- (sb!debug::print-code-location-source-form loc 0)
- (terpri)))))
projects / sbcl.git / blobdiff