EVERY/SOME/NOTEVERY/NOTANY incorrectly cause heap-allocation of environment

[Douglas Katzman]

Here is an interpreter for a fictitious domain-specific-language based on a real example from our code.

(defun eval-clause-1 (top-level-expr arg1 arg2 arg3)
  (declare (fixnum arg1 arg2) (optimize (speed 3) (safety 0)))
  (labels ((recurse (expr &aux (data (cdr expr)))
             (ecase (car expr)
               (and (every #'recurse data))
               (or (some #'recurse data))
               (arg1<= (<= arg1 (the fixnum data)))
               (arg2> (> arg2 (the fixnum data)))
               (arg3-memq (not (null (member arg3 data :test #'eq)))))))
    (recurse top-level-expr)))

Some sample input:
* (defparameter *simple-expr* '(OR (AND (ARG1<= . 32) (ARG2> . 9)) (ARG3-MEMQ FOO BAZ)))
* (time (loop repeat 10000 count (eval-clause-1 *simple-expr* 0 0 'foo)))
Evaluation took:
  0.003 seconds of real time
  0.002690 seconds of total run time (0.002671 user, 0.000019 system)
  100.00% CPU
  5,377,834 processor cycles
  949,376 bytes consed

10000

Why did the DSL interpreter cons anything at all? I can fix it in two ways:
1. change the AND/OR clauses to use (LOOP for item in data {always,thereis} ...
  because obviously there is nothing that captures the environment upwardly.
2. declare the type of DATA, which magically works and I don't know why:

(defun eval-clause-1 (top-level-expr arg1 arg2 arg3)
  (declare (fixnum arg1 arg2) (optimize (speed 3) (safety 0)))
  (labels ((recurse (expr &aux (data (cdr expr)))
             (ecase (car expr)
               (and (every #'recurse (the list data))) ; changed this line
               (or (some #'recurse (the list data))) ; changed this line
               (arg1<= (<= arg1 (the fixnum data)))
               (arg2> (> arg2 (the fixnum data)))
               (arg3-memq (not (null (member arg3 data :test #'eq)))))))
    (recurse top-level-expr)))

* (time (loop repeat 10000 count (eval-clause-1 *simple-expr* 0 0 'foo)))
Evaluation took:
  0.001 seconds of real time
  0.001014 seconds of total run time (0.001013 user, 0.000001 system)
  100.00% CPU
  2,022,668 processor cycles
  0 bytes consed

Tested at this revision, which is 'dirty' only for an unrelated change:
src/runtime/sbcl --core output/sbcl.core --version
SBCL 1.0.57.64-b75bc9d-dirty

[Douglas Katzman (dougk)]

OK, this kind of makes sense. All the quantifiers are defined in terms of (MAP NIL #'fn ...). The transform of MAP for a known sequence type ends up not demanding a closure over the functional arg, but the full call to MAP passes the functional arg which is not known to be downward. (Frankly I think that's *also* a bug: MAP never "holds on" to its functional arg but the compiler doesn't know it)

However, the solution for _this_ bug is in the compiler macros for the quantifiers. Even with a dynamic-extent declaration on my function RECURSE, that does not make the inner lambda also dynamic-extent.
(Which, by the way, also seems to contradict the premise that dynamic-extent is contagious!)

So forcing a dynamic-extent declaration into the expansion of the compiler-macro seems to do the trick:

diff --git a/src/code/seq.lisp b/src/code/seq.lisp
index bc678fd..58f5438 100644
--- a/src/code/seq.lisp
+++ b/src/code/seq.lisp
@@ -1183,17 +1183,17 @@ 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 (gensym "BLOCK")))
+ (blockname (gensym "BLOCK"))
+ (wrapped-pred (gensym "PRED")))
                     (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 ((,wrapped-pred (,@elements)
+ (let ((pred-value (funcall ,pred ,@elements)))
+ (,',found-test pred-value
+ (return-from ,blockname
+ ,',found-result)))))
+ (declare (dynamic-extent #',wrapped-pred))
+ (map nil #',wrapped-pred ,first-seq ,@more-seqs))
                          ,',unfound-result)))))))

I haven't built this in full yet, but it does appear to have fixed my test case.

[Paul Khuong (pvk)]

Fix committed in 441dfe5 (Make sure quantifiers don't cons). There were two sources of consing: the closure, but also the safety value cell to detect out-of-extent RETURN-FROM. Both have been extinguished.