"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-info (debug-condition)
- ((code-component :reader no-debug-info-code-component
- :initarg :code-component))
- #!+sb-doc
- (:documentation "There is no usable debugging information available.")
- (:report (lambda (condition stream)
- (fresh-line stream)
- (format stream
- "no debug information available for ~S~%"
- (no-debug-info-code-component condition)))))
-
(define-condition no-debug-fun-returns (debug-condition)
((debug-fun :reader no-debug-fun-returns-debug-fun
:initarg :debug-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."
+ the debug information lacks details about returning ~
+ values here."
fun)))))
(define-condition no-debug-blocks (debug-condition)
;;;; frames
;;; This is used in FIND-ESCAPED-FRAME and with the bogus components
-;;; and LRAs used for :FUN-END breakpoints. When a components
+;;; 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.
(defun get-lisp-obj-address (thing) (get-lisp-obj-address thing))
(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
+ (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-lowtag)))
-;;;; X86 support
+;;;; (OR X86 X86-64) support
-#!+x86
+#!+(or x86 x86-64)
(progn
(defun compute-lra-data-from-pc (pc)
(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
(defun x86-call-context (fp &key (depth 0))
(declare (type system-area-pointer fp)
(fixnum depth))
- ;;(format t "*CC ~S ~S~%" fp 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+ ocfp-save-offset) 4))))
+ (let ((lisp-ocfp (sap-ref-sap fp (- (* (1+ ocfp-save-offset)
+ sb!vm::n-word-bytes))))
(lisp-ra (sap-ref-sap fp (- (* (1+ return-pc-save-offset)
- 4))))
+ sb!vm::n-word-bytes))))
(c-ocfp (sap-ref-sap fp (* 0 sb!vm:n-word-bytes)))
(c-ra (sap-ref-sap fp (* 1 sb!vm:n-word-bytes))))
- (cond ((and (sap> lisp-ocfp fp) (cstack-pointer-valid-p lisp-ocfp)
+ #+nil (format t " lisp-ocfp=~S~% lisp-ra=~S~% c-ocfp=~S~% c-ra=~S~%"
+ lisp-ocfp lisp-ra c-ocfp c-ra)
+ (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)
frame)))
(bogus-debug-fun
(let ((fp (frame-pointer frame)))
- (when (cstack-pointer-valid-p fp)
- #!+x86
+ (when (control-stack-pointer-valid-p fp)
+ #!+(or x86 x86-64)
(multiple-value-bind (ra ofp) (x86-call-context fp)
- (compute-calling-frame ofp ra frame))
- #!-x86
+ (and ra (compute-calling-frame ofp ra frame)))
+ #!-(or x86 x86-64)
(compute-calling-frame
#!-alpha
(sap-ref-sap fp (* ocfp-save-offset
;;; Get the old FP or return PC out of FRAME. STACK-SLOT is the
;;; standard save location offset on the stack. LOC is the saved
;;; SC-OFFSET describing the main location.
-#!-x86
+#!-(or x86 x86-64)
(defun get-context-value (frame stack-slot loc)
(declare (type compiled-frame frame) (type unsigned-byte stack-slot)
(type sb!c:sc-offset loc))
(if escaped
(sub-access-debug-var-slot pointer loc escaped)
(stack-ref pointer stack-slot))))
-#!+x86
+#!+(or x86 x86-64)
(defun get-context-value (frame stack-slot loc)
(declare (type compiled-frame frame) (type unsigned-byte stack-slot)
(type sb!c:sc-offset loc))
(#.ocfp-save-offset
(stack-ref pointer stack-slot))
(#.lra-save-offset
- (sap-ref-sap pointer (- (* (1+ stack-slot) 4))))))))
+ (sap-ref-sap pointer (- (* (1+ stack-slot)
+ sb!vm::n-word-bytes))))))))
-#!-x86
+#!-(or x86 x86-64)
(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))
(sub-set-debug-var-slot pointer loc value escaped)
(setf (stack-ref pointer stack-slot) value))))
-#!+x86
+#!+(or x86 x86-64)
(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))
(#.ocfp-save-offset
(setf (stack-ref pointer stack-slot) value))
(#.lra-save-offset
- (setf (sap-ref-sap pointer (- (* (1+ stack-slot) 4))) value))))))
+ (setf (sap-ref-sap pointer (- (* (1+ stack-slot)
+ sb!vm::n-word-bytes))) 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
;;; 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.
-#!-x86
+#!-(or x86 x86-64)
(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)
"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
+#!+(or x86 x86-64)
(defun compute-calling-frame (caller ra up-frame)
(declare (type system-area-pointer caller ra))
(/noshow0 "entering COMPUTE-CALLING-FRAME")
- (when (cstack-pointer-valid-p caller)
+ (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)
(/noshow0 "at COND")
(cond (code
- (/noshow0 "in CODE clause")
;; If it's escaped it may be a function end breakpoint trap.
(when (and (code-component-p code)
(eq (%code-debug-info code) :bogus-lra))
code (1+ real-lra-slot)))
(setq code (code-header-ref code real-lra-slot))
(aver code)))
- (t
- (/noshow0 "in T clause")
- ;; not escaped
+ ((not escaped)
(multiple-value-setq (pc-offset code)
(compute-lra-data-from-pc ra))
(unless code
(setf code :foreign-function
- pc-offset 0
- escaped nil))))
-
+ pc-offset 0))))
(let ((d-fun (case code
(:undefined-function
(make-bogus-debug-fun
"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"))
(if up-frame (1+ (frame-number up-frame)) 0)
escaped)))))
-#!+x86
+(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)))
+
+#!+(or x86 x86-64)
(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))
- (sb!alien:with-alien
- ((lisp-interrupt-contexts (array (* os-context-t) nil) :extern))
(/noshow0 "at head of WITH-ALIEN")
- (let ((context (sb!alien:deref lisp-interrupt-contexts index)))
+ (let ((context (nth-interrupt-context index)))
(/noshow0 "got CONTEXT")
(when (= (sap-int frame-pointer)
(sb!vm:context-register context sb!vm::cfp-offset))
pc-offset code))
(/noshow0 "returning from FIND-ESCAPED-FRAME")
(return
- (values code pc-offset context))))))))))
+ (values code pc-offset context)))))))))
-#!-x86
+#!-(or x86 x86-64)
(defun find-escaped-frame (frame-pointer)
(declare (type system-area-pointer frame-pointer))
(dotimes (index *free-interrupt-context-index* (values nil 0 nil))
- (sb!alien:with-alien
- ((lisp-interrupt-contexts (array (* os-context-t) nil) :extern))
- (let ((scp (sb!alien:deref lisp-interrupt-contexts index)))
- (when (= (sap-int frame-pointer)
- (sb!vm:context-register scp sb!vm::cfp-offset))
- (without-gcing
- (let ((code (code-object-from-bits
- (sb!vm:context-register scp sb!vm::code-offset))))
- (when (symbolp code)
- (return (values code 0 scp)))
- (let* ((code-header-len (* (get-header-data code)
- sb!vm:n-word-bytes))
- (pc-offset
- (- (sap-int (sb!vm:context-pc scp))
- (- (get-lisp-obj-address code)
- sb!vm:other-pointer-lowtag)
- code-header-len)))
- ;; Check to see whether we were executing in a branch
- ;; delay slot.
- #!+(or pmax sgi) ; pmax only (and broken anyway)
- (when (logbitp 31 (sb!alien:slot scp '%mips::sc-cause))
- (incf pc-offset sb!vm:n-word-bytes))
- (unless (<= 0 pc-offset
- (* (code-header-ref code sb!vm:code-code-size-slot)
- sb!vm:n-word-bytes))
- ;; We were in an assembly routine. Therefore, use the
- ;; LRA as the pc.
- (setf pc-offset
- (- (sb!vm:context-register scp sb!vm::lra-offset)
- (get-lisp-obj-address code)
- code-header-len)))
- (return
- (if (eq (%code-debug-info code) :bogus-lra)
- (let ((real-lra (code-header-ref code
- real-lra-slot)))
- (values (lra-code-header real-lra)
- (get-header-data real-lra)
- nil))
- (values code pc-offset scp)))))))))))
+ (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))))))))))
+
+#!-(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."
+ (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
(defun debug-fun-from-pc (component pc)
(let ((info (%code-debug-info component)))
(cond
- ((not info)
- (debug-signal 'no-debug-info :code-component component))
+ ((not info)
+ ;; FIXME: It seems that most of these (at least on x86) are
+ ;; actually assembler routines, and could be named by looking
+ ;; at the sb-fasl:*assembler-routines*.
+ (make-bogus-debug-fun "no debug information for frame"))
((eq info :bogus-lra)
(make-bogus-debug-fun "function end breakpoint"))
(t
(sap-ref-32 catch
(* sb!vm:catch-block-current-cont-slot
sb!vm:n-word-bytes))))
- (let* (#!-x86
+ (let* (#!-(or x86 x86-64)
(lra (stack-ref catch sb!vm:catch-block-entry-pc-slot))
- #!+x86
+ #!+(or x86 x86-64)
(ra (sap-ref-sap
catch (* sb!vm:catch-block-entry-pc-slot
sb!vm:n-word-bytes)))
- #!-x86
+ #!-(or x86 x86-64)
(component
(stack-ref catch sb!vm:catch-block-current-code-slot))
- #!+x86
+ #!+(or x86 x86-64)
(component (component-from-component-ptr
(component-ptr-from-pc ra)))
(offset
- #!-x86
+ #!-(or x86 x86-64)
(* (- (1+ (get-header-data lra))
(get-header-data component))
sb!vm:n-word-bytes)
- #!+x86
+ #!+(or x86 x86-64)
(- (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
+ (push (cons #!-(or x86 x86-64)
(stack-ref catch sb!vm:catch-block-tag-slot)
- #!+x86
+ #!+(or x86 x86-64)
(make-lisp-obj
- (sap-ref-32 catch (* sb!vm:catch-block-tag-slot
- sb!vm:n-word-bytes)))
+ (sap-ref-word catch (* sb!vm:catch-block-tag-slot
+ sb!vm:n-word-bytes)))
(make-compiled-code-location
offset (frame-debug-fun frame)))
reversed-result)))
(fun-debug-fun (%closure-fun fun)))
(#.sb!vm:funcallable-instance-header-widetag
(fun-debug-fun (funcallable-instance-fun fun)))
- ((#.sb!vm:simple-fun-header-widetag
- #.sb!vm:closure-fun-header-widetag)
+ (#.sb!vm:simple-fun-header-widetag
(let* ((name (%simple-fun-name fun))
(component (fun-code-header fun))
(res (find-if
;; optional. Stick the extra var in the result
;; element representing the keyword or optional,
;; which is the previous one.
+ ;;
+ ;; FIXME: NCONC used for side-effect: the effect is defined,
+ ;; but this is bad style no matter what.
(nconc (car res)
(list (compiled-debug-fun-lambda-list-var
args (incf i) vars))))
(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
(let* ((len (length vars))
(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
(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
(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)))))
(defun make-valid-lisp-obj (val)
(if (or
;; fixnum
- (zerop (logand val 3))
+ (zerop (logand val sb!vm:fixnum-tag-mask))
;; character
- (and (zerop (logand val #xffff0000)) ; Top bits zero
- (= (logand val #xff) sb!vm:base-char-widetag)) ; char tag
+ (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)
;; pointer
(make-lisp-obj val)
:invalid-object))
-#!-x86
+#!-(or x86 x86-64)
(defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
(macrolet ((with-escaped-value ((var) &body forms)
`(if escaped
(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!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: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:n-word-bytes)))))
(sb!sys:sap-ref-sap nfp (* (sb!c:sc-offset-offset sc-offset)
sb!vm:n-word-bytes)))))))
-#!+x86
+#!+(or x86 x86-64)
(defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
(declare (type system-area-pointer fp))
(macrolet ((with-escaped-value ((var) &body forms)
(without-gcing
(with-escaped-value (val)
(make-valid-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!vm:n-word-bytes)))))
(#.sb!vm:control-stack-sc-number
(stack-ref fp (sb!c:sc-offset-offset sc-offset)))
- (#.sb!vm: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:n-word-bytes)))))
+ (sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
+ sb!vm:n-word-bytes)))))
(#.sb!vm:unsigned-stack-sc-number
- (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
- sb!vm:n-word-bytes))))
+ (sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
+ sb!vm:n-word-bytes))))
(#.sb!vm:signed-stack-sc-number
- (signed-sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
- sb!vm:n-word-bytes))))
+ (signed-sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
+ sb!vm:n-word-bytes))))
(#.sb!vm:sap-stack-sc-number
(sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
sb!vm:n-word-bytes)))))))
(compiled-debug-var-sc-offset debug-var))
value))))
-#!-x86
+#!-(or x86 x86-64)
(defun sub-set-debug-var-slot (fp sc-offset value &optional escaped)
(macrolet ((set-escaped-value (val)
`(if escaped
(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)))
(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:n-word-bytes))
sb!vm:n-word-bytes))
(the system-area-pointer value)))))))
-#!+x86
+#!+(or x86 x86-64)
(defun sub-set-debug-var-slot (fp sc-offset value &optional escaped)
(macrolet ((set-escaped-value (val)
`(if escaped
(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)))
(imagpart (the (complex long-float) value))))
(#.sb!vm:control-stack-sc-number
(setf (stack-ref fp (sb!c:sc-offset-offset sc-offset)) value))
- (#.sb!vm:base-char-stack-sc-number
- (setf (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
- sb!vm:n-word-bytes)))
+ (#.sb!vm:character-stack-sc-number
+ (setf (sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
+ 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:n-word-bytes)))
- (the (unsigned-byte 32) value)))
+ (setf (sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
+ sb!vm:n-word-bytes)))
+ (the sb!vm:word value)))
(#.sb!vm:signed-stack-sc-number
- (setf (signed-sap-ref-32
+ (setf (signed-sap-ref-word
fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
sb!vm:n-word-bytes)))
- (the (signed-byte 32) value)))
+ (the (signed-byte #.sb!vm:n-word-bits) value)))
(#.sb!vm:sap-stack-sc-number
(setf (sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
sb!vm:n-word-bytes)))
(compiled-debug-fun-compiler-debug-fun what))
:standard)
(error ":FUN-END breakpoints are currently unsupported ~
- for the known return convention."))
+ for the known return convention."))
(let* ((bpt (%make-breakpoint hook-fun what kind info))
(starter (compiled-debug-fun-end-starter what)))
(do ((frame frame (frame-down frame)))
((not frame) nil)
(when (and (compiled-frame-p frame)
- (#-x86 eq #+x86 sap=
+ (#!-(or x86 x86-64) eq #!+(or x86 x86-64) sap=
lra
(get-context-value frame lra-save-offset lra-sc-offset)))
(return t)))))
;;; breakpoints.
(defun handle-breakpoint-aux (breakpoints data offset component signal-context)
(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)
(defun get-fun-end-breakpoint-values (scp)
(let ((ocfp (int-sap (sb!vm:context-register
scp
- #!-x86 sb!vm::ocfp-offset
- #!+x86 sb!vm::ebx-offset)))
+ #!-(or x86 x86-64) sb!vm::ocfp-offset
+ #!+(or x86 x86-64) sb!vm::ebx-offset)))
(nargs (make-lisp-obj
(sb!vm:context-register scp sb!vm::nargs-offset)))
(reg-arg-offsets '#.sb!vm::*register-arg-offsets*)
;;;; MAKE-BOGUS-LRA (used for :FUN-END breakpoints)
(defconstant bogus-lra-constants
- #!-x86 2 #!+x86 3)
+ #!-(or x86 x86-64) 2 #!+(or x86 x86-64) 3)
(defconstant known-return-p-slot
- (+ sb!vm:code-constants-offset #!-x86 1 #!+x86 2))
+ (+ sb!vm:code-constants-offset #!-(or x86 x86-64) 1 #!+(or x86 x86-64) 2))
;;; Make a bogus LRA object that signals a breakpoint trap when
;;; returned to. If the breakpoint trap handler returns, REAL-LRA is
;;; instruction.
(defun make-bogus-lra (real-lra &optional known-return-p)
(without-gcing
+ ;; 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-debug-info code-object) :bogus-lra)
(setf (code-header-ref code-object sb!vm:code-trace-table-offset-slot)
length)
- #!-x86
+ #!-(or x86 x86-64)
(setf (code-header-ref code-object real-lra-slot) real-lra)
- #!+x86
+ #!+(or x86 x86-64)
(multiple-value-bind (offset code) (compute-lra-data-from-pc real-lra)
(setf (code-header-ref code-object real-lra-slot) code)
(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:n-byte-bits))
+ (system-area-ub8-copy src-start 0 dst-start 0 length)
(sb!vm:sanctify-for-execution code-object)
- #!+x86
+ #!+(or x86 x86-64)
(values dst-start code-object (sap- trap-loc src-start))
- #!-x86
+ #!-(or x86 x86-64)
(let ((new-lra (make-lisp-obj (+ (sap-int dst-start)
sb!vm:other-pointer-lowtag))))
(set-header-data
;; (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 ~W"
- (compiled-code-location-kind loc)
- (compiled-code-location-pc loc))
- (sb!debug::print-code-location-source-form loc 0)
- (terpri)))))
projects / sbcl.git / blobdiff