(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))))
+ (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)))))
#!+x86
(sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer)
(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
4))))
(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)
+ (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)
+ (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
#!-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)
(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)
(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))
(/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
(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
+ (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))
- (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)))))))))))
+ ;; Check to see whether we were executing in a branch
+ ;; delay slot.
+ #!+(or pmax sgi) ; pmax only (and broken anyway)
+ (when (logbitp 31 (sb!alien:slot scp '%mips::sc-cause))
+ (incf pc-offset sb!vm:n-word-bytes))
+ (unless (<= 0 pc-offset
+ (* (code-header-ref code sb!vm:code-code-size-slot)
+ sb!vm:n-word-bytes))
+ ;; We were in an assembly routine. Therefore, use the
+ ;; LRA as the pc.
+ (setf pc-offset
+ (- (sb!vm:context-register scp sb!vm::lra-offset)
+ (get-lisp-obj-address code)
+ code-header-len)))
+ (return
+ (if (eq (%code-debug-info code) :bogus-lra)
+ (let ((real-lra (code-header-ref code
+ real-lra-slot)))
+ (values (lra-code-header real-lra)
+ (get-header-data real-lra)
+ nil))
+ (values code pc-offset scp))))))))))
;;; Find the code object corresponding to the object represented by
;;; bits and return it. We assume bogus functions correspond to the
(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
(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)))))
(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
(do ((frame frame (frame-down frame)))
((not frame) nil)
(when (and (compiled-frame-p frame)
- (#-x86 eq #+x86 sap=
+ (#!-x86 eq #!+x86 sap=
lra
(get-context-value frame lra-save-offset lra-sc-offset)))
(return t)))))
;;; returns the overwritten bits. You must call this in a context in
;;; which GC is disabled, so that Lisp doesn't move objects around
;;; that C is pointing to.
-(sb!alien:define-alien-routine "breakpoint_install" sb!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:define-alien-routine "breakpoint_remove" sb!c-call:void
- (code-obj sb!c-call:unsigned-long)
- (pc-offset sb!c-call:int)
- (old-inst sb!c-call:unsigned-long))
+(sb!alien: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:define-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)
;;; 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)
projects / sbcl.git / blobdiff