Fix cut-to-width in the presence of bad constants in dead code.

[sbcl.git] / src / compiler / srctran.lisp

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index b66f0f4..fa780c9 100644 (file)
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -242,7 +242,7 @@
    (t (values nil t))))
 (define-source-transform get (&rest args)
   (case (length args)
-   (2 `(sb!impl::get2 ,@args))
+   (2 `(sb!impl::get3 ,@args nil))
    (3 `(sb!impl::get3 ,@args))
    (t (values nil t))))
 
@@ -2522,7 +2522,7 @@
             `(mod ,base-char-code-limit)))
           (t
            (specifier-type
-            `(mod ,char-code-limit))))))
+            `(mod ,sb!xc:char-code-limit))))))
 
 (defoptimizer (code-char derive-type) ((code))
   (let ((type (lvar-type code)))
@@ -2955,7 +2955,7 @@
                  (setf (block-reoptimize (node-block node)) t)
                  (reoptimize-component (node-component node) :maybe))
                t)
-             (cut-node (node &aux did-something over-wide)
+             (cut-node (node)
                "Try to cut a node to width. The primary return value is
                 whether we managed to cut (cleverly), and the second whether
                 anything was changed.  The third return value tells whether
@@ -2967,9 +2967,13 @@
                   (typecase (ref-leaf node)
                     (constant
                      (let* ((constant-value (constant-value (ref-leaf node)))
-                            (new-value (if signedp
-                                           (mask-signed-field width constant-value)
-                                           (ldb (byte width 0) constant-value))))
+                            (new-value
+                              (cond ((not (integerp constant-value))
+                                     (return-from cut-node (values t nil)))
+                                    (signedp
+                                     (mask-signed-field width constant-value))
+                                    (t
+                                     (ldb (byte width 0) constant-value)))))
                        (cond ((= constant-value new-value)
                               (values t nil)) ; we knew what to do and did nothing
                              (t
@@ -3014,7 +3018,9 @@
                                                  (modular-fun-info-name modular-fun))
                                                 (function
                                                  (funcall modular-fun node width)))
-                                              :exit-if-null))
+                                              :exit-if-null)
+                                        (did-something nil)
+                                        (over-wide nil))
                                (unless (eql modular-fun :good)
                                  (setq did-something t
                                        over-wide t)
@@ -3185,7 +3191,7 @@
         ,(lvar-value x))
       (give-up-ir1-transform)))
 
-(dolist (x '(= char= + * logior logand logxor logtest))
+(dolist (x '(= char= two-arg-char-equal + * logior logand logxor logtest))
   (%deftransform x '(function * *) #'commutative-arg-swap
                  "place constant arg last"))
 
@@ -3707,7 +3713,8 @@
 \f
 ;;;; character operations
 
-(deftransform char-equal ((a b) (base-char base-char))
+(deftransform two-arg-char-equal ((a b) (base-char base-char) *
+                                  :policy (> speed space))
   "open code"
   '(let* ((ac (char-code a))
           (bc (char-code b))
@@ -3719,6 +3726,19 @@
                  (and (> sum 415) (< sum 461))
                  (and (> sum 463) (< sum 477))))))))
 
+(deftransform two-arg-char-equal ((a b) (* (constant-arg character)) *
+                                  :node node)
+  (let ((char (lvar-value b)))
+    (if (both-case-p char)
+        (let ((reverse (if (upper-case-p char)
+                           (char-downcase char)
+                           (char-upcase char))))
+          (if (policy node (> speed space))
+              `(or (char= a ,char)
+                   (char= a ,reverse))
+              `(char-equal-constant a ,char ,reverse)))
+        '(char= a b))))
+
 (deftransform char-upcase ((x) (base-char))
   "open code"
   '(let ((n-code (char-code x)))