From: Paul Khuong <pvk@pvk.ca>
Date: Sat, 26 Oct 2013 17:18:23 +0000 (-0400)
Subject: Make sure quantifiers don't cons
X-Git-Url: http://repo.macrolet.net/gitweb/?p=sbcl.git;a=commitdiff_plain;h=441dfe5655f1ec3ee96e7b17b7cb1c7a4a906117

Make sure quantifiers don't cons

Quantifiers like SOME and EVERY are implemented in terms of (MAP NIL)
of a wrapper function with early RETURN. If type information does not
enable MAP to be open coded, declarations are necessary to avoid
consing up a closure and a value cell for the return.

DX functions really shouldn't cause value cells for return blocks.

Also, revert d0f65b07a30adc989e36a82ddc0ed54d135d638e which is
now mostly redundant.
---

diff --git a/NEWS b/NEWS
index 978021c..2951b1b 100644
--- a/NEWS
+++ b/NEWS
@@ -13,6 +13,8 @@ changes relative to sbcl-1.1.12:
     COMPUTE-RESTARTS, making it faster and cons less (lp#769615)
   * enhancement: FIND-RESTART and COMPUTE-RESTARTS handle huge restart
     clusters better in some cases
+  * enhancement: SOME/ANY/other quantification higher-order functions no
+    longer cons. (lp#1070635)
   * bug fix: forward references to classes in fasls can now be loaded.
     (lp#746132)
   * bug fix: don't warn on a interpreted->compiled function redefinition
diff --git a/src/code/seq.lisp b/src/code/seq.lisp
index 54c7c02..e6abb66 100644
--- a/src/code/seq.lisp
+++ b/src/code/seq.lisp
@@ -1207,17 +1207,20 @@ many elements are copied."
                 ;; from the old seq.lisp into target-seq.lisp.
                 (define-compiler-macro ,name (pred first-seq &rest more-seqs)
                   (let ((elements (make-gensym-list (1+ (length more-seqs))))
-                        (blockname (sb!xc:gensym "BLOCK")))
+                        (blockname (sb!xc:gensym "BLOCK"))
+                        (wrapper (sb!xc:gensym "WRAPPER")))
                     (once-only ((pred pred))
                       `(block ,blockname
-                         (map nil
-                              (lambda (,@elements)
-                                (let ((pred-value (funcall ,pred ,@elements)))
-                                  (,',found-test pred-value
-                                    (return-from ,blockname
-                                      ,',found-result))))
-                              ,first-seq
-                              ,@more-seqs)
+                         (flet ((,wrapper (,@elements)
+                                  (declare (optimize (sb!c::check-tag-existence 0)))
+                                  (let ((pred-value (funcall ,pred ,@elements)))
+                                    (,',found-test pred-value
+                                                   (return-from ,blockname
+                                                     ,',found-result)))))
+                           (declare (inline ,wrapper)
+                                    (dynamic-extent #',wrapper))
+                           (map nil #',wrapper ,first-seq
+                                ,@more-seqs))
                          ,',unfound-result)))))))
   (defquantifier some when pred-value :unfound-result nil :doc
   "Apply PREDICATE to the 0-indexed elements of the sequences, then
diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index 37e3c75..975acc4 100644
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -852,8 +852,7 @@
   (or (when (forward-referenced-class-p class)
         class)
       (some #'class-has-a-forward-referenced-superclass-p
-            ;; KLUDGE: SOME conses without knowing the type
-            (the list (class-direct-superclasses class)))))
+            (class-direct-superclasses class))))
 
 ;;; This is called by :after shared-initialize whenever a class is initialized
 ;;; or reinitialized. The class may or may not be finalized.
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 92079e7..21adaf5 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -4880,3 +4880,20 @@
     (declare (ignore warnings-p))
     (assert (functionp fun))
     (assert failure-p)))
+
+;; quantifiers shouldn't cons themselves.
+(with-test (:name :quantifiers-no-consing)
+  (let ((constantly-t (lambda (x) x t))
+        (constantly-nil (lambda (x) x nil))
+        (list (make-list 1000 :initial-element nil))
+        (vector (make-array 1000 :initial-element nil)))
+    (macrolet ((test (quantifier)
+                 (let ((function (make-symbol (format nil "TEST-~A" quantifier))))
+                   `(flet ((,function (function sequence)
+                             (,quantifier function sequence)))
+                      (ctu:assert-no-consing (,function constantly-t list))
+                      (ctu:assert-no-consing (,function constantly-nil vector))))))
+      (test some)
+      (test every)
+      (test notany)
+      (test notevery))))