From 0b9304783ffb07853927ec7ab67378602d4f39b4 Mon Sep 17 00:00:00 2001
From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Thu, 1 Dec 2011 17:43:49 +0200
Subject: [PATCH] fix misoptimization of TRUNCATE

  Reported by Eric Marsden on sbcl-devel 2011-12-01.

   "illegal instruction on PowerPC"

  We check for result type being a VALUES-TYPE-P when deciding if to compute
  the second value for TRUNCATE or not -- but *WILD-TYPE* isn't a values type.

  Make VALUES-TYPE-P return true for it from now on. What could possibly go
  wrong? Just two other places need to change, it seems.
---
 NEWS                      |    1 +
 src/code/early-type.lisp  |    6 ++++++
 src/code/late-type.lisp   |    3 ++-
 src/compiler/ir2tran.lisp |    2 +-
 tests/compiler.pure.lisp  |   17 +++++++++++++++++
 5 files changed, 27 insertions(+), 2 deletions(-)

diff --git a/NEWS b/NEWS
index 77b045c..25969ee 100644
--- a/NEWS
+++ b/NEWS
@@ -13,6 +13,7 @@ changes relative to sbcl-1.0.54:
     account for signed zeros.
   * bug fix: compiler error when typechecking a call to a function with
     non-constant keyword arguments.
+  * bug fix: misoptimization of TRUNCATE causing erratic behaviour.
 
 changes in sbcl-1.0.54 relative to sbcl-1.0.53:
   * minor incompatible changes:
diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp
index 5b761c0..1b395f1 100644
--- a/src/code/early-type.lisp
+++ b/src/code/early-type.lisp
@@ -134,8 +134,14 @@
             (:include args-type
                       (class-info (type-class-or-lose 'values)))
             (:constructor %make-values-type)
+            (:predicate %values-type-p)
             (:copier nil)))
 
+(declaim (inline value-type-p))
+(defun values-type-p (x)
+  (or (eq x *wild-type*)
+      (%values-type-p x)))
+
 (defun-cached (make-values-type-cached
                :hash-bits 8
                :hash-function (lambda (req opt rest allowp)
diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 13e3368..d1eaa9e 100644
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -432,8 +432,9 @@
       1
       (values-type-max-value-count type)))
 
+;;; VALUES type with a single value.
 (defun type-single-value-p (type)
-  (and (values-type-p type)
+  (and (%values-type-p type)
        (not (values-type-rest type))
        (null (values-type-optional type))
        (singleton-p (values-type-required type))))
diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index 1674834..4a35b47 100644
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -667,7 +667,7 @@
   (let* ((type (node-derived-type call))
          (types
           (mapcar #'primitive-type
-                  (if (values-type-p type)
+                  (if (args-type-p type)
                       (append (args-type-required type)
                               (args-type-optional type))
                       (list type))))
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index eb60efd..2388091 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -4096,3 +4096,20 @@
                          (declare (type keyword p3))
                          (tree-equal p1 (cons 1 2) (the (member :test) p3) p4)))))
     (assert (funcall fun (cons 1.0 2.0) :test '=))))
+
+(with-test (:name :truncate-wild-values)
+  (multiple-value-bind (q r)
+      (handler-bind ((warning #'error))
+        (let ((sb-c::*check-consistency* t))
+          (funcall (compile nil
+                            `(lambda (a)
+                               (declare (type (member 1d0 2d0) a))
+                               (block return-value-tag
+                                 (funcall
+                                  (the function
+                                       (catch 'debug-catch-tag
+                                         (return-from return-value-tag
+                                           (progn (truncate a)))))))))
+                   2d0)))
+    (assert (eql 2 q))
+    (assert (eql 0d0 r))))
-- 
1.7.10.4