From 78689792e8f8d20b3b931f508f3a9eca81b64f1f Mon Sep 17 00:00:00 2001
From: Christophe Rhodes <csr21@cam.ac.uk>
Date: Mon, 2 Aug 2004 12:29:29 +0000
Subject: [PATCH 1/1] 0.8.13.17: 	Merge partly-working fix for bug 61 
 ... I think this fixes it on sparc, ppc and maybe mips.
 	... alpha is broken because it seems that just
 about every 		backtrace has a "bogus stack
 frame", maybe arising from 		the PAL stuff? 
 Dunno. 	... x86 is broken because, well, erm,
 dunno.

---
 BUGS                            |   10 ++++++++++
 src/assembly/alpha/support.lisp |   13 +++++--------
 src/assembly/hppa/support.lisp  |   16 ++++++++++++++--
 src/assembly/mips/support.lisp  |   24 ++++++++++++++++--------
 src/assembly/ppc/support.lisp   |   22 ++++++++++++++++------
 src/assembly/sparc/support.lisp |   14 +++++---------
 src/assembly/x86/support.lisp   |    8 ++------
 src/code/debug-int.lisp         |   21 +++++++--------------
 src/compiler/alpha/arith.lisp   |    2 ++
 tests/debug.impure.lisp         |   25 ++++++++++++++++---------
 version.lisp-expr               |    2 +-
 11 files changed, 94 insertions(+), 63 deletions(-)

diff --git a/BUGS b/BUGS
index c04e31c..4d5e3b4 100644
--- a/BUGS
+++ b/BUGS
@@ -167,6 +167,12 @@ WORKAROUND:
   then requesting a BACKTRACE at the debugger prompt gives no information
   about where in the user program the problem occurred.
 
+  (this is apparently mostly fixed on the SPARC and PPC architectures:
+  while giving the backtrace the system complains about "unknown
+  source location: using block start", but apart from that the
+  backtrace seems reasonable.  See tests/debug.impure.lisp for a test
+  case)
+
 64:
   Using the pretty-printer from the command prompt gives funny
   results, apparently because the pretty-printer doesn't know
@@ -1581,3 +1587,7 @@ WORKAROUND:
   Downing fixed most of the problems on non-x86 architectures, but on
   the x86 the backtrace from this evaluation does not reveal anything
   about the problem.  (See tests in debug.impure.lisp)
+
+346: alpha backtrace
+  In sbcl-0.8.13, all backtraces from errors caused by internal errors
+  on the alpha seem to have a "bogus stack frame".
diff --git a/src/assembly/alpha/support.lisp b/src/assembly/alpha/support.lisp
index df556e4..a2ef297 100644
--- a/src/assembly/alpha/support.lisp
+++ b/src/assembly/alpha/support.lisp
@@ -13,7 +13,7 @@
 
 (!def-vm-support-routine generate-call-sequence (name style vop)
   (ecase style
-    (:raw
+    ((:raw :none)
      (values
       `((inst li (make-fixup ',name :assembly-routine) temp)
 	(inst jsr lip-tn temp))
@@ -50,13 +50,7 @@
 	  (:temporary (:scs (control-stack) :offset nfp-save-offset)
 		      ,nfp-save)
 	  (:temporary (:scs (non-descriptor-reg)) temp1)
-	  (:save-p t)))))
-    (:none
-     (values
-      `((inst li (make-fixup ',name :assembly-routine) temp)
-	(inst jsr lip-tn temp (make-fixup ',name :assembly-routine)))
-      '((:temporary (:scs (non-descriptor-reg)) temp))
-      nil))))
+	  (:save-p t)))))))
 
 (!def-vm-support-routine generate-return-sequence (style)
   (ecase style
@@ -69,3 +63,6 @@
 				    :offset lra-offset)
 		    lip-tn :offset 2)))
     (:none)))
+
+(defun return-machine-address (scp)
+  (context-register scp lip-offset))
diff --git a/src/assembly/hppa/support.lisp b/src/assembly/hppa/support.lisp
index 18f8b8f..4d7d53f 100644
--- a/src/assembly/hppa/support.lisp
+++ b/src/assembly/hppa/support.lisp
@@ -1,5 +1,15 @@
-(in-package "SB!VM")
+;;;; the machine-specific support routines needed by the file assembler
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
 
+(in-package "SB!VM")
 
 (!def-vm-support-routine generate-call-sequence (name style vop)
   (ecase style
@@ -49,7 +59,6 @@
 	`((:temporary (:scs (any-reg) :from (:eval 0) :to (:eval 1))
 		      ,fixup)))))))
 
-
 (!def-vm-support-routine generate-return-sequence (style)
   (ecase style
     (:raw
@@ -60,3 +69,6 @@
 				    :offset lra-offset)
 		    :offset 1)))
     (:none)))
+
+(defun return-machine-address (scp)
+  (context-register scp lip-offset))
diff --git a/src/assembly/mips/support.lisp b/src/assembly/mips/support.lisp
index c91d8c7..2bad731 100644
--- a/src/assembly/mips/support.lisp
+++ b/src/assembly/mips/support.lisp
@@ -1,8 +1,19 @@
+;;;; the machine-specific support routines needed by the file assembler
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
 (in-package "SB!VM")
 
 (!def-vm-support-routine generate-call-sequence (name style vop)
   (ecase style
-    (:raw
+    ((:raw :none)
      (values
       `((inst jal (make-fixup ',name :assembly-routine))
 	(inst nop))
@@ -36,13 +47,7 @@
 		      ,lra)
 	  (:temporary (:scs (control-stack) :offset nfp-save-offset)
 		      ,nfp-save)
-	  (:save-p t)))))
-    (:none
-     (values
-      `((inst j (make-fixup ',name :assembly-routine))
-	(inst nop))
-      nil))))
-
+	  (:save-p t)))))))
 
 (!def-vm-support-routine generate-return-sequence (style)
   (ecase style
@@ -56,3 +61,6 @@
 				    :offset lra-offset)
 		    lip-tn :offset 2)))
     (:none)))
+
+(defun return-machine-address (scp)
+  (context-register scp lip-offset))
diff --git a/src/assembly/ppc/support.lisp b/src/assembly/ppc/support.lisp
index 3d736ac..512e4c1 100644
--- a/src/assembly/ppc/support.lisp
+++ b/src/assembly/ppc/support.lisp
@@ -1,8 +1,19 @@
+;;;; the machine-specific support routines needed by the file assembler
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
 (in-package "SB!VM")
 
 (!def-vm-support-routine generate-call-sequence (name style vop)
   (ecase style
-    (:raw
+    ((:raw :none)
      (values 
       `((inst bla (make-fixup ',name :assembly-routine)))
       `()))
@@ -34,11 +45,7 @@
 	   ,lra)
 	  (:temporary (:scs (control-stack) :offset nfp-save-offset)
 	   ,nfp-save)
-	  (:save-p :compute-only)))))
-    (:none
-     (values 
-      `((inst ba  (make-fixup ',name :assembly-routine)))
-      `()))))
+	  (:save-p :compute-only)))))))
 
 (!def-vm-support-routine generate-return-sequence (style)
   (ecase style
@@ -53,3 +60,6 @@
 		                    :offset lip-offset)
 		    :offset 2)))
     (:none)))
+
+(defun return-machine-address (scp)
+  (sap-int (context-lr scp)))
diff --git a/src/assembly/sparc/support.lisp b/src/assembly/sparc/support.lisp
index d5a1532..42d4f0d 100644
--- a/src/assembly/sparc/support.lisp
+++ b/src/assembly/sparc/support.lisp
@@ -13,7 +13,7 @@
 
 (!def-vm-support-routine generate-call-sequence (name style vop)
   (ecase style
-    (:raw
+    ((:raw :none)
      (let ((temp (make-symbol "TEMP"))
 	   (lip (make-symbol "LIP")))
        (values 
@@ -52,14 +52,7 @@
 		      ,lra)
 	  (:temporary (:scs (control-stack) :offset nfp-save-offset)
 		      ,nfp-save)
-	  (:save-p :compute-only)))))
-    (:none
-     (let ((temp (make-symbol "TEMP")))
-       (values 
-	`((inst ji ,temp (make-fixup ',name :assembly-routine))
-	  (inst nop))
-	`((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1))
-		      ,temp)))))))
+	  (:save-p :compute-only)))))))
 
 (!def-vm-support-routine generate-return-sequence (style)
   (ecase style
@@ -76,3 +69,6 @@
 				    :offset lra-offset)
 		    :offset 2)))
     (:none)))
+
+(defun return-machine-address (scp)
+  (+ (context-register scp lip-offset) 8))
diff --git a/src/assembly/x86/support.lisp b/src/assembly/x86/support.lisp
index 6721471..4bb9167 100644
--- a/src/assembly/x86/support.lisp
+++ b/src/assembly/x86/support.lisp
@@ -11,7 +11,7 @@
 
 (!def-vm-support-routine generate-call-sequence (name style vop)
   (ecase style
-    (:raw
+    ((:raw :none)
      (values
       `((inst call (make-fixup ',name :assembly-routine)))
       nil))
@@ -21,11 +21,7 @@
 	(inst call (make-fixup ',name :assembly-routine))
 	(note-this-location ,vop :single-value-return)
 	(move esp-tn ebx-tn))
-      '((:save-p :compute-only))))
-    (:none
-     (values
-      `((inst jmp (make-fixup ',name :assembly-routine)))
-      nil))))
+      '((:save-p :compute-only))))))
 
 (!def-vm-support-routine generate-return-sequence (style)
   (ecase style
diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp
index 352f968..320c7c3 100644
--- a/src/code/debug-int.lisp
+++ b/src/code/debug-int.lisp
@@ -1002,20 +1002,13 @@
   "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))
-         #!+sparc (+ (sb!vm:context-register scp sb!vm::lip-offset) 8)
-         #!-(or ppc sparc) (- (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)))
+  (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
diff --git a/src/compiler/alpha/arith.lisp b/src/compiler/alpha/arith.lisp
index d62ac7d..f20275f 100644
--- a/src/compiler/alpha/arith.lisp
+++ b/src/compiler/alpha/arith.lisp
@@ -139,6 +139,8 @@
      ,@(when (and tagged-type (not arg-swap))
 	 `((define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM")
 			fast-fixnum-c-binop)
+	     (:args (x ,@(unless restore-fixnum-mask `(:target r)) 
+		       :scs (any-reg)))
 	     (:arg-types tagged-num (:constant ,tagged-type))
 	     ,@(when restore-fixnum-mask
 		 `((:temporary (:sc non-descriptor-reg) temp)))
diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp
index 7759cd4..9acd873 100644
--- a/tests/debug.impure.lisp
+++ b/tests/debug.impure.lisp
@@ -97,7 +97,7 @@
 ;;; Try it with and without tail call elimination, since they can have
 ;;; different effects.  (Specifically, if undefined_tramp is incorrect
 ;;; a stunted stack can result from the tail call variant.)
-#-x86 ; bug 345
+#-(or alpha x86) ; bug 345
 (progn
   (flet ((test-function ()
 	   (declare (optimize (speed 2) (debug 1))) ; tail call elimination
@@ -123,15 +123,22 @@
 ;;; the return value (to the flet or the enclosing top level form) is
 ;;; more than MOST-POSITIVE-FIXNUM with the current spaces on OS X.
 ;;; Enabling it might catch other problems, so do it anyway.
-(flet ((test-function ()
-         (declare (optimize (speed 1) (debug 2))) ; tail call elimination
-         (/ 42 0)))
-  (assert (verify-backtrace #'test-function '/)))
+#-alpha ; bug 346
+(progn
+  (flet ((test-function ()
+	   (declare (optimize (speed 1) (debug 2))) ; tail call elimination
+	   (/ 42 0)))
+    (assert (verify-backtrace #'test-function '/)))
+
+  (flet ((test-function ()
+	   (declare (optimize (speed 1) (debug 2))) ; no tail call elimination
+	   (/ 42 0)))
+    (assert (verify-backtrace #'test-function '/))))
 
-(flet ((test-function ()
-         (declare (optimize (speed 1) (debug 2))) ; no tail call elimination
-         (/ 42 0)))
-  (assert (verify-backtrace #'test-function '/)))
+#-(or x86 alpha) ; bug 61
+(defun throw-test ()
+  (throw 'no-such-tag t))
+(assert (verify-backtrace #'throw-test 'throw-test))
 
 ;;; success
 (quit :unix-status 104)
diff --git a/version.lisp-expr b/version.lisp-expr
index d9885d0..fa06b52 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.13.16"
+"0.8.13.17"
-- 
1.7.10.4