From aae2706b8a22e913bb354531687797450446ea81 Mon Sep 17 00:00:00 2001
From: Paul Khuong <pvk@pvk.ca>
Date: Fri, 24 May 2013 13:13:12 -0400
Subject: [PATCH] Even safer substitution of constants in CUT-TO-WIDTH

 * Fix another aspect of the modular arithmetic bug that was only
   partially fixed by ccd2a1d (Substitute constants with modular
   equivalents more safely); detected by the previous fix not
   working on !x86oids.
---
 src/compiler/ir1opt.lisp  |   12 ++++++++----
 src/compiler/ir1util.lisp |    4 ++--
 src/compiler/srctran.lisp |    3 ++-
 3 files changed, 12 insertions(+), 7 deletions(-)

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 838f284..7f44b64 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -289,16 +289,20 @@
 ;;; What we do is intersect RTYPE with NODE's DERIVED-TYPE. If the
 ;;; intersection is different from the old type, then we do a
 ;;; REOPTIMIZE-LVAR on the NODE-LVAR.
-(defun derive-node-type (node rtype)
+(defun derive-node-type (node rtype &key from-scratch)
   (declare (type valued-node node) (type ctype rtype))
-  (let ((node-type (node-derived-type node)))
-    (unless (eq node-type rtype)
+  (let* ((initial-type (node-derived-type node))
+         (node-type (if from-scratch
+                        *wild-type*
+                        initial-type)))
+    (unless (eq initial-type rtype)
       (let ((int (values-type-intersection node-type rtype))
             (lvar (node-lvar node)))
-        (when (type/= node-type int)
+        (when (type/= initial-type int)
           (when (and *check-consistency*
                      (eq int *empty-type*)
                      (not (eq rtype *empty-type*)))
+            (aver (not from-scratch))
             (let ((*compiler-error-context* node))
               (compiler-warn
                "New inferred type ~S conflicts with old type:~
diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index dc96f0c..7d9f2f3 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -1894,7 +1894,7 @@ is :ANY, the function name is not checked."
 ;;;; leaf hackery
 
 ;;; Change the LEAF that a REF refers to.
-(defun change-ref-leaf (ref leaf)
+(defun change-ref-leaf (ref leaf &key recklessly)
   (declare (type ref ref) (type leaf leaf))
   (unless (eq (ref-leaf ref) leaf)
     (push ref (leaf-refs leaf))
@@ -1909,7 +1909,7 @@ is :ANY, the function name is not checked."
                  (eq lvar (basic-combination-fun dest))
                  (csubtypep ltype (specifier-type 'function))))
           (setf (node-derived-type ref) vltype)
-          (derive-node-type ref vltype)))
+          (derive-node-type ref vltype :from-scratch recklessly)))
     (reoptimize-lvar (node-lvar ref)))
   (values))
 
diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index caed9bf..4fc7754 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -2933,7 +2933,8 @@
                                            (mask-signed-field width constant-value)
                                            (ldb (byte width 0) constant-value))))
                        (unless (= constant-value new-value)
-                         (change-ref-leaf node (make-constant new-value))
+                         (change-ref-leaf node (make-constant new-value)
+                                          :recklessly t)
                          (let ((lvar (node-lvar node)))
                            (setf (lvar-%derived-type lvar)
                                  (and (lvar-has-single-use-p lvar)
-- 
1.7.10.4