Constant-fold backquote of constant expressions

 * There is no guarantee that backquote expressions cons up fresh
   storage, so we are free to allocate (sub)lists or vectors at
   compile-time. In addition to regular constant-folding, perform
   part of LIST/LIST*/APPEND at compile-time.

 * Fix one instance of CL:SORT of now-literal data.

 * Implement SB!IMPL:PROPER-LIST-P because BACKQ-APPEND needed that.

 * Based on a patch by James Y Knight; closes lp#1026439.

diff --git a/NEWS b/NEWS
index 17c2f2b..28f9f94 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -76,6 +76,8 @@ changes relative to sbcl-1.1.7:
   * optimization: associative bitwise operations reassociate patterns like
     (f (f x k1) k2) to expose (f x (f k1 k2)).  Same for + and * of
     rational values.
+  * optimization: quasiquote expressions now perform more constant folding,
+    instead of consing equal lists at runtime. (lp#1026439)
 
 changes in sbcl-1.1.7 relative to sbcl-1.1.6:
   * enhancement: TRACE :PRINT-ALL handles multiple-valued forms.

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 4b8befe..a01f3d0 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1204,7 +1204,7 @@ possibly temporariliy, because it might be used internally."
                "LISTEN-SKIP-WHITESPACE"
                "PACKAGE-INTERNAL-SYMBOL-COUNT" "PACKAGE-EXTERNAL-SYMBOL-COUNT"
                "PARSE-BODY" "PARSE-LAMBDA-LIST" "PARSE-LAMBDA-LIST-LIKE-THING"
-               "PROPER-LIST-OF-LENGTH-P"
+               "PROPER-LIST-OF-LENGTH-P" "PROPER-LIST-P"
                "LIST-OF-LENGTH-AT-LEAST-P"
                "LIST-WITH-LENGTH-P"
                "SINGLETON-P"

diff --git a/src/code/primordial-extensions.lisp b/src/code/primordial-extensions.lisp
index 284b401..e91d56d 100644 (file)
--- a/src/code/primordial-extensions.lisp
+++ b/src/code/primordial-extensions.lisp
@@ -345,6 +345,21 @@
                                        (1- max))))
         (t nil)))
 
+(defun proper-list-p (x)
+  (unless (consp x)
+    (return-from proper-list-p (null x)))
+  (let ((rabbit (cdr x))
+        (turtle x))
+    (flet ((pop-rabbit ()
+             (when (eql rabbit turtle) ; circular
+               (return-from proper-list-p nil))
+             (when (atom rabbit)
+               (return-from proper-list-p (null rabbit)))
+             (pop rabbit)))
+      (loop (pop-rabbit)
+            (pop-rabbit)
+            (pop turtle)))))
+
 ;;; Helpers for defining error-signalling NOP's for "not supported
 ;;; here" operations.
 (defmacro define-unsupported-fun (name &optional

diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index 8221b10..358208f 100644 (file)
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -703,6 +703,15 @@
 (defknown make-list (index &key (:initial-element t)) list
   (movable flushable))
 
+(defknown sb!impl::backq-list (&rest t) list (movable flushable))
+(defknown sb!impl::backq-list* (t &rest t) t (movable flushable))
+(defknown sb!impl::backq-append (&rest t) t (flushable))
+(defknown sb!impl::backq-nconc (&rest t) t ()
+  :destroyed-constant-args (remove-non-constants-and-nils #'butlast))
+(defknown sb!impl::backq-cons (t t) cons (foldable movable flushable))
+(defknown sb!impl::backq-vector (list) simple-vector
+    (foldable movable flushable))
+
 ;;; All but last must be of type LIST, but there seems to be no way to
 ;;; express that in this syntax.
 (defknown append (&rest t) t (flushable))

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index a83a68c..9e4d3b4 100644 (file)
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -1614,3 +1614,75 @@
   (define-trimmer-transform string-left-trim t nil)
   (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))

diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp
index dc23874..86eafc6 100644 (file)
--- a/src/compiler/target-disassem.lisp
+++ b/src/compiler/target-disassem.lisp
@@ -1685,10 +1685,10 @@
 ;;; an alist of (SYMBOL-SLOT-OFFSET . ACCESS-FUN-NAME) for slots
 ;;; in a symbol object that we know about
 (defparameter *grokked-symbol-slots*
-  (sort `((,sb!vm:symbol-value-slot . symbol-value)
-          (,sb!vm:symbol-plist-slot . symbol-plist)
-          (,sb!vm:symbol-name-slot . symbol-name)
-          (,sb!vm:symbol-package-slot . symbol-package))
+  (sort (copy-list `((,sb!vm:symbol-value-slot . symbol-value)
+                     (,sb!vm:symbol-plist-slot . symbol-plist)
+                     (,sb!vm:symbol-name-slot . symbol-name)
+                     (,sb!vm:symbol-package-slot . symbol-package)))
         #'<
         :key #'car))