From 441dfe5655f1ec3ee96e7b17b7cb1c7a4a906117 Mon Sep 17 00:00:00 2001 From: Paul Khuong Date: Sat, 26 Oct 2013 13:18:23 -0400 Subject: [PATCH] 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. --- NEWS | 2 ++ src/code/seq.lisp | 21 ++++++++++++--------- src/pcl/std-class.lisp | 3 +-- tests/compiler.pure.lisp | 17 +++++++++++++++++ 4 files changed, 32 insertions(+), 11 deletions(-) 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)))) -- 1.7.10.4