(let ((fp (frame-pointer frame)))
(when (control-stack-pointer-valid-p fp)
#!+(or x86 x86-64)
- (multiple-value-bind (ra ofp) (x86-call-context fp)
+ (multiple-value-bind (ra ofp) (x86-call-context fp)
(and ra (compute-calling-frame ofp ra frame)))
- #!-(or x86 x86-64)
+ #!-(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.
-#!-(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))
- (let ((pointer (frame-pointer frame))
- (escaped (compiled-frame-escaped frame)))
- (if escaped
- (sub-access-debug-var-slot pointer loc escaped)
- (stack-ref pointer stack-slot))))
-#!+(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))
(escaped (compiled-frame-escaped frame)))
(if escaped
(sub-access-debug-var-slot pointer loc escaped)
+ #!-(or x86 x86-64)
+ (stack-ref pointer stack-slot)
+ #!+(or x86 x86-64)
(ecase stack-slot
(#.ocfp-save-offset
(stack-ref pointer stack-slot))
(sap-ref-sap pointer (- (* (1+ stack-slot)
sb!vm::n-word-bytes))))))))
-#!-(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))
- (let ((pointer (frame-pointer frame))
- (escaped (compiled-frame-escaped frame)))
- (if escaped
- (sub-set-debug-var-slot pointer loc value escaped)
- (setf (stack-ref pointer stack-slot) value))))
-
-#!+(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))
(escaped (compiled-frame-escaped frame)))
(if escaped
(sub-set-debug-var-slot pointer loc value escaped)
+ #!-(or x86 x86-64)
+ (setf (stack-ref pointer stack-slot) value)
+ #!+(or x86 x86-64)
(ecase stack-slot
(#.ocfp-save-offset
(setf (stack-ref pointer stack-slot) value))
escaped)
(if up-frame (1+ (frame-number up-frame)) 0)
escaped))))))
+
#!+(or x86 x86-64)
(defun compute-calling-frame (caller ra up-frame)
(declare (type system-area-pointer caller ra))
;;; Find the code object corresponding to the object represented by
;;; bits and return it. We assume bogus functions correspond to the
;;; undefined-function.
+#!-(or x86 x86-64)
(defun code-object-from-bits (bits)
(declare (type (unsigned-byte 32) bits))
(let ((object (make-lisp-obj bits)))
(or (fun-code-header object)
:undefined-function)
(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)
- ((= widetag sb!vm:return-pc-header-widetag)
- (lra-code-header object))
- (t
- nil))))))))
+ (when (= lowtag sb!vm:other-pointer-lowtag)
+ (let ((widetag (widetag-of object)))
+ (cond ((= widetag sb!vm:code-header-widetag)
+ object)
+ ((= widetag sb!vm:return-pc-header-widetag)
+ (lra-code-header object))
+ (t
+ nil))))))))
\f
;;;; frame utilities
;;; returns the overwritten bits. You must call this in a context in
;;; which GC is disabled, so that Lisp doesn't move objects around
;;; that C is pointing to.
-(sb!alien:define-alien-routine "breakpoint_install" sb!alien:unsigned-long
+(sb!alien:define-alien-routine "breakpoint_install" sb!alien:unsigned-int
(code-obj sb!alien:unsigned-long)
(pc-offset sb!alien:int))
(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))
+ (old-inst sb!alien:unsigned-int))
(sb!alien:define-alien-routine "breakpoint_do_displaced_inst" sb!alien:void
(scp (* os-context-t))
- (orig-inst sb!alien:unsigned-long))
+ (orig-inst sb!alien:unsigned-int))
;;;; breakpoint handlers (layer between C and exported interface)
;; no more breakpoints active at this location, then the normal
;; instruction has been put back, and we do not need to
;; DO-DISPLACED-INST.
- (let ((data (breakpoint-data component offset nil)))
- (when (and data (breakpoint-data-breakpoints data))
- ;; The breakpoint is still active, so we need to execute the
- ;; displaced instruction and leave the breakpoint instruction
- ;; behind. The best way to do this is different on each machine,
- ;; so we just leave it up to the C code.
- (breakpoint-do-displaced-inst signal-context
- (breakpoint-data-instruction data))
- ;; Some platforms have no usable sigreturn() call. If your
- ;; implementation of arch_do_displaced_inst() _does_ sigreturn(),
- ;; it's polite to warn here
- #!+(and sparc solaris)
- (error "BREAKPOINT-DO-DISPLACED-INST returned?"))))
+ (setf data (breakpoint-data component offset nil))
+ (when (and data (breakpoint-data-breakpoints data))
+ ;; The breakpoint is still active, so we need to execute the
+ ;; displaced instruction and leave the breakpoint instruction
+ ;; behind. The best way to do this is different on each machine,
+ ;; so we just leave it up to the C code.
+ (breakpoint-do-displaced-inst signal-context
+ (breakpoint-data-instruction data))
+ ;; Some platforms have no usable sigreturn() call. If your
+ ;; implementation of arch_do_displaced_inst() _does_ sigreturn(),
+ ;; it's polite to warn here
+ #!+(and sparc solaris)
+ (error "BREAKPOINT-DO-DISPLACED-INST returned?")))
(defun invoke-breakpoint-hooks (breakpoints component offset)
(let* ((debug-fun (debug-fun-from-pc component offset))
projects / sbcl.git / blobdiff