Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv2091/src/code
Modified Files:
debug-int.lisp ppc-vm.lisp
Log Message:
0.8.13.5:
Fix backtrace on ppc. (Brian Downing sbcl-devel 2004-07-19)
... use BUG to report breakdown in logic;
... some tests fail on x86, so comment them out;
... untested as yet on non-x86 non-ppc.
Index: debug-int.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/debug-int.lisp,v
retrieving revision 1.79
retrieving revision 1.80
diff -u -d -r1.79 -r1.80
--- debug-int.lisp 29 Jun 2004 08:50:58 -0000 1.79
+++ debug-int.lisp 27 Jul 2004 11:16:18 -0000 1.80
@@ -948,24 +948,42 @@
(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)))
+ (- (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)
+ #!+(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)))
+ (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
@@ -975,6 +993,25 @@
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
+ ;; This conditional logic should probably go into
+ ;; architecture specific files somehow.
+ #!+ppc (sap-int (sb!vm::context-lr scp))
+ #!-(or ppc) (- (sb!vm:context-register scp sb!vm::lra-offset)
+ sb!vm:other-pointer-lowtag))
+ (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
;;; undefined-function.
Index: ppc-vm.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/ppc-vm.lisp,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -d -r1.9 -r1.10
--- ppc-vm.lisp 29 Jul 2003 13:01:55 -0000 1.9
+++ ppc-vm.lisp 27 Jul 2004 11:16:18 -0000 1.10
@@ -86,6 +86,13 @@
(declare (type (alien (* os-context-t)) context))
(deref (context-register-addr context index)))
+(define-alien-routine ("os_context_lr_addr" context-lr-addr) (* unsigned-long)
+ (context (* os-context-t)))
+
+(defun context-lr (context)
+ (declare (type (alien (* os-context-t)) context))
+ (int-sap (deref (context-lr-addr context))))
+
(defun %set-context-register (context index new)
(declare (type (alien (* os-context-t)) context))
(setf (deref (context-register-addr context index))
|