ADJOIN shouldn't constant fold.

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

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index ac8cd0f..9e4d3b4 100644 (file)
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -1150,7 +1150,7 @@
 ;;; practice.
 ;;;
 ;;; Limit full open coding based on length of constant sequences. Default
-;;; value is chosen so that other parts of to compiler (constraint propagation
+;;; value is chosen so that other parts of the compiler (constraint propagation
 ;;; mainly) won't go nonlinear too badly. It's not an exact number -- but
 ;;; in the right ballpark.
 (defvar *concatenate-open-code-limit* 129)
@@ -1453,20 +1453,20 @@
   (when (or test key)
     (delay-ir1-transform node :optimize)
     (give-up-ir1-transform "non-trivial :KEY or :TEST"))
-  `(with-array-data ((bits sequence :offset-var offset)
-                     (start start)
-                     (end end)
-                     :check-fill-pointer t)
-     (let ((p ,(if (constant-lvar-p item)
-                   (case (lvar-value item)
-                     (0 `(%bit-position/0 bits from-end start end))
-                     (1 `(%bit-position/1 bits from-end start end))
-                     (otherwise
-                      (abort-ir1-transform)))
-                   `(%bit-position (the bit item) bits from-end start end))))
-       (if p
-           (values item (the index (- (truly-the index p) offset)))
-           (values nil nil)))))
+  (catch 'not-a-bit
+    `(with-array-data ((bits sequence :offset-var offset)
+                       (start start)
+                       (end end)
+                       :check-fill-pointer t)
+       (let ((p ,(if (constant-lvar-p item)
+                     (case (lvar-value item)
+                       (0 `(%bit-position/0 bits from-end start end))
+                       (1 `(%bit-position/1 bits from-end start end))
+                       (otherwise (throw 'not-a-bit `(values nil nil))))
+                     `(%bit-position item bits from-end start end))))
+         (if p
+             (values item (the index (- (truly-the index p) offset)))
+             (values nil nil))))))
 
 (deftransform %find-position ((item sequence from-end start end key test)
                               (character string t t t function function)
@@ -1615,3 +1615,74 @@
   (define-trimmer-transform string-right-trim nil t)
   (define-trimmer-transform string-trim t t))
 
+\f
+;;; (partially) constant-fold backq-* functions, or convert to their
+;;; plain CL equivalent (now that they're not needed for pprinting).
+
+;; Pop constant values from the end, list/list* them if any, and link
+;; the remainder with list* at runtime.
+(defun transform-backq-list-or-list* (function values)
+  (let ((gensyms (make-gensym-list (length values)))
+        (reverse (reverse values))
+        (constants '()))
+    (loop while (and reverse
+                     (constant-lvar-p (car reverse)))
+          do (push (lvar-value (pop reverse))
+                   constants))
+    (if (null constants)
+        `(lambda ,gensyms
+           (,function ,@gensyms))
+        (let ((tail (apply function constants)))
+          (if (null reverse)
+              `',tail
+              (let* ((nvariants (length reverse))
+                     (variants (subseq gensyms 0 nvariants)))
+                `(lambda ,gensyms
+                   (declare (ignore ,@(subseq gensyms nvariants)))
+                   ,(if tail
+                        `(list* ,@variants ',tail)
+                        `(list ,@variants)))))))))
+
+(deftransform sb!impl::backq-list ((&rest elts))
+  (transform-backq-list-or-list* 'list elts))
+
+(deftransform sb!impl::backq-list* ((&rest elts))
+  (transform-backq-list-or-list* 'list* elts))
+
+;; Merge adjacent constant values
+(deftransform sb!impl::backq-append ((&rest elts))
+  (let ((gensyms (make-gensym-list (length elts)))
+        (acc nil)
+        (ignored '())
+        (arguments '()))
+    (flet ((convert-accumulator ()
+             (let ((constant (apply 'append (nreverse (shiftf acc nil)))))
+               (when constant
+                 (push `',constant arguments)))))
+      (loop for gensym in gensyms
+            for (elt . next) on elts by #'cdr
+            do (cond ((constant-lvar-p elt)
+                      (let ((elt (lvar-value elt)))
+                        (when (and next (not (proper-list-p elt)))
+                          (abort-ir1-transform
+                           "Non-list or improper list spliced in ~
+                            the middle of a backquoted list."))
+                        (push gensym ignored)
+                        (push elt acc)))
+                     (t
+                      (convert-accumulator)
+                      (push gensym arguments)))
+            finally (convert-accumulator)))
+    (let ((arguments (nreverse arguments)))
+      `(lambda ,gensyms
+         (declare (ignore ,@ignored))
+         (append ,@arguments)))))
+
+;; Nothing special for nconc
+(define-source-transform sb!impl::backq-nconc (&rest elts)
+  `(nconc ,@elts))
+
+;; cons and vector are handled with regular constant folding...
+;; but we still want to convert backq-cons into cl:cons.
+(deftransform sb!impl::backq-cons ((x y))
+  `(cons x y))