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

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 2fc68a9..0d22154 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -134,6 +134,11 @@
     (1 `(cons ,(first args) nil))
     (t (values nil t))))
 
+(defoptimizer (list derive-type) ((&rest args) node)
+  (if args
+      (specifier-type 'cons)
+      (specifier-type 'null)))
+
 ;;; And similarly for LIST*.
 (define-source-transform list* (arg &rest others)
   (cond ((not others) arg)
@@ -145,6 +150,75 @@
       (specifier-type 'cons)
       (lvar-type arg)))
 
+;;;
+
+(define-source-transform nconc (&rest args)
+  (case (length args)
+    (0 ())
+    (1 (car args))
+    (t (values nil t))))
+
+;;; (append nil nil nil fixnum) => fixnum
+;;; (append x x cons x x) => cons
+;;; (append x x x x list) => list
+;;; (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))
+                      (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)))))))))
+
+(defoptimizer (append derive-type) ((&rest args))
+  (derive-append-type args))
+
+(defoptimizer (sb!impl::append2 derive-type) ((&rest args))
+  (derive-append-type args))
+
+(defoptimizer (nconc derive-type) ((&rest args))
+  (derive-append-type args))
+
 ;;; Translate RPLACx to LET and SETF.
 (define-source-transform rplaca (x y)
   (once-only ((n-x x))
@@ -236,8 +310,24 @@
 ;;; on the argument types), but we make it a regular transform so that
 ;;; the VM has a chance to see the bare LOGTEST and potentiall choose
 ;;; to implement it differently.  --njf, 06-02-2006
-(deftransform logtest ((x y) * *)
-  `(not (zerop (logand x y))))
+;;;
+;;; Other transforms may be useful even with direct LOGTEST VOPs; let
+;;; them fire (including the type-directed constant folding below), but
+;;; disable the inlining rewrite in such cases. -- PK, 2013-05-20
+(deftransform logtest ((x y) * * :node node)
+  (let ((type (two-arg-derive-type x y
+                                   #'logand-derive-type-aux
+                                   #'logand)))
+    (multiple-value-bind (typep definitely)
+        (ctypep 0 type)
+      (cond ((and (not typep) definitely)
+             t)
+            ((type= type (specifier-type '(eql 0)))
+             nil)
+            ((neq :default (combination-implementation-style node))
+             (give-up-ir1-transform))
+            (t
+             `(not (zerop (logand x y))))))))
 
 (deftransform logbitp
     ((index integer) (unsigned-byte (or (signed-byte #.sb!vm:n-word-bits)
@@ -2393,305 +2483,6 @@
 (defoptimizer (random derive-type) ((bound &optional state))
   (one-arg-derive-type bound #'random-derive-type-aux nil))
 
-;;;; DERIVE-TYPE methods for LOGAND, LOGIOR, and friends
-
-;;; Return the maximum number of bits an integer of the supplied type
-;;; can take up, or NIL if it is unbounded. The second (third) value
-;;; is T if the integer can be positive (negative) and NIL if not.
-;;; Zero counts as positive.
-(defun integer-type-length (type)
-  (if (numeric-type-p type)
-      (let ((min (numeric-type-low type))
-            (max (numeric-type-high type)))
-        (values (and min max (max (integer-length min) (integer-length max)))
-                (or (null max) (not (minusp max)))
-                (or (null min) (minusp min))))
-      (values nil t t)))
-
-;;; See _Hacker's Delight_, Henry S. Warren, Jr. pp 58-63 for an
-;;; explanation of LOG{AND,IOR,XOR}-DERIVE-UNSIGNED-{LOW,HIGH}-BOUND.
-;;; Credit also goes to Raymond Toy for writing (and debugging!) similar
-;;; versions in CMUCL, from which these functions copy liberally.
-
-(defun logand-derive-unsigned-low-bound (x y)
-  (let ((a (numeric-type-low x))
-        (b (numeric-type-high x))
-        (c (numeric-type-low y))
-        (d (numeric-type-high y)))
-    (loop for m = (ash 1 (integer-length (lognor a c))) then (ash m -1)
-          until (zerop m) do
-          (unless (zerop (logand m (lognot a) (lognot c)))
-            (let ((temp (logandc2 (logior a m) (1- m))))
-              (when (<= temp b)
-                (setf a temp)
-                (loop-finish))
-              (setf temp (logandc2 (logior c m) (1- m)))
-              (when (<= temp d)
-                (setf c temp)
-                (loop-finish))))
-          finally (return (logand a c)))))
-
-(defun logand-derive-unsigned-high-bound (x y)
-  (let ((a (numeric-type-low x))
-        (b (numeric-type-high x))
-        (c (numeric-type-low y))
-        (d (numeric-type-high y)))
-    (loop for m = (ash 1 (integer-length (logxor b d))) then (ash m -1)
-          until (zerop m) do
-          (cond
-            ((not (zerop (logand b (lognot d) m)))
-             (let ((temp (logior (logandc2 b m) (1- m))))
-               (when (>= temp a)
-                 (setf b temp)
-                 (loop-finish))))
-            ((not (zerop (logand (lognot b) d m)))
-             (let ((temp (logior (logandc2 d m) (1- m))))
-               (when (>= temp c)
-                 (setf d temp)
-                 (loop-finish)))))
-          finally (return (logand b d)))))
-
-(defun logand-derive-type-aux (x y &optional same-leaf)
-  (when same-leaf
-    (return-from logand-derive-type-aux x))
-  (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
-    (declare (ignore x-pos))
-    (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y)
-      (declare (ignore y-pos))
-      (if (not x-neg)
-          ;; X must be positive.
-          (if (not y-neg)
-              ;; They must both be positive.
-              (cond ((and (null x-len) (null y-len))
-                     (specifier-type 'unsigned-byte))
-                    ((null x-len)
-                     (specifier-type `(unsigned-byte* ,y-len)))
-                    ((null y-len)
-                     (specifier-type `(unsigned-byte* ,x-len)))
-                    (t
-                     (let ((low (logand-derive-unsigned-low-bound x y))
-                           (high (logand-derive-unsigned-high-bound x y)))
-                       (specifier-type `(integer ,low ,high)))))
-              ;; X is positive, but Y might be negative.
-              (cond ((null x-len)
-                     (specifier-type 'unsigned-byte))
-                    (t
-                     (specifier-type `(unsigned-byte* ,x-len)))))
-          ;; X might be negative.
-          (if (not y-neg)
-              ;; Y must be positive.
-              (cond ((null y-len)
-                     (specifier-type 'unsigned-byte))
-                    (t (specifier-type `(unsigned-byte* ,y-len))))
-              ;; Either might be negative.
-              (if (and x-len y-len)
-                  ;; The result is bounded.
-                  (specifier-type `(signed-byte ,(1+ (max x-len y-len))))
-                  ;; We can't tell squat about the result.
-                  (specifier-type 'integer)))))))
-
-(defun logior-derive-unsigned-low-bound (x y)
-  (let ((a (numeric-type-low x))
-        (b (numeric-type-high x))
-        (c (numeric-type-low y))
-        (d (numeric-type-high y)))
-    (loop for m = (ash 1 (integer-length (logxor a c))) then (ash m -1)
-          until (zerop m) do
-          (cond
-            ((not (zerop (logandc2 (logand c m) a)))
-             (let ((temp (logand (logior a m) (1+ (lognot m)))))
-               (when (<= temp b)
-                 (setf a temp)
-                 (loop-finish))))
-            ((not (zerop (logandc2 (logand a m) c)))
-             (let ((temp (logand (logior c m) (1+ (lognot m)))))
-               (when (<= temp d)
-                 (setf c temp)
-                 (loop-finish)))))
-          finally (return (logior a c)))))
-
-(defun logior-derive-unsigned-high-bound (x y)
-  (let ((a (numeric-type-low x))
-        (b (numeric-type-high x))
-        (c (numeric-type-low y))
-        (d (numeric-type-high y)))
-    (loop for m = (ash 1 (integer-length (logand b d))) then (ash m -1)
-          until (zerop m) do
-          (unless (zerop (logand b d m))
-            (let ((temp (logior (- b m) (1- m))))
-              (when (>= temp a)
-                (setf b temp)
-                (loop-finish))
-              (setf temp (logior (- d m) (1- m)))
-              (when (>= temp c)
-                (setf d temp)
-                (loop-finish))))
-          finally (return (logior b d)))))
-
-(defun logior-derive-type-aux (x y &optional same-leaf)
-  (when same-leaf
-    (return-from logior-derive-type-aux x))
-  (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
-    (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y)
-      (cond
-       ((and (not x-neg) (not y-neg))
-        ;; Both are positive.
-        (if (and x-len y-len)
-            (let ((low (logior-derive-unsigned-low-bound x y))
-                  (high (logior-derive-unsigned-high-bound x y)))
-              (specifier-type `(integer ,low ,high)))
-            (specifier-type `(unsigned-byte* *))))
-       ((not x-pos)
-        ;; X must be negative.
-        (if (not y-pos)
-            ;; Both are negative. The result is going to be negative
-            ;; and be the same length or shorter than the smaller.
-            (if (and x-len y-len)
-                ;; It's bounded.
-                (specifier-type `(integer ,(ash -1 (min x-len y-len)) -1))
-                ;; It's unbounded.
-                (specifier-type '(integer * -1)))
-            ;; X is negative, but we don't know about Y. The result
-            ;; will be negative, but no more negative than X.
-            (specifier-type
-             `(integer ,(or (numeric-type-low x) '*)
-                       -1))))
-       (t
-        ;; X might be either positive or negative.
-        (if (not y-pos)
-            ;; But Y is negative. The result will be negative.
-            (specifier-type
-             `(integer ,(or (numeric-type-low y) '*)
-                       -1))
-            ;; We don't know squat about either. It won't get any bigger.
-            (if (and x-len y-len)
-                ;; Bounded.
-                (specifier-type `(signed-byte ,(1+ (max x-len y-len))))
-                ;; Unbounded.
-                (specifier-type 'integer))))))))
-
-(defun logxor-derive-unsigned-low-bound (x y)
-  (let ((a (numeric-type-low x))
-        (b (numeric-type-high x))
-        (c (numeric-type-low y))
-        (d (numeric-type-high y)))
-    (loop for m = (ash 1 (integer-length (logxor a c))) then (ash m -1)
-          until (zerop m) do
-          (cond
-            ((not (zerop (logandc2 (logand c m) a)))
-             (let ((temp (logand (logior a m)
-                                 (1+ (lognot m)))))
-               (when (<= temp b)
-                 (setf a temp))))
-            ((not (zerop (logandc2 (logand a m) c)))
-             (let ((temp (logand (logior c m)
-                                 (1+ (lognot m)))))
-               (when (<= temp d)
-                 (setf c temp)))))
-          finally (return (logxor a c)))))
-
-(defun logxor-derive-unsigned-high-bound (x y)
-  (let ((a (numeric-type-low x))
-        (b (numeric-type-high x))
-        (c (numeric-type-low y))
-        (d (numeric-type-high y)))
-    (loop for m = (ash 1 (integer-length (logand b d))) then (ash m -1)
-          until (zerop m) do
-          (unless (zerop (logand b d m))
-            (let ((temp (logior (- b m) (1- m))))
-              (cond
-                ((>= temp a) (setf b temp))
-                (t (let ((temp (logior (- d m) (1- m))))
-                     (when (>= temp c)
-                       (setf d temp)))))))
-          finally (return (logxor b d)))))
-
-(defun logxor-derive-type-aux (x y &optional same-leaf)
-  (when same-leaf
-    (return-from logxor-derive-type-aux (specifier-type '(eql 0))))
-  (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
-    (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y)
-      (cond
-        ((and (not x-neg) (not y-neg))
-         ;; Both are positive
-         (if (and x-len y-len)
-             (let ((low (logxor-derive-unsigned-low-bound x y))
-                   (high (logxor-derive-unsigned-high-bound x y)))
-               (specifier-type `(integer ,low ,high)))
-             (specifier-type '(unsigned-byte* *))))
-        ((and (not x-pos) (not y-pos))
-         ;; Both are negative.  The result will be positive, and as long
-         ;; as the longer.
-         (specifier-type `(unsigned-byte* ,(if (and x-len y-len)
-                                               (max x-len y-len)
-                                               '*))))
-        ((or (and (not x-pos) (not y-neg))
-             (and (not y-pos) (not x-neg)))
-         ;; Either X is negative and Y is positive or vice-versa. The
-         ;; result will be negative.
-         (specifier-type `(integer ,(if (and x-len y-len)
-                                        (ash -1 (max x-len y-len))
-                                        '*)
-                           -1)))
-        ;; We can't tell what the sign of the result is going to be.
-        ;; All we know is that we don't create new bits.
-        ((and x-len y-len)
-         (specifier-type `(signed-byte ,(1+ (max x-len y-len)))))
-        (t
-         (specifier-type 'integer))))))
-
-(macrolet ((deffrob (logfun)
-             (let ((fun-aux (symbolicate logfun "-DERIVE-TYPE-AUX")))
-             `(defoptimizer (,logfun derive-type) ((x y))
-                (two-arg-derive-type x y #',fun-aux #',logfun)))))
-  (deffrob logand)
-  (deffrob logior)
-  (deffrob logxor))
-
-(defoptimizer (logeqv derive-type) ((x y))
-  (two-arg-derive-type x y (lambda (x y same-leaf)
-                             (lognot-derive-type-aux
-                              (logxor-derive-type-aux x y same-leaf)))
-                       #'logeqv))
-(defoptimizer (lognand derive-type) ((x y))
-  (two-arg-derive-type x y (lambda (x y same-leaf)
-                             (lognot-derive-type-aux
-                              (logand-derive-type-aux x y same-leaf)))
-                       #'lognand))
-(defoptimizer (lognor derive-type) ((x y))
-  (two-arg-derive-type x y (lambda (x y same-leaf)
-                             (lognot-derive-type-aux
-                              (logior-derive-type-aux x y same-leaf)))
-                       #'lognor))
-(defoptimizer (logandc1 derive-type) ((x y))
-  (two-arg-derive-type x y (lambda (x y same-leaf)
-                             (if same-leaf
-                                 (specifier-type '(eql 0))
-                                 (logand-derive-type-aux
-                                  (lognot-derive-type-aux x) y nil)))
-                       #'logandc1))
-(defoptimizer (logandc2 derive-type) ((x y))
-  (two-arg-derive-type x y (lambda (x y same-leaf)
-                             (if same-leaf
-                                 (specifier-type '(eql 0))
-                                 (logand-derive-type-aux
-                                  x (lognot-derive-type-aux y) nil)))
-                       #'logandc2))
-(defoptimizer (logorc1 derive-type) ((x y))
-  (two-arg-derive-type x y (lambda (x y same-leaf)
-                             (if same-leaf
-                                 (specifier-type '(eql -1))
-                                 (logior-derive-type-aux
-                                  (lognot-derive-type-aux x) y nil)))
-                       #'logorc1))
-(defoptimizer (logorc2 derive-type) ((x y))
-  (two-arg-derive-type x y (lambda (x y same-leaf)
-                             (if same-leaf
-                                 (specifier-type '(eql -1))
-                                 (logior-derive-type-aux
-                                  x (lognot-derive-type-aux y) nil)))
-                       #'logorc2))
-
 ;;;; miscellaneous derive-type methods
 
 (defoptimizer (integer-length derive-type) ((x))
@@ -3051,50 +2842,79 @@
                (setf (block-reoptimize (node-block node)) t)
                (reoptimize-component (node-component node) :maybe))
              (cut-node (node &aux did-something)
-               (when (and (not (block-delete-p (node-block node)))
-                          (ref-p node)
-                          (constant-p (ref-leaf node)))
-                 (let* ((constant-value (constant-value (ref-leaf node)))
-                        (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))
-                     (setf (lvar-%derived-type (node-lvar node)) (make-values-type :required (list (ctype-of new-value))))
-                     (setf (block-reoptimize (node-block node)) t)
-                     (reoptimize-component (node-component node) :maybe)
-                     (return-from cut-node t))))
-               (when (and (not (block-delete-p (node-block node)))
-                          (combination-p node)
-                          (eq (basic-combination-kind node) :known))
-                 (let* ((fun-ref (lvar-use (combination-fun node)))
-                        (fun-name (leaf-source-name (ref-leaf fun-ref)))
-                        (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)))))
+               (when (block-delete-p (node-block node))
+                 (return-from cut-node))
+               (typecase node
+                 (ref
+                  (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))))
+                       (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)))))
+                 (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)
                (do-uses (node lvar)
                  (when (cut-node node)
@@ -3461,6 +3281,60 @@
       (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
+;;; probably be handled with a more general tree-rewriting pass.
+(macrolet ((def (operator &key (type 'integer) (folded operator))
+             `(deftransform ,operator ((x z) (,type (constant-arg ,type)))
+                ,(format nil "associate ~A/~A of constants"
+                         operator folded)
+                (binding* ((node  (if (lvar-has-single-use-p x)
+                                      (lvar-use x)
+                                      (give-up-ir1-transform)))
+                           (nil (or (and (combination-p node)
+                                         (eq (lvar-fun-name
+                                              (combination-fun node))
+                                             ',folded))
+                                    (give-up-ir1-transform)))
+                           (y   (second (combination-args node)))
+                           (nil (or (constant-lvar-p y)
+                                    (give-up-ir1-transform)))
+                           (y   (lvar-value y)))
+                  (unless (typep y ',type)
+                    (give-up-ir1-transform))
+                  (splice-fun-args x ',folded 2)
+                  `(lambda (x y z)
+                     (declare (ignore y z))
+                     (,',operator x ',(,folded y (lvar-value z))))))))
+  (def logand)
+  (def logior)
+  (def logxor)
+  (def logtest :folded logand)
+  (def + :type rational)
+  (def * :type rational))
+
+(deftransform mask-signed-field ((width x) ((constant-arg unsigned-byte) *))
+  "Fold mask-signed-field/mask-signed-field of constant width"
+  (binding* ((node  (if (lvar-has-single-use-p x)
+                        (lvar-use x)
+                        (give-up-ir1-transform)))
+             (nil (or (combination-p node)
+                      (give-up-ir1-transform)))
+             (nil (or (eq (lvar-fun-name (combination-fun node))
+                          'mask-signed-field)
+                      (give-up-ir1-transform)))
+             (x-width (first (combination-args node)))
+             (nil (or (constant-lvar-p x-width)
+                      (give-up-ir1-transform)))
+             (x-width (lvar-value x-width)))
+    (unless (typep x-width 'unsigned-byte)
+      (give-up-ir1-transform))
+    (splice-fun-args x 'mask-signed-field 2)
+    `(lambda (width x-width x)
+       (declare (ignore width x-width))
+       (mask-signed-field ,(min (lvar-value width) x-width) x))))
+
 ;;; These are restricted to rationals, because (- 0 0.0) is 0.0, not -0.0, and
 ;;; (* 0 -4.0) is -0.0.
 (deftransform - ((x y) ((constant-arg (member 0)) rational) *)
@@ -3712,10 +3586,10 @@
         ((and (csubtypep x-type char-type)
               (csubtypep y-type char-type))
          '(char= x y))
-        ((or (fixnum-type-p x-type) (fixnum-type-p y-type))
-         (commutative-arg-swap node))
         ((or (eq-comparable-type-p x-type) (eq-comparable-type-p y-type))
-         '(eq x y))
+         (if (and (constant-lvar-p x) (not (constant-lvar-p y)))
+             '(eq y x)
+             '(eq x y)))
         ((and (not (constant-lvar-p y))
               (or (constant-lvar-p x)
                   (and (csubtypep x-type y-type)
@@ -4152,10 +4026,12 @@
         `(car (nthcdr ,n ,list)))))
 
 (define-source-transform elt (seq n)
-  (multiple-value-bind (context count) (possible-rest-arg-context seq)
-    (if context
-        `(%rest-ref ,n ,seq ,context ,count)
-        (values nil t))))
+  (if (policy *lexenv* (= safety 3))
+      (values nil t)
+      (multiple-value-bind (context count) (possible-rest-arg-context seq)
+        (if context
+            `(%rest-ref ,n ,seq ,context ,count)
+            (values nil t)))))
 
 ;;; CAxR -> %REST-REF
 (defun source-transform-car (list nth)