Tail recursion

[Cohen@MCC.COM (Richard M. Cohen)]

There was some discussion about tail recursion optimization a few
months back.  I put together a small hack that handles the simple
cases of tail recursion.  It does not attack the general case
of tail-calls (i.e., reusing the current stack frame for any
tail call, not just recursive ones).

Basically, this is a compiler optimizer that operates on simple
tail recursive functions to change the tail-recursive calls to goto's.

This hack only handles "simple tail-recursive calls", meaning those that
don't represent recursive calls made in a modified global context (i.e.,
with any specials rebound, or dynamic handlers rebound).  It also
doesn't address mutually recursive functions, since they don't involve
tail recursion.

I'm throwing this out to community in hopes that it may a prove useful,
though not complete, solution to the problem.  (It did address the
problem that most recently sparked the discussion!)

There are some (hopefully) illustrative examples at the end of the code

Cheers,

-- Rich

;;; -*- Mode: LISP; Syntax: Common-lisp; Package: USER; Base: 10 -*-

;;1 ----------------------------------------------------------------------------
0;;
;;1 Define a compiler optimizer for the simple cases of tail recursion.

0;;1 The optimizer only takes any action on function bodies that are
0;;1 tail-recursive in simple ways.  (That is, don't involve any special
0;;1 forms, such as UNWIND-PROTECT, or CATCH around the recursive calls2;
0;;1 also avoid the issues of encapsulations with stack-consed objects2;
0;;1 optimizing such complex calls is not practical.)
0;;
;;1 We don't try to optimize recursive calls:
0;;
;;1 (0) in any Flavor or CLOS method (or defun-in-method),
0;;1 (1) inside of LET's that rebind any of the functions formal parameters,
0;;1 (2) recursive calls inside of calls to RETURN,
0;;1 (3) embedded in any but a few well-understood and well-behaved special forms
0;;1     (i.e., PROGN, BLOCK, LET, IF, COND),
0;;1 (4) embedded in a macro.
0;;
;;1 Set *OPTIMIZE-TAIL-RECURSION* to :VERBOSE to see what gets done.
0;;
;;1 ----------------------------------------------------------------------------


0;;1 ----------------------------------------------------------------------------
0;;1 Known problems with this code:
0;;
;;1 (1) It doesn't interface properly with in-core compilation.
0;;1     Compiling from a ZMACS buffer will use these optimizations,
0;;     1but compiling an interpreted definition won't.
0;;
;;1 (2) I use 0sys:Special-Variable-P1 to test for special variable bindings
0;;     1to avoid losing LET bindings of special variables.  Is this the right
0;;     1test?
0;;
;;1 ----------------------------------------------------------------------------


0;; -------------------------------- 1Change Log0 --------------------------------
;;
;;1 17-Sep-900	1RMC0	1Try to optimize the simple tail-recursive cases.
0;;1 18-Sep-900	1RMC0	1Don't optimize through LET bindings of global variables.
0;;
;; ----------------------------------------------------------------------------



;;1 Here's how to remove the optimizer, if you want to.
0;;
;;1 0(Compiler:Delete-1Optimizer0 1function0 Optimize-Tail-Recursion)


(defvar 3*Optimize-Tail-Recursion* 0T)	;2set to :VERBSE to watch tail-recursion elimination.

0;;1 DEFUN expands into an (FDEFINE FOO (FUNCTION (LAMBDA (...) ...)))
0;;1 So, we put the tail-recursion optimizer on FUNCTION.


0(Compiler:DefOptimizer (3Function0 3Optimize-Tail-Recursion0) (form)
  (let ((Optimized-Form
	  (compiler:Matchp Form
	    (('Function ('lambda Formal-Args
			 ('declare ('sys:function-name name))
			 . body))
	     ;;2 Don't try to optimize:
0	     ;;2 (1) Methods & defun-in-flavor's (NAME won't be an atom)
0	     ;;2 (2) functions whose arglist contains any lambda-list-keyword.
0	     ;;2      (I don't want to worry about mapping actuals to formals for them.)
0	     (if (and (symbolp Name)
		      (null (intersection Formal-Args lambda-list-keywords))
		      (tail-recursive-p `(progn ,.body) Name Formal-Args))
		 `(Function (lambda ,Formal-Args
			      (declare (sys:Function-Name ,Name))
			      ,(Remove-Tail-Recursion body Name Formal-Args)))
		 form))
	    (* form))))
    (if *Optimize-Tail-Recursion*
	(progn (when (and (not (equal Form Optimized-Form))
			  (or (eql *Optimize-Tail-Recursion* ':Verbose)
			      compiler:*trace-optimize-form*))
		 (let ((cl:*print-pretty* t))
		   (format *trace-output* "~&~S -> ~S" form Optimized-Form)))
	       Optimized-Form)
	Form)))

(defun 3Remove-Tail-Recursion 0(Body Name Formal-Args)
  "Surround BODY by a BLOCK/TAGBODY so that tail-recursive calls can be
   replaced with some SETQ's and a GO."
  (let ((Outer-Block (gensym (symbol-name Name)))
	(Restart-Tag (gensym (string-append "RESTART-" (symbol-name Name)))))
    (gensym "G")
    `(block ,Outer-Block
       (TagBody ,Restart-Tag
		(return-from ,Outer-Block
		  (progn 
		    ,@(sublis (mapcar #'(lambda (Call)
					  (cons Call
						(Convert-Tail-Recursive-Call
						  Call
						  Formal-Args
						  Restart-Tag)))
				      (Body-Extract-Tail-Recursive-Calls
					Body
					Name
					Formal-Args))
			    Body)))))))

(defun 3Convert-Tail-Recursive-Call 0(Call Formal-Args Restart-Tag)
  "Convert a (tail-recursive) function call into some SETQ's and a GO."
  `(progn (psetq ,@(mapcan #'(lambda (Formal Actual)
			       `(,Formal ,Actual))
			   Formal-Args (cdr Call)))
	  (go ,Restart-Tag)))

;;
;;1 Test whether a form is tail recursive
0;;

(defun 3Tail-Recursive-P 0(form Name Formal-Args)
  "Does FORM make a tail call to the function NAME?
   (i.e., assuming FORM is part of the body for function NAME)"
  (and (consp form)
       (symbolp (car form))
       (funcall (get (car form) 'Tail-Recursive-P 'Immediate-Recursive-Call-P)
		form name Formal-Args)))

(defun 3Body-Tail-Recursive-P 0(Form Name Formal-Args)
  (Tail-Recursive-P (car (last Form)) name Formal-Args))

(defun 3Progn-Form-Tail-Recursive-P 0(form name Formal-Args)
  (Body-Tail-Recursive-P (cdr Form) Name Formal-Args))

(defun 3Let-Form-Tail-Recursive-P 0(form name Formal-Args)
  "We only consider LET's to be tail recursive if they don't rebind
   any of the function's formal arguments."
  ;;2 We want to use simple SETQ's to change the arguments for recursive calls.
0  ;;2 If we allowed LET's that capture the formal arg names, that wouldn't work.
0  (and (Tail-Recursion-Filter-For-Let Form Formal-Args)
       (Body-Tail-Recursive-P (cddr form) name Formal-Args)))

(defun 3Tail-Recursion-Filter-For-Let 0(Form Formal-Args)
  (let ((Bound-Vars (mapcar #'(lambda (X) (if (consp X) (car X) X))
			    (second Form))))
    ;;2 We don't try to optimize if the LET rebinds a formal parameter, or a global.
0    ;;2 (because the global binding would be popped off when we go to the restart tag.)
0    (and (null (intersection Formal-Args Bound-Vars))
	 (not (some #'sys:Special-Variable-P Bound-Vars)))))

(defun 3If-Form-Tail-Recursive-P 0(form name Formal-Args)
  (or (tail-recursive-p (third form) name Formal-Args)
      (tail-recursive-p (fourth form) name Formal-Args)))

(defun 3Cond-Form-Tail-Recursive-P 0(form name Formal-Args)
  (some #'(lambda (Clause)
	    (Body-Tail-Recursive-P Clause Name Formal-Args))
	(cdr Form)))

(defun 3Immediate-Recursive-Call-P 0(Form Name Formal-Args)
  (declare (ignore Formal-Args))
  (and (Proper-List-P Form)
       (eql (car Form) Name)))

(defprop 3Let 0 3 0  Let-Form-Tail-Recursive-P Tail-Recursive-P)
(defprop 3Progn 0Progn-Form-Tail-Recursive-P Tail-Recursive-P)
(defprop 3Block 0Progn-Form-Tail-Recursive-P Tail-Recursive-P)
(defprop 3If 0  3 0   If-Form-Tail-Recursive-P Tail-Recursive-P)
(defprop 3Cond  0 Cond-Form-Tail-Recursive-P Tail-Recursive-P)

;;
;;1 Extract tail-recursive calls form a form.
0;;
;;1 These are the actual lists appearing in the form,
0;;1 as they are later passed to SUBLIS, which uses an EQL test.
0;;

(defun 3Extract-Tail-Recursive-Calls 0(Form Name Formal-Args)
  "Extract sublists of FORM that represent tail-recursive calls to NAME.
   (i.e., assuming FORM is part of the body for function NAME)"
  (when (and (Proper-List-P form)
	     (symbolp (car form)))
    (let ((Extractor (get (car Form) 'Extract-Tail-Recursive-Calls #'Extract-Immediate-Recursive-Call)))
      (when Extractor
	(funcall Extractor Form Name Formal-Args)))))

(defun 3Body-Extract-Tail-Recursive-Calls 0(Form Name Formal-Args)
  (let ((Candidate (last Form)))
    (when (Proper-List-P (car Candidate))
      (Extract-Tail-Recursive-Calls (car Candidate) Name Formal-Args))))

(defun 3Progn-Form-Extract-Tail-Recursive-Calls 0(Form Name Formal-Args)
  (Body-Extract-Tail-Recursive-Calls (cdr Form) Name Formal-Args))

(defun 3Let-Form-Extract-Tail-Recursive-Calls 0(Form Name Formal-Args)
  ;;2 We want to use simple SETQ's to change the arguments for recursive calls.
0  ;;2 If we allowed LET's that capture the formal arg names, that wouldn't work.
0  (when (Tail-Recursion-Filter-For-Let Form Formal-Args)
    (Body-Extract-Tail-Recursive-Calls (cddr Form) Name Formal-Args)))

(defun 3If-Form-Extract-Tail-Recursive-Calls 0(Form Name Formal-Args)
  (append (Extract-Tail-Recursive-Calls (third Form) Name Formal-Args)
	  (Extract-Tail-Recursive-Calls (fourth Form) Name Formal-Args)))

(defun 3Cond-Form-Extract-Tail-Recursive-Calls 0(form name Formal-Args)
  (mapcan #'(lambda (Clause)
	      (Body-Extract-Tail-Recursive-Calls Clause Name Formal-Args))
	  (cdr Form)))

(defun 3Extract-Immediate-Recursive-Call 0(Form Name Formal-Args)
  (declare (ignore Formal-Args))
  (when (and (Proper-List-P Form)
	     (eql Name (car Form)))
    (list Form)))

(defprop 3Progn 0Progn-Form-Extract-Tail-Recursive-Calls  Extract-Tail-Recursive-Calls)
(defprop 3Let 0 3 0 3 0Let-Form-Extract-Tail-Recursive-Calls  Extract-Tail-Recursive-Calls)
(defprop 3Block 0Progn-Form-Extract-Tail-Recursive-Calls  Extract-Tail-Recursive-Calls)
(defprop 3If 0     3 0If-Form-Extract-Tail-Recursive-Calls  Extract-Tail-Recursive-Calls)
(defprop 3Cond 0 3 0Cond-Form-Extract-Tail-Recursive-Calls  Extract-Tail-Recursive-Calls)

;;
;;1 Utilities
0;;

(defun 3Proper-List-P 0(Thing)
  (and (consp Thing)
       (null (cdr (last Thing)))))

;;
;;1 A couple of tail-recursive functions...
0;;

#||

 (defun 3My-Member 0(X L)
   (if (null L)
       NIL
       (if (eql X (car L))
	   L
	   (My-Member X (cdr L)))))
 
 (defun 3Foo 0(x y z)
   (if (= X 0)
       (+ Y Z)
       (if (< X Y)
	   (Foo (1- X) Y Z)
	   (Foo (1- Y) X Z))))

(defmacro 3With-It 0((&rest Bindings) &body Body)
  `(let ,Bindings
     ,@(copy-list Body)))

(defun 3Foo-2 0(X Y Z)
  (With-It ((Q X))
    (if (= Q 0)
	(+ Y Z)
	(if (< X Y)
	    (Foo-2 (1- X) Y Z)
	    (Foo-2 (1- Y) X Z)))))

;;1 BAR does not have its tail-recusive call optimized,
0;;1 because the tail-recursive call is "protected" by the CATCH
0;;1 and UNWIND-PROTECT.  We only optimize when we can "see"
0;;1 the tail-recursive call through forms we know don't
0;;1 control function evaluation in special ways.

0 (defun 3Bar 0(X Y)
   (catch Bar-Tag
     (unwind-protect
	 (if (plusp X)
	     (Bar (1- X) Y)
	     (throw Bar-Tag Y))
       (tv:beep))))
 
 (defun 3Foo-With-Let 0(x y z)
   (if (= X 0)
       (+ Y Z)
       (if (< X Y)
	   (let ((Z (+ X Y)))
	     ;;2 This recursive call won't get removed
0	     ;;2 (because the LET captures the formal param Z)
0	     (Foo-with-let (1- X) Y Z))
	   (let ((Zz (+ X Y)))
	     ;;2 This one will.
0	     (Foo-with-let (1- Y) X Zz)))))

;;1 Here's the macro expansion of the DEFUN FOO

0 (progn
   (EVAL-WHEN (COMPILE)
     (COMPILER:FILE-DECLARE 'FOO 'DEF 'NIL))
   (FDEFINE 'FOO
	    #'(LAMBDA (X Y Z)
		(DECLARE (SYS:FUNCTION-NAME FOO))
		NIL
		(BLOCK FOO
		  (IF (= X 0) (+ Y Z) (IF (< X Y) (FOO (1- X) Y Z) (FOO (1- Y) X Z)))))
	    T)
   'FOO)

;;1 Here's the lambda function after removing tail recursion.
0 (fdefine 'Foo
	  #'(LAMBDA (X Y Z)
	      (DECLARE #'FOO)
	      (BLOCK #:FOO5403
		(TagBody
		  #:RESTART-FOO5404 (RETURN-FROM #:FOO5403
				      (PROGN
					NIL
					(BLOCK FOO
					  (IF (= X 0)
					      (+ Y Z)
					      (IF (< X Y)
						  (progn
						    (SETQ X (1- X))
						    (SETQ Y Y)
						    (SETQ Z Z)
						    (GO #:RESTART-FOO5404))
						  (progn
						    (SETQ X (1- Y))
						    (SETQ Y X)
						    (SETQ Z Z)
						    (GO #:RESTART-FOO5404)))))))))))

;;1 These generic function methods shouldn't be optimized, because
0;;1 changing the arguments can affect the dispatch so that some
0;;1 other method is invoked.  (The optimizer can detect them because
0;;1 their internal function specifiers are lists, not symbols.)

0 (SCL:defmethod 3(Frob 0fs:Alto-Host3)0 (X)
   (if (Foo X)
       (Bar X)
       (Frob self (1- X))))
 
 (SCL:defun-in-flavor 3(Frob-Internal 0fs:Alto-Host3)0 (X)
   (if (Foo X)
       (Bar X)
       (Frob self (1- X))))
 
 (Clos:defmethod 3CFrob 0((self 3Clos:Standard-Class)0 X)
   (if (Foo X)
       (Bar X)
       (CFrob self (1- X))))

||#

;;
;;1 End of File
0;;