X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=b66f0f44e9373d3c2d5ef1b42753af6d92e86daa;hb=d01d509257052e694365b76be5ab597fa06764ec;hp=0d22154584167da326e779bc29f8d7c2960c4179;hpb=9ce27ba26f45c2d59e2f95b616bd5d8f3eaeffdc;p=sbcl.git

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 0d22154..b66f0f4 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -164,51 +164,39 @@
 ;;; (append x x x x sequence) => sequence
 ;;; (append fixnum x ...) => nil
 (defun derive-append-type (args)
-  (cond ((not args)
-         (specifier-type 'null))
-        (t
-         (let ((cons-type (specifier-type 'cons))
-               (null-type (specifier-type 'null))
-               (list-type (specifier-type 'list))
-               (last (lvar-type (car (last args)))))
-           (or
-            ;; Check that all but the last arguments are lists first
-            (loop for (arg next) on args
-                  while next
-                  do
-                  (let ((lvar-type (lvar-type arg)))
-                    (unless (or (csubtypep list-type lvar-type)
-                                (csubtypep lvar-type list-type))
+  (when (null args)
+    (return-from derive-append-type (specifier-type 'null)))
+  (let* ((cons-type (specifier-type 'cons))
+         (null-type (specifier-type 'null))
+         (list-type (specifier-type 'list))
+         (last (lvar-type (car (last args)))))
+    ;; Derive the actual return type, assuming that all but the last
+    ;; arguments are LISTs (otherwise, APPEND/NCONC doesn't return).
+    (loop with all-nil = t       ; all but the last args are NIL?
+          with some-cons = nil   ; some args are conses?
+          for (arg next) on args
+          for lvar-type = (type-approx-intersection2 (lvar-type arg)
+                                                     list-type)
+          while next
+          do (multiple-value-bind (typep definitely)
+                 (ctypep nil lvar-type)
+               (cond ((type= lvar-type *empty-type*)
+                      ;; type mismatch! insert an inline check that'll cause
+                      ;; compile-time warnings.
                       (assert-lvar-type arg list-type
-                                        (lexenv-policy *lexenv*))
-                      (return *empty-type*))))
-            (loop with all-nil = t
-                  for (arg next) on args
-                  for lvar-type = (lvar-type arg)
-                  while next
-                  do
-                  (cond
-                    ;; Cons in the middle guarantees the result will be a cons
-                    ((csubtypep lvar-type cons-type)
-                     (return cons-type))
-                    ;; If all but the last are NIL the type of the last arg
-                    ;; can be used
-                    ((csubtypep lvar-type null-type))
-                    (all-nil
-                     (setf all-nil nil)))
-                  finally
-                  (return
-                    (cond (all-nil
-                           last)
-                          ((csubtypep last cons-type)
-                           cons-type)
-                          ((csubtypep last list-type)
-                           list-type)
-                          ;; If the last is SEQUENCE (or similar) it'll
-                          ;; be either that sequence or a cons, which is a
-                          ;; sequence
-                          ((csubtypep list-type last)
-                           last)))))))))
+                                        (lexenv-policy *lexenv*)))
+                     (some-cons) ; we know result's a cons -- nothing to do
+                     ((and (not typep) definitely) ; can't be NIL
+                      (setf some-cons t))          ; must be a CONS
+                     (all-nil
+                      (setf all-nil (csubtypep lvar-type null-type)))))
+          finally
+             ;; if some of the previous arguments are CONSes so is the result;
+             ;; if all the previous values are NIL, we're a fancy identity;
+             ;; otherwise, could be either
+             (return (cond (some-cons cons-type)
+                           (all-nil last)
+                           (t (type-union last cons-type)))))))
 
 (defoptimizer (append derive-type) ((&rest args))
   (derive-append-type args))
@@ -2776,7 +2764,98 @@
               (specifier-type `(signed-byte ,size-high))
               *universal-type*))
         *universal-type*)))
+
+;;; Rightward ASH
+#!+ash-right-vops
+(progn
+  (defun %ash/right (integer amount)
+    (ash integer (- amount)))
+
+  (deftransform ash ((integer amount))
+    "Convert ASH of signed word to %ASH/RIGHT"
+    (unless (and (csubtypep (lvar-type integer) ; do that ourselves to avoid
+                            (specifier-type 'sb!vm:signed-word)) ; optimization
+                 (csubtypep (lvar-type amount)  ; notes.
+                            (specifier-type '(integer * 0))))
+      (give-up-ir1-transform))
+    (when (constant-lvar-p amount)
+      (give-up-ir1-transform))
+    (let ((use (lvar-uses amount)))
+      (cond ((and (combination-p use)
+                  (eql '%negate (lvar-fun-name (combination-fun use))))
+             (splice-fun-args amount '%negate 1)
+             `(lambda (integer amount)
+                (declare (type unsigned-byte amount))
+                (%ash/right integer (if (>= amount ,sb!vm:n-word-bits)
+                                        ,(1- sb!vm:n-word-bits)
+                                        amount))))
+            (t
+             `(%ash/right integer (if (<= amount ,(- sb!vm:n-word-bits))
+                                      ,(1- sb!vm:n-word-bits)
+                                      (- amount)))))))
+
+  (deftransform ash ((integer amount))
+    "Convert ASH of word to %ASH/RIGHT"
+    (unless (and (csubtypep (lvar-type integer)
+                            (specifier-type 'sb!vm:word))
+                 (csubtypep (lvar-type amount)
+                            (specifier-type '(integer * 0))))
+      (give-up-ir1-transform))
+    (when (constant-lvar-p amount)
+      (give-up-ir1-transform))
+    (let ((use (lvar-uses amount)))
+      (cond ((and (combination-p use)
+                  (eql '%negate (lvar-fun-name (combination-fun use))))
+             (splice-fun-args amount '%negate 1)
+             `(lambda (integer amount)
+                (declare (type unsigned-byte amount))
+                (if (>= amount ,sb!vm:n-word-bits)
+                    0
+                    (%ash/right integer amount))))
+            (t
+             `(if (<= amount ,(- sb!vm:n-word-bits))
+                  0
+                  (%ash/right integer (- amount)))))))
+
+  (deftransform %ash/right ((integer amount) (integer (constant-arg unsigned-byte)))
+    "Convert %ASH/RIGHT by constant back to ASH"
+    `(ash integer ,(- (lvar-value amount))))
+
+  (deftransform %ash/right ((integer amount) * * :node node)
+    "strength reduce large variable right shift"
+    (let ((return-type (single-value-type (node-derived-type node))))
+      (cond ((type= return-type (specifier-type '(eql 0)))
+             0)
+            ((type= return-type (specifier-type '(eql -1)))
+             -1)
+            ((csubtypep return-type (specifier-type '(member -1 0)))
+             `(ash integer ,(- sb!vm:n-word-bits)))
+            (t
+             (give-up-ir1-transform)))))
+
+  (defun %ash/right-derive-type-aux (n-type shift same-arg)
+    (declare (ignore same-arg))
+    (or (and (or (csubtypep n-type (specifier-type 'sb!vm:signed-word))
+                 (csubtypep n-type (specifier-type 'word)))
+             (csubtypep shift (specifier-type `(mod ,sb!vm:n-word-bits)))
+             (let ((n-low (numeric-type-low n-type))
+                   (n-high (numeric-type-high n-type))
+                   (s-low (numeric-type-low shift))
+                   (s-high (numeric-type-high shift)))
+               (make-numeric-type :class 'integer :complexp :real
+                                  :low (when n-low
+                                         (if (minusp n-low)
+                                             (ash n-low (- s-low))
+                                             (ash n-low (- s-high))))
+                                  :high (when n-high
+                                          (if (minusp n-high)
+                                              (ash n-high (- s-high))
+                                              (ash n-high (- s-low)))))))
+        *universal-type*))
 
+  (defoptimizer (%ash/right derive-type) ((n shift))
+    (two-arg-derive-type n shift #'%ash/right-derive-type-aux #'%ash/right))
+  )
 
 ;;; Modular functions
 
@@ -2841,9 +2920,48 @@
                (setf (node-reoptimize node) t)
                (setf (block-reoptimize (node-block node)) t)
                (reoptimize-component (node-component node) :maybe))
-             (cut-node (node &aux did-something)
+             (insert-lvar-cut (lvar)
+               "Insert a LOGAND/MASK-SIGNED-FIELD to cut the value of LVAR
+                to the required bit width. Returns T if any change was made.
+
+                When the destination of LVAR will definitely cut LVAR's value
+                to width (i.e. it's a logand or mask-signed-field with constant
+                other argument), do nothing. Otherwise, splice LOGAND/M-S-F in."
+               (binding* ((dest (lvar-dest lvar) :exit-if-null)
+                          (nil  (combination-p dest) :exit-if-null)
+                          (name (lvar-fun-name (combination-fun dest) t))
+                          (args (combination-args dest)))
+                 (case name
+                   (logand
+                    (when (= 2 (length args))
+                      (let ((other (if (eql (first args) lvar)
+                                       (second args)
+                                       (first args))))
+                        (when (and (constant-lvar-p other)
+                                   (ctypep (lvar-value other) type)
+                                   (not signedp))
+                          (return-from insert-lvar-cut)))))
+                   (mask-signed-field
+                    (when (and signedp
+                               (eql lvar (second args))
+                               (constant-lvar-p (first args))
+                               (<= (lvar-value (first args)) width))
+                      (return-from insert-lvar-cut)))))
+               (filter-lvar lvar
+                            (if signedp
+                                `(mask-signed-field ,width 'dummy)
+                                `(logand 'dummy ,(ldb (byte width 0) -1))))
+               (do-uses (node lvar)
+                 (setf (block-reoptimize (node-block node)) t)
+                 (reoptimize-component (node-component node) :maybe))
+               t)
+             (cut-node (node &aux did-something over-wide)
+               "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
+                the cut value might be wider than expected."
                (when (block-delete-p (node-block node))
-                 (return-from cut-node))
+                 (return-from cut-node (values t nil)))
                (typecase node
                  (ref
                   (typecase (ref-leaf node)
@@ -2852,75 +2970,100 @@
                             (new-value (if signedp
                                            (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))
-                         (let ((lvar (node-lvar node)))
-                           (setf (lvar-%derived-type lvar)
-                                 (and (lvar-has-single-use-p lvar)
-                                      (make-values-type :required (list (ctype-of new-value))))))
-                         (setf (block-reoptimize (node-block node)) t)
-                         (reoptimize-component (node-component node) :maybe)
-                         t)))
-                    (lambda-var
-                     (binding* ((dest (lvar-dest lvar) :exit-if-null)
-                                (nil  (combination-p dest) :exit-if-null)
-                                (name (lvar-fun-name (combination-fun dest))))
-                       ;; we're about to insert an m-s-f/logand between a ref to
-                       ;; a variable and another m-s-f/logand. No point in doing
-                       ;; that; the parent m-s-f/logand was already cut to width
-                       ;; anyway.
-                       (unless (or (cond (signedp
-                                          (and (eql name 'mask-signed-field)
-                                               (eql lvar (second
-                                                          (combination-args
-                                                           dest)))))
-                                         (t
-                                          (eql name 'logand)))
-                                   (csubtypep (lvar-type lvar) type))
-                         (filter-lvar lvar
-                                      (if signedp
-                                          `(mask-signed-field ,width 'dummy)
-                                          `(logand 'dummy ,(ldb (byte width 0) -1))))
-                         (setf (block-reoptimize (node-block node)) t)
-                         (reoptimize-component (node-component node) :maybe)
-                         t)))))
+                       (cond ((= constant-value new-value)
+                              (values t nil)) ; we knew what to do and did nothing
+                             (t
+                              (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)
+                                           (make-values-type :required (list (ctype-of new-value))))))
+                              (setf (block-reoptimize (node-block node)) t)
+                              (reoptimize-component (node-component node) :maybe)
+                              (values t t)))))))
                  (combination
                   (when (eq (basic-combination-kind node) :known)
                     (let* ((fun-ref (lvar-use (combination-fun node)))
                            (fun-name (lvar-fun-name (combination-fun node)))
                            (modular-fun (find-modular-version fun-name kind
                                                               signedp width)))
-                      (when (and modular-fun
-                                 (not (and (eq fun-name 'logand)
-                                           (csubtypep
-                                            (single-value-type (node-derived-type node))
-                                            type))))
-                        (binding* ((name (etypecase modular-fun
-                                           ((eql :good) fun-name)
-                                           (modular-fun-info
-                                            (modular-fun-info-name modular-fun))
-                                           (function
-                                            (funcall modular-fun node width)))
-                                         :exit-if-null))
-                          (unless (eql modular-fun :good)
-                            (setq did-something t)
-                            (change-ref-leaf
-                             fun-ref
-                             (find-free-fun name "in a strange place"))
-                            (setf (combination-kind node) :full))
-                          (unless (functionp modular-fun)
-                            (dolist (arg (basic-combination-args node))
-                              (when (cut-lvar arg)
-                                (setq did-something t))))
-                          (when did-something
-                            (reoptimize-node node name))
-                          did-something)))))))
-             (cut-lvar (lvar &aux did-something)
+                      (cond ((not modular-fun)
+                             ;; don't know what to do here
+                             (values nil nil))
+                            ((let ((dtype (single-value-type
+                                           (node-derived-type node))))
+                               (and
+                                (case fun-name
+                                  (logand
+                                   (csubtypep dtype
+                                              (specifier-type 'unsigned-byte)))
+                                  (logior
+                                   (csubtypep dtype
+                                              (specifier-type '(integer * 0))))
+                                  (mask-signed-field
+                                   t)
+                                  (t nil))
+                                (csubtypep dtype type)))
+                             ;; nothing to do
+                             (values t nil))
+                            (t
+                             (binding* ((name (etypecase modular-fun
+                                                ((eql :good) fun-name)
+                                                (modular-fun-info
+                                                 (modular-fun-info-name modular-fun))
+                                                (function
+                                                 (funcall modular-fun node width)))
+                                              :exit-if-null))
+                               (unless (eql modular-fun :good)
+                                 (setq did-something t
+                                       over-wide t)
+                                 (change-ref-leaf
+                                  fun-ref
+                                  (find-free-fun name "in a strange place"))
+                                 (setf (combination-kind node) :full))
+                               (unless (functionp modular-fun)
+                                 (dolist (arg (basic-combination-args node))
+                                   (multiple-value-bind (change wide)
+                                       (cut-lvar arg)
+                                     (setf did-something (or did-something change)
+                                           over-wide (or over-wide wide)))))
+                               (when did-something
+                                 (reoptimize-node node name))
+                               (values t did-something over-wide)))))))))
+             (cut-lvar (lvar &key head
+                        &aux did-something must-insert over-wide)
+               "Cut all the LVAR's use nodes. If any of them wasn't handled
+                and its type is too wide for the operation we wish to perform
+                insert an explicit bit-width narrowing operation (LOGAND or
+                MASK-SIGNED-FIELD) between the LVAR (*) and its destination.
+                The narrowing operation might not be inserted if the LVAR's
+                destination is already such an operation, to avoid endless
+                recursion.
+
+                If we're at the head, forcibly insert a cut operation if the
+                result might be too wide.
+
+                (*) We can't easily do that for each node, and doing so might
+                result in code bloat, anyway. (I'm also not sure it would be
+                correct for complicated C/D FG)"
                (do-uses (node lvar)
-                 (when (cut-node node)
-                   (setq did-something t)))
-               did-something))
-      (cut-lvar lvar))))
+                 (multiple-value-bind (handled any-change wide)
+                     (cut-node node)
+                   (setf did-something (or did-something any-change)
+                         must-insert (or must-insert
+                                         (not (or handled
+                                                  (csubtypep (single-value-type
+                                                              (node-derived-type node))
+                                                             type))))
+                         over-wide (or over-wide wide))))
+               (when (or must-insert
+                         (and head over-wide))
+                 (setf did-something (or (insert-lvar-cut lvar) did-something)
+                       ;; we're just the right width after an explicit cut.
+                       over-wide nil))
+               (values did-something over-wide)))
+      (cut-lvar lvar :head t))))
 
 (defun best-modular-version (width signedp)
   ;; 1. exact width-matched :untagged
@@ -2928,7 +3071,10 @@
   ;; 3. >/>= width-matched :untagged
   (let* ((uuwidths (modular-class-widths *untagged-unsigned-modular-class*))
          (uswidths (modular-class-widths *untagged-signed-modular-class*))
-         (uwidths (merge 'list uuwidths uswidths #'< :key #'car))
+         (uwidths (if (and uuwidths uswidths)
+                      (merge 'list (copy-list uuwidths) (copy-list uswidths)
+                             #'< :key #'car)
+                      (or uuwidths uswidths)))
          (twidths (modular-class-widths *tagged-modular-class*)))
     (let ((exact (find (cons width signedp) uwidths :test #'equal)))
       (when exact
@@ -2946,53 +3092,87 @@
           (return-from best-modular-version
             (values (car ugt) :untagged (cdr ugt))))))))
 
+(defun integer-type-numeric-bounds (type)
+  (typecase type
+    (numeric-type (values (numeric-type-low type)
+                          (numeric-type-high type)))
+    (union-type
+     (let ((low  nil)
+           (high nil))
+       (dolist (type (union-type-types type) (values low high))
+         (unless (and (numeric-type-p type)
+                      (eql (numeric-type-class type) 'integer))
+           (return (values nil nil)))
+         (let ((this-low (numeric-type-low type))
+               (this-high (numeric-type-high type)))
+           (unless (and this-low this-high)
+             (return (values nil nil)))
+           (setf low  (min this-low  (or low  this-low))
+                 high (max this-high (or high this-high)))))))))
+
 (defoptimizer (logand optimizer) ((x y) node)
   (let ((result-type (single-value-type (node-derived-type node))))
-    (when (numeric-type-p result-type)
-      (let ((low (numeric-type-low result-type))
-            (high (numeric-type-high result-type)))
-        (when (and (numberp low)
-                   (numberp high)
-                   (>= low 0))
-          (let ((width (integer-length high)))
-            (multiple-value-bind (w kind signedp)
-                (best-modular-version width nil)
-              (when w
-                ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH SIGNEDP).
-                ;;
-                ;; FIXME: I think the FIXME (which is from APD) above
-                ;; implies that CUT-TO-WIDTH should do /everything/
-                ;; that's required, including reoptimizing things
-                ;; itself that it knows are necessary.  At the moment,
-                ;; CUT-TO-WIDTH sets up some new calls with
-                ;; combination-type :FULL, which later get noticed as
-                ;; known functions and properly converted.
-                ;;
-                ;; We cut to W not WIDTH if SIGNEDP is true, because
-                ;; signed constant replacement needs to know which bit
-                ;; in the field is the signed bit.
-                (let ((xact (cut-to-width x kind (if signedp w width) signedp))
-                      (yact (cut-to-width y kind (if signedp w width) signedp)))
-                  (declare (ignore xact yact))
-                  nil) ; After fixing above, replace with T, meaning
-                       ; "don't reoptimize this (LOGAND) node any more".
-                ))))))))
+    (multiple-value-bind (low high)
+        (integer-type-numeric-bounds result-type)
+      (when (and (numberp low)
+                 (numberp high)
+                 (>= low 0))
+        (let ((width (integer-length high)))
+          (multiple-value-bind (w kind signedp)
+              (best-modular-version width nil)
+            (when w
+              ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH SIGNEDP).
+              ;;
+              ;; FIXME: I think the FIXME (which is from APD) above
+              ;; implies that CUT-TO-WIDTH should do /everything/
+              ;; that's required, including reoptimizing things
+              ;; itself that it knows are necessary.  At the moment,
+              ;; CUT-TO-WIDTH sets up some new calls with
+              ;; combination-type :FULL, which later get noticed as
+              ;; known functions and properly converted.
+              ;;
+              ;; We cut to W not WIDTH if SIGNEDP is true, because
+              ;; signed constant replacement needs to know which bit
+              ;; in the field is the signed bit.
+              (let ((xact (cut-to-width x kind (if signedp w width) signedp))
+                    (yact (cut-to-width y kind (if signedp w width) signedp)))
+                (declare (ignore xact yact))
+                nil) ; After fixing above, replace with T, meaning
+                                        ; "don't reoptimize this (LOGAND) node any more".
+              )))))))
 
 (defoptimizer (mask-signed-field optimizer) ((width x) node)
   (let ((result-type (single-value-type (node-derived-type node))))
-    (when (numeric-type-p result-type)
-      (let ((low (numeric-type-low result-type))
-            (high (numeric-type-high result-type)))
-        (when (and (numberp low) (numberp high))
-          (let ((width (max (integer-length high) (integer-length low))))
-            (multiple-value-bind (w kind)
-                (best-modular-version (1+ width) t)
-              (when w
-                ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND W T).
-                ;; [ see comment above in LOGAND optimizer ]
-                (cut-to-width x kind w t)
-                nil ; After fixing above, replace with T.
-                ))))))))
+    (multiple-value-bind (low high)
+        (integer-type-numeric-bounds result-type)
+      (when (and (numberp low) (numberp high))
+        (let ((width (max (integer-length high) (integer-length low))))
+          (multiple-value-bind (w kind)
+              (best-modular-version (1+ width) t)
+            (when w
+              ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND W T).
+              ;; [ see comment above in LOGAND optimizer ]
+              (cut-to-width x kind w t)
+              nil                ; After fixing above, replace with T.
+              )))))))
+
+(defoptimizer (logior optimizer) ((x y) node)
+  (let ((result-type (single-value-type (node-derived-type node))))
+    (multiple-value-bind (low high)
+        (integer-type-numeric-bounds result-type)
+      (when (and (numberp low)
+                 (numberp high)
+                 (<= high 0))
+        (let ((width (integer-length low)))
+          (multiple-value-bind (w kind)
+              (best-modular-version (1+ width) t)
+            (when w
+              ;; FIXME: see comment in LOGAND optimizer
+              (let ((xact (cut-to-width x kind w t))
+                    (yact (cut-to-width y kind w t)))
+                (declare (ignore xact yact))
+                nil) ; After fixing above, replace with T
+              )))))))
 
 ;;; miscellanous numeric transforms
 
@@ -3001,11 +3181,11 @@
   (if (and (constant-lvar-p x)
            (not (constant-lvar-p y)))
       `(,(lvar-fun-name (basic-combination-fun node))
-        y
+        (truly-the ,(lvar-type y) y)
         ,(lvar-value x))
       (give-up-ir1-transform)))
 
-(dolist (x '(= char= + * logior logand logxor))
+(dolist (x '(= char= + * logior logand logxor logtest))
   (%deftransform x '(function * *) #'commutative-arg-swap
                  "place constant arg last"))
 
@@ -3263,14 +3443,17 @@
   (def logxor -1 (lognot x))
   (def logxor 0 x))
 
+(defun least-zero-bit (x)
+  (and (/= x -1)
+       (1- (integer-length (logxor x (1+ x))))))
+
 (deftransform logand ((x y) (* (constant-arg t)) *)
   "fold identity operation"
-  (let ((y (lvar-value y)))
-    (unless (and (plusp y)
-                 (= y (1- (ash 1 (integer-length y)))))
-      (give-up-ir1-transform))
-    (unless (csubtypep (lvar-type x)
-                       (specifier-type `(integer 0 ,y)))
+  (let* ((y (lvar-value y))
+         (width (or (least-zero-bit y) '*)))
+    (unless (and (neq width 0) ; (logand x 0) handled elsewhere
+                 (csubtypep (lvar-type x)
+                            (specifier-type `(unsigned-byte ,width))))
       (give-up-ir1-transform))
     'x))
 
@@ -3281,6 +3464,16 @@
       (give-up-ir1-transform))
     'x))
 
+(deftransform logior ((x y) (* (constant-arg t)) *)
+  "fold identity operation"
+  (let* ((y (lvar-value y))
+         (width (or (least-zero-bit (lognot y))
+                    (give-up-ir1-transform)))) ; (logior x 0) handled elsewhere
+    (unless (csubtypep (lvar-type x)
+                       (specifier-type `(integer ,(- (ash 1 width)) -1)))
+      (give-up-ir1-transform))
+    'x))
+
 ;;; Pick off easy association opportunities for constant folding.
 ;;; More complicated stuff that also depends on commutativity
 ;;; (e.g. (f (f x k1) (f y k2)) => (f (f x y) (f k1 k2))) should
@@ -3306,13 +3499,17 @@
                   (splice-fun-args x ',folded 2)
                   `(lambda (x y z)
                      (declare (ignore y z))
-                     (,',operator x ',(,folded y (lvar-value z))))))))
+                     ;; (operator (folded x y) z)
+                     ;; == (operator x (folded z y))
+                     (,',operator x ',(,folded (lvar-value z) y)))))))
   (def logand)
   (def logior)
   (def logxor)
   (def logtest :folded logand)
   (def + :type rational)
-  (def * :type rational))
+  (def + :type rational :folded -)
+  (def * :type rational)
+  (def * :type rational :folded /))
 
 (deftransform mask-signed-field ((width x) ((constant-arg unsigned-byte) *))
   "Fold mask-signed-field/mask-signed-field of constant width"
@@ -3344,6 +3541,25 @@
   "convert (* x 0) to 0"
   0)
 
+(deftransform %negate ((x) (rational))
+  "Eliminate %negate/%negate of rationals"
+  (splice-fun-args x '%negate 1)
+  '(the rational x))
+
+(deftransform %negate ((x) (number))
+  "Combine %negate/*"
+  (let ((use (lvar-uses x))
+        arg)
+    (unless (and (combination-p use)
+                 (eql '* (lvar-fun-name (combination-fun use)))
+                 (constant-lvar-p (setf arg (second (combination-args use))))
+                 (numberp (setf arg (lvar-value arg))))
+      (give-up-ir1-transform))
+    (splice-fun-args x '* 2)
+    `(lambda (x y)
+       (declare (ignore y))
+       (* x ,(- arg)))))
+
 ;;; Return T if in an arithmetic op including lvars X and Y, the
 ;;; result type is not affected by the type of X. That is, Y is at
 ;;; least as contagious as X.
@@ -3605,25 +3821,72 @@
   "convert to simpler equality predicate"
   (let ((x-type (lvar-type x))
         (y-type (lvar-type y))
-        (string-type (specifier-type 'string))
-        (bit-vector-type (specifier-type 'bit-vector)))
-    (cond
-      ((same-leaf-ref-p x y) t)
-      ((and (csubtypep x-type string-type)
-            (csubtypep y-type string-type))
-       '(string= x y))
-      ((and (csubtypep x-type bit-vector-type)
-            (csubtypep y-type bit-vector-type))
-       '(bit-vector-= x y))
-      ;; if at least one is not a string, and at least one is not a
-      ;; bit-vector, then we can reason from types.
-      ((and (not (and (types-equal-or-intersect x-type string-type)
-                      (types-equal-or-intersect y-type string-type)))
-            (not (and (types-equal-or-intersect x-type bit-vector-type)
-                      (types-equal-or-intersect y-type bit-vector-type)))
-            (not (types-equal-or-intersect x-type y-type)))
-       nil)
-      (t (give-up-ir1-transform)))))
+        (combination-type (specifier-type '(or bit-vector string
+                                            cons pathname))))
+    (flet ((both-csubtypep (type)
+             (let ((ctype (specifier-type type)))
+               (and (csubtypep x-type ctype)
+                    (csubtypep y-type ctype)))))
+      (cond
+        ((same-leaf-ref-p x y) t)
+        ((both-csubtypep 'string)
+         '(string= x y))
+        ((both-csubtypep 'bit-vector)
+         '(bit-vector-= x y))
+        ((both-csubtypep 'pathname)
+         '(pathname= x y))
+        ((or (not (types-equal-or-intersect x-type combination-type))
+             (not (types-equal-or-intersect y-type combination-type)))
+         (if (types-equal-or-intersect x-type y-type)
+             '(eql x y)
+             ;; Can't simply check for type intersection if both types are combination-type
+             ;; since array specialization would mean types don't intersect, even when EQUAL
+             ;; doesn't care for specialization.
+             ;; Previously checking for intersection in the outer COND resulted in
+             ;;
+             ;; (equal (the (cons (or simple-bit-vector
+             ;;                       simple-base-string))
+             ;;             x)
+             ;;        (the (cons (or (and bit-vector (not simple-array))
+             ;;                       (simple-array character (*))))
+             ;;             y))
+             ;; being incorrectly folded to NIL
+             nil))
+        (t (give-up-ir1-transform))))))
+
+(deftransform equalp ((x y) * *)
+  "convert to simpler equality predicate"
+  (let ((x-type (lvar-type x))
+        (y-type (lvar-type y))
+        (combination-type (specifier-type '(or number array
+                                            character
+                                            cons pathname
+                                            instance hash-table))))
+    (flet ((both-csubtypep (type)
+             (let ((ctype (specifier-type type)))
+               (and (csubtypep x-type ctype)
+                    (csubtypep y-type ctype)))))
+      (cond
+        ((same-leaf-ref-p x y) t)
+        ((both-csubtypep 'string)
+         '(string-equal x y))
+        ((both-csubtypep 'bit-vector)
+         '(bit-vector-= x y))
+        ((both-csubtypep 'pathname)
+         '(pathname= x y))
+        ((both-csubtypep 'character)
+         '(char-equal x y))
+        ((both-csubtypep 'number)
+         '(= x y))
+        ((both-csubtypep 'hash-table)
+         '(hash-table-equalp x y))
+        ((or (not (types-equal-or-intersect x-type combination-type))
+             (not (types-equal-or-intersect y-type combination-type)))
+         ;; See the comment about specialized types in the EQUAL transform above
+         (if (types-equal-or-intersect y-type x-type)
+             '(eq x y)
+             nil))
+        (t (give-up-ir1-transform))))))
 
 ;;; Convert to EQL if both args are rational and complexp is specified
 ;;; and the same for both.
@@ -3791,15 +4054,15 @@
                                                             'character))
 
 (define-source-transform char-equal (&rest args)
-  (multi-compare 'sb!impl::two-arg-char-equal args nil 'character t))
+  (multi-compare 'two-arg-char-equal args nil 'character t))
 (define-source-transform char-lessp (&rest args)
-  (multi-compare 'sb!impl::two-arg-char-lessp args nil 'character t))
+  (multi-compare 'two-arg-char-lessp args nil 'character t))
 (define-source-transform char-greaterp (&rest args)
-  (multi-compare 'sb!impl::two-arg-char-greaterp args nil 'character t))
+  (multi-compare 'two-arg-char-greaterp args nil 'character t))
 (define-source-transform char-not-greaterp (&rest args)
-  (multi-compare 'sb!impl::two-arg-char-greaterp args t 'character t))
+  (multi-compare 'two-arg-char-greaterp args t 'character t))
 (define-source-transform char-not-lessp (&rest args)
-  (multi-compare 'sb!impl::two-arg-char-lessp args t 'character t))
+  (multi-compare 'two-arg-char-lessp args t 'character t))
 
 ;;; This function does source transformation of N-arg inequality
 ;;; functions such as /=. This is similar to MULTI-COMPARE in the <3
@@ -3848,6 +4111,48 @@
         `(values (the real ,arg0))
         `(let ((minrest (min ,@rest)))
           (if (<= ,arg0 minrest) ,arg0 minrest)))))
+
+;;; Simplify some cross-type comparisons
+(macrolet ((def (comparator round)
+             `(progn
+                (deftransform ,comparator
+                    ((x y) (rational (constant-arg float)))
+                  "open-code RATIONAL to FLOAT comparison"
+                  (let ((y (lvar-value y)))
+                    #-sb-xc-host
+                    (when (or (float-nan-p y)
+                              (float-infinity-p y))
+                      (give-up-ir1-transform))
+                    (setf y (rational y))
+                    `(,',comparator
+                      x ,(if (csubtypep (lvar-type x)
+                                        (specifier-type 'integer))
+                             (,round y)
+                             y))))
+                (deftransform ,comparator
+                    ((x y) (integer (constant-arg ratio)))
+                  "open-code INTEGER to RATIO comparison"
+                  `(,',comparator x ,(,round (lvar-value y)))))))
+  (def < ceiling)
+  (def > floor))
+
+(deftransform = ((x y) (rational (constant-arg float)))
+  "open-code RATIONAL to FLOAT comparison"
+  (let ((y (lvar-value y)))
+    #-sb-xc-host
+    (when (or (float-nan-p y)
+              (float-infinity-p y))
+      (give-up-ir1-transform))
+    (setf y (rational y))
+    (if (and (csubtypep (lvar-type x)
+                        (specifier-type 'integer))
+             (ratiop y))
+        nil
+        `(= x ,y))))
+
+(deftransform = ((x y) (integer (constant-arg ratio)))
+  "constant-fold INTEGER to RATIO comparison"
+  nil)
 
 ;;;; converting N-arg arithmetic functions
 ;;;;
@@ -4554,3 +4859,35 @@
                (policy-quality-name-p (lvar-value quality-name)))
     (give-up-ir1-transform))
   '(%policy-quality policy quality-name))
+
+(deftransform encode-universal-time
+    ((second minute hour date month year &optional time-zone)
+     ((constant-arg (mod 60)) (constant-arg (mod 60))
+      (constant-arg (mod 24))
+      (constant-arg (integer 1 31))
+      (constant-arg (integer 1 12))
+      (constant-arg (integer 1899))
+      (constant-arg (rational -24 24))))
+  (let ((second (lvar-value second))
+        (minute (lvar-value minute))
+        (hour (lvar-value hour))
+        (date (lvar-value date))
+        (month (lvar-value month))
+        (year (lvar-value year))
+        (time-zone (lvar-value time-zone)))
+    (if (zerop (rem time-zone 1/3600))
+        (encode-universal-time second minute hour date month year time-zone)
+        (give-up-ir1-transform))))
+
+#!-(and win32 (not sb-thread))
+(deftransform sleep ((seconds) ((integer 0 #.(expt 10 8))))
+  `(sb!unix:nanosleep seconds 0))
+
+#!-(and win32 (not sb-thread))
+(deftransform sleep ((seconds) ((constant-arg (real 0))))
+  (let ((seconds-value (lvar-value seconds)))
+    (multiple-value-bind (seconds nano)
+        (sb!impl::split-seconds-for-sleep seconds-value)
+      (if (> seconds (expt 10 8))
+          (give-up-ir1-transform)
+          `(sb!unix:nanosleep ,seconds ,nano)))))