0.8.3.21:

	Fix PPC floating point backend bugs
	... STFD moves a doubleword to the effective address.  Better not
		have that effective address be a 32-bit area
		(e.g. SINGLE-STACK) then

diff --git a/BUGS b/BUGS
index a20b8ff..545ec9c 100644 (file)
--- a/BUGS
+++ b/BUGS
@@ -1205,3 +1205,28 @@ WORKAROUND:
   There are lots of special variables in SBCL, and I feel sure that at
   least some of them are indicative of potentially thread-unsafe 
   parts of the system.  See doc/internals/notes/threading-specials
+
+285: PPC randomness
+  In SBCL 0.8.3.1x on a powerpc running Linux (dunno if Darwin is
+    similarly affected):
+  * (dotimes (i 100) (random 1663553320000000))
+
+  NIL
+  * (dotimes (i 100) (random 1663553340000000))
+
+  NIL
+  * (dotimes (i 100) (random 1663553350000000))
+
+  debugger invoked on condition of type TYPE-ERROR:
+    The value -30653269094906
+      is not of type
+      (OR (SINGLE-FLOAT 0.0) (DOUBLE-FLOAT 0.0d0) (RATIONAL 0)).
+
+    and, weirdly, the frame is:
+  ("hairy arg processor for top level local call RANDOM"
+   1663553347392000
+   #S(RANDOM-STATE
+      :STATE #(0 2567483615 188 1503590015 2333049409 322761517 ...)))
+
+  (the type error doesn't seem to be terribly deterministic in when it
+  occurs.  Bigger numbers seem better able to trigger the error)

diff --git a/NEWS b/NEWS
index 97fb78a..9e14331 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -2013,6 +2013,9 @@ changes in sbcl-0.8.4 relative to sbcl-0.8.3:
     combination.  (reported by Andreas Fuchs)
   * bug fix: RUN-PROGRAM now does not fail if some element in $PATH
     names a non-existent directory.  (thanks to Andreas Fuchs)
+  * bug fix: ROUND and TRUNCATE could, under certain circumstances on
+    the PPC platform, lead to stack corruption; this has been fixed.
+    (reported by Rainer Joswig)
   * optimization: restored some effective method precomputation in
     CLOS (turned off by an ANSI fix in sbcl-0.8.3); the amount of
     precomputation is now tunable.

diff --git a/src/compiler/ppc/float.lisp b/src/compiler/ppc/float.lisp
index ed7bdaa..d2bd56f 100644 (file)
--- a/src/compiler/ppc/float.lisp
+++ b/src/compiler/ppc/float.lisp
@@ -502,8 +502,7 @@
                (:args (x :scs (,from-sc) :target temp))
                (:temporary (:from (:argument 0) :sc single-reg) temp)
                (:temporary (:scs (double-stack)) stack-temp)
-               (:results (y :scs (signed-reg)
-                            :load-if (not (sc-is y signed-stack))))
+               (:results (y :scs (signed-reg)))
                (:arg-types ,from-type)
                (:result-types signed-num)
                (:translate ,trans)
@@ -514,22 +513,15 @@
                (:generator 5
                  (note-this-location vop :internal-error)
                  (inst ,inst temp x)
-                 (sc-case y
-                   (signed-stack
-                    (inst stfd temp (current-nfp-tn vop)
-                          (* (tn-offset y) sb!vm:n-word-bytes)))
-                   (signed-reg
-                    (inst stfd temp (current-nfp-tn vop)
-                          (* (tn-offset stack-temp) sb!vm:n-word-bytes))
-                    (inst lwz y (current-nfp-tn vop)
-                          (+ 4 (* (tn-offset stack-temp) sb!vm:n-word-bytes)))))))))
+                 (inst stfd temp (current-nfp-tn vop)
+                       (* (tn-offset stack-temp) sb!vm:n-word-bytes))
+                 (inst lwz y (current-nfp-tn vop)
+                       (+ 4 (* (tn-offset stack-temp) sb!vm:n-word-bytes)))))))
   (frob %unary-truncate single-reg single-float fctiwz)
   (frob %unary-truncate double-reg double-float fctiwz)
   (frob %unary-round single-reg single-float fctiw)
   (frob %unary-round double-reg double-float fctiw))
 
-
-
 (define-vop (make-single-float)
   (:args (bits :scs (signed-reg) :target res
               :load-if (not (sc-is bits signed-stack))))
@@ -624,69 +616,50 @@
 (define-vop (double-float-high-bits)
   (:args (float :scs (double-reg descriptor-reg)
                :load-if (not (sc-is float double-stack))))
-  (:results (hi-bits :scs (signed-reg)
-                    :load-if (or (sc-is float descriptor-reg double-stack)
-                                 (not (sc-is hi-bits signed-stack)))))
-  (:temporary (:scs (signed-stack)) stack-temp)
+  (:results (hi-bits :scs (signed-reg)))
+  (:temporary (:scs (double-stack)) stack-temp)
   (:arg-types double-float)
   (:result-types signed-num)
   (:translate double-float-high-bits)
   (:policy :fast-safe)
   (:vop-var vop)
   (:generator 5
-    (sc-case hi-bits
-      (signed-reg
-       (sc-case float
-        (double-reg
-         (inst stfd float (current-nfp-tn vop)
-               (* (tn-offset stack-temp) sb!vm:n-word-bytes))
-         (inst lwz hi-bits (current-nfp-tn vop)
-               (* (tn-offset stack-temp) sb!vm:n-word-bytes)))
-        (double-stack
-         (inst lwz hi-bits (current-nfp-tn vop)
-               (* (tn-offset float) sb!vm:n-word-bytes)))
-        (descriptor-reg
-         (loadw hi-bits float sb!vm:double-float-value-slot
-                sb!vm:other-pointer-lowtag))))
-      (signed-stack
-       (sc-case float
-        (double-reg
-         (inst stfd float (current-nfp-tn vop)
-               (* (tn-offset hi-bits) sb!vm:n-word-bytes))))))))
+    (sc-case float
+      (double-reg
+       (inst stfd float (current-nfp-tn vop)
+             (* (tn-offset stack-temp) sb!vm:n-word-bytes))
+       (inst lwz hi-bits (current-nfp-tn vop)
+             (* (tn-offset stack-temp) sb!vm:n-word-bytes)))
+      (double-stack
+       (inst lwz hi-bits (current-nfp-tn vop)
+             (* (tn-offset float) sb!vm:n-word-bytes)))
+      (descriptor-reg
+       (loadw hi-bits float sb!vm:double-float-value-slot
+              sb!vm:other-pointer-lowtag)))))
 
 (define-vop (double-float-low-bits)
   (:args (float :scs (double-reg descriptor-reg)
                :load-if (not (sc-is float double-stack))))
-  (:results (lo-bits :scs (unsigned-reg)
-                    :load-if (or (sc-is float descriptor-reg double-stack)
-                                 (not (sc-is lo-bits unsigned-stack)))))
-  (:temporary (:scs (unsigned-stack)) stack-temp)
+  (:results (lo-bits :scs (unsigned-reg)))
+  (:temporary (:scs (double-stack)) stack-temp)
   (:arg-types double-float)
   (:result-types unsigned-num)
   (:translate double-float-low-bits)
   (:policy :fast-safe)
   (:vop-var vop)
   (:generator 5
-    (sc-case lo-bits
-      (unsigned-reg
-       (sc-case float
-        (double-reg
-         (inst stfd float (current-nfp-tn vop)
-               (* (tn-offset stack-temp) sb!vm:n-word-bytes))
-         (inst lwz lo-bits (current-nfp-tn vop)
-               (* (1+ (tn-offset stack-temp)) sb!vm:n-word-bytes)))
-        (double-stack
-         (inst lwz lo-bits (current-nfp-tn vop)
-               (* (1+ (tn-offset float)) sb!vm:n-word-bytes)))
-        (descriptor-reg
-         (loadw lo-bits float (1+ sb!vm:double-float-value-slot)
-                sb!vm:other-pointer-lowtag))))
-      (unsigned-stack
-       (sc-case float
-        (double-reg
-         (inst stfd float (current-nfp-tn vop)
-               (* (tn-offset lo-bits) sb!vm:n-word-bytes))))))))
-
+    (sc-case float
+      (double-reg
+        (inst stfd float (current-nfp-tn vop)
+             (* (tn-offset stack-temp) sb!vm:n-word-bytes))
+       (inst lwz lo-bits (current-nfp-tn vop)
+             (* (1+ (tn-offset stack-temp)) sb!vm:n-word-bytes)))
+      (double-stack
+        (inst lwz lo-bits (current-nfp-tn vop)
+             (* (1+ (tn-offset float)) sb!vm:n-word-bytes)))
+      (descriptor-reg
+        (loadw lo-bits float (1+ sb!vm:double-float-value-slot)
+              sb!vm:other-pointer-lowtag)))))
 \f
 ;;;; Float mode hackery:
 

diff --git a/tests/print.impure.lisp b/tests/print.impure.lisp
index c5e6d61..69ff13c 100644 (file)
--- a/tests/print.impure.lisp
+++ b/tests/print.impure.lisp
@@ -129,5 +129,10 @@
 ;;; expanders.
 (funcall (formatter "~@<~A~:*~A~:>") nil 3)
 
+;;; the PPC floating point backend was at one point sufficiently
+;;; broken that this looped infinitely or caused segmentation
+;;; violations through stack corruption.
+(print 0.0001)
+
 ;;; success
 (quit :unix-status 104)

diff --git a/version.lisp-expr b/version.lisp-expr
index d1e0356..7d52788 100644 (file)
--- 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.3.20"
+"0.8.3.21"