Allocating closures on the stack

[pazzani@pan.ICS.UCI.EDU (Michael Pazzani)]

A while back, I complained that MCL allocates closures on the
heap, making mapping function more expensive than loop, do, etc.
Now, I've finally decided to do something about it.

THE PROBLEM:

For example:
(defun p(x y)(position-if #'(lambda(e)(oddp (+ e y)))))

? (time (p '(1 2 3 ) 1))
(P '(1 2 3) 1) took 1 milliseconds (0.001 seconds) to run.
 40 bytes of memory allocated.

A new closure is created and stored in the heap each time
p is called

(disassemble reveals that $SP-MKCLOSURE is called)
? (disassemble 'p)
0 (JSR_SUBPRIM $SP-TWO-ARGS-VPUSH)
4 (VPUSH '#<Anonymous Function #x8C6D6E>)
10 (VPUSH (VSP 4))
14 (SET_NARGS 2)
16 (JSR_SUBPRIM $SP-MKCLOSURE)
20 (MOVE.L ATEMP0 D1)
22 (MOVE.L (VSP 4) D0)
26 (SET_NARGS 2)
28 (SPOP VSP)
30 (JMP #'POSITION-IF)

A SOLUTION
(def-downward-funarg position-if 0)
creates a compiler macro that makes a flet, and
defines the function to have dynamic extent..  This calls
$SP-MKSTKCLOSURE which I presume puts the closure on the stack.

? (time (p '(1 2 3) 1))
(P '(1 2 3) 1) took 0 milliseconds (0.000 seconds) to run.
1


? (disassemble 'p)
0 (JSR_SUBPRIM $SP-TWO-ARGS-VPUSH)
4 (VPUSH '#<Compiled-function NOT-SO-ANONYMOUS-LAMBDA (Non-Global)  #x8BC716>)
10 (VPUSH (VSP 4))
14 (SET_NARGS 2)
16 (JSR_SUBPRIM $SP-MKSTKCLOSURE)
20 (VPUSH ATEMP0)
22 (MOVE.L @VSP D1)
24 (MOVE.L (VSP 8) D0)
28 (SET_NARGS 2)
30 (MOVE.L '#<POSITION-IF Symbol Function Locative> ATEMP0)
36 (JSR_SUBPRIM $SP-MVPASS)
40 (JSR_SUBPRIM $SP-POPNLISPAREA)
44 (JMP_SUBPRIM $SP-NVALRET)


Here's the code for def-downward-funarg, and declarations
for many functions that take functional arguments.  This reduced
the amount of space allocated by one system I used by about 10%
(since I use mapping functions a lot).  If you can think of any
improvements, please let me know.

Michael Pazzani
Associate Professor
Department of Information and Computer Science
University of California
Irvine, CA 92717-3425
phone (714) 856-5888
fax   (714) 856-4056
e-mail pazzani@ics.uci.edu



(defun function-lambda-p(x)
  (and (consp x)
       (eq (car x) 'function)
       (consp (cadr x))
       (eq (car (cadr x)) 'lambda)))


(defun create-compiler-macro(name functional-argument-position)
  (cond ((gethash name ccl::*compiler-macros*)
	 (format t "~%;~A already defined." name) nil)
	(t
	 `(define-compiler-macro ,name (&rest args)
	    (let ((funarg (nth ,functional-argument-position args)))
	      (if (function-lambda-p funarg)
		  (make-flet  funarg ',name ,functional-argument-position args)
		          (cons ',name args)))))))

(defun make-flet(funarg new-name functional-argument-position args &aux (body (copy-list args)))
  (setf (nth functional-argument-position body)
    (list 'function 'not-so-anonymous-lambda))
  `(flet ((not-so-anonymous-lambda ,(cadr (cadr funarg)) ,@(cddr (cadr funarg))))
     (declare (dynamic-extent #'not-so-anonymous-lambda))
     ,(cons new-name body)))

(defmacro def-downward-funarg (name number)
  (create-compiler-macro name number))

;(def-downward-funarg APPLY 0)
(def-downward-funarg FUNCALL 0)
;(def-downward-funarg MAPCAR 0)
;(def-downward-funarg MAPC 0)
(def-downward-funarg MAPCAN 0)
(def-downward-funarg MAPCON 0)
(def-downward-funarg MAP 1)
(def-downward-funarg MAPLIST 0)
(def-downward-funarg COUNT-IF 0)
(def-downward-funarg NSUBSTITUTE-IF-NOT 1)
(def-downward-funarg DELETE-IF-NOT 0)
(def-downward-funarg FIND-IF 0)
(def-downward-funarg NSUBSTITUTE-IF 1)
(def-downward-funarg MEMBER-IF-NOT 0)
(def-downward-funarg DELETE-IF 0)
(def-downward-funarg SUBST-IF 1)
(def-downward-funarg SUBST-IF-NOT 1)
(def-downward-funarg NSUBST-IF-NOT 1)
(def-downward-funarg REMOVE-IF 0)
(def-downward-funarg SUBSTITUTE-IF-NOT 1)
(def-downward-funarg POSITION-IF-NOT 0)
(def-downward-funarg POSITION-IF 0)
(def-downward-funarg NSUBST-IF 1)
(def-downward-funarg SUBSTITUTE-IF 1)
(def-downward-funarg REMOVE-IF-NOT 0)
(def-downward-funarg MEMBER-IF 0)
(def-downward-funarg FIND-IF-NOT 0)
(def-downward-funarg COUNT-IF-NOT 0)
(def-downward-funarg REDUCE 0)
;(def-downward-funarg NOTANY 0)
;(def-downward-funarg NOTEVERY 0)
(def-downward-funarg RASSOC-IF-NOT 0)
(def-downward-funarg RASSOC-IF 0)
(def-downward-funarg ASSOC-IF-NOT 0)
(def-downward-funarg ASSOC-IF 0)
(def-downward-funarg STABLE-SORT 1)
;(def-downward-funarg SOME 0)
(def-downward-funarg SORT 1)
(def-downward-funarg MERGE 3)
;(def-downward-funarg EVERY 0)


#|
(do-symbols (s)  ;try predicate and test also
    (when (member 'function (arglist s))
      (format t "~%(def-downward-funarg ~a ~a)"
              s (position 'function (arglist s) ))))

(defun p(x y)(position-if #'(lambda(e)(oddp (+ e y))) x))
(time (p '(1 2 3 ) 1))



|#