Substitute constants with modular equivalents more safely

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

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 7736902..f6369e6 100644 (file)
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -88,6 +88,9 @@
 ;;; Make source transforms to turn CxR forms into combinations of CAR
 ;;; and CDR. ANSI specifies that everything up to 4 A/D operations is
 ;;; defined.
+;;; Don't transform CAD*R, they are treated specially for &more args
+;;; optimizations
+
 (/show0 "about to set CxR source transforms")
 (loop for i of-type index from 2 upto 4 do
       ;; Iterate over BUF = all names CxR where x = an I-element
@@ -101,8 +104,10 @@
             (declare (type index k))
             (setf (aref buf (1+ k))
                   (if (logbitp k j) #\A #\D)))
-          (setf (info :function :source-transform (intern buf))
-                #'source-transform-cxr))))
+          (unless (member buf '("CADR" "CADDR" "CADDDR")
+                          :test #'equal)
+            (setf (info :function :source-transform (intern buf))
+                  #'source-transform-cxr)))))
 (/show0 "done setting CxR source transforms")
 
 ;;; Turn FIRST..FOURTH and REST into the obvious synonym, assuming
@@ -110,6 +115,7 @@
 ;;; Nth, which can be expanded into a CAR/CDR later on if policy
 ;;; favors it.
 (define-source-transform rest (x) `(cdr ,x))
+(define-source-transform first (x) `(car ,x))
 (define-source-transform second (x) `(cadr ,x))
 (define-source-transform third (x) `(caddr ,x))
 (define-source-transform fourth (x) `(cadddr ,x))
@@ -3054,7 +3060,10 @@
                                        (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))))
+                     (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)
                      (return-from cut-node t))))
@@ -4146,19 +4155,34 @@
         `(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)))))
 
-;;; CAR -> %REST-REF
-(defun source-transform-car (list)
+;;; CAxR -> %REST-REF
+(defun source-transform-car (list nth)
   (multiple-value-bind (context count) (possible-rest-arg-context list)
     (if context
-        `(%rest-ref 0 ,list ,context ,count)
+        `(%rest-ref ,nth ,list ,context ,count)
         (values nil t))))
-(define-source-transform car (list) (source-transform-car list))
-(define-source-transform first (list) (source-transform-car list))
+
+(define-source-transform car (list)
+  (source-transform-car list 0))
+
+(define-source-transform cadr (list)
+  (or (source-transform-car list 1)
+      `(car (cdr ,list))))
+
+(define-source-transform caddr (list)
+  (or (source-transform-car list 2)
+      `(car (cdr (cdr ,list)))))
+
+(define-source-transform cadddr (list)
+  (or (source-transform-car list 3)
+      `(car (cdr (cdr (cdr ,list))))))
 
 ;;; LENGTH -> %REST-LENGTH
 (defun source-transform-length (list)
@@ -4192,7 +4216,8 @@
 
 (deftransform %rest-ref ((n list context count))
   (cond ((rest-var-more-context-ok list)
-         `(%more-arg context n))
+         `(and (< (the index n) count)
+               (%more-arg context n)))
         ((and (constant-lvar-p n) (zerop (lvar-value n)))
          `(car list))
         (t