diff options
Diffstat (limited to 'tail-recursion.lisp')
| -rw-r--r-- | tail-recursion.lisp | 274 |
1 files changed, 274 insertions, 0 deletions
diff --git a/tail-recursion.lisp b/tail-recursion.lisp new file mode 100644 index 0000000..7940113 --- /dev/null +++ b/tail-recursion.lisp @@ -0,0 +1,274 @@ +;;; +;;; ARGTAGS, TAILPROG and DEFTAIL +;;; Copyright 2012 Kaz Kylheku +;;; <kaz@kylheku.com> +;;; +;;; This Lisp source contains three ideas which reveal tail recursion +;;; to be a syntactic sugar for goto, and then implement primitives +;;; which disguise goto behind a more disciplined interface +;;; which resembles function calling. +;;; +;;; First ARGTAGS is presented. Then a macro called TAILPROG which +;;; builds a slightly higher level abstraction on ARGTAGS. +;;; +;;; Finally a scheme, no pun intended, for cross-module tail calling +;;; is presented in the form of function-defining macro DEFTAIL. +;;; + +;;; +;;; ARGTAGS +;;; ======= +;;; +;;; The idea is to extend TAGBODY in a simple way: give the tags named +;;; parameters, and thus provide a GOTO that takes argument expressions. The +;;; parameters are simply the names of variables that are in scope of the +;;; body, and the GOTO simply assigns the argument value to the +;;; variables. The syntactic convenience is considerable though. And there /is/ +;;; a subtlety: shadowing is handled. If a GOTO occurs in some inner scope +;;; in which a a label parameter is shadowed, the GOTO will properly +;;; initialize the outer variable. It won't blindly assign to the inner +;;; variable. +;;; +;;; With this, you can express tail recursion, including mutual tail +;;; recursion, with nearly the same syntactic sugar. And it turns into +;;; stackless iteration: jumping around within a TAGBODY. +;;; +;;; E.g. in the thread ``better way to enumerate'', viper-2 posted this: +;;; +;;; (defun enumerate-with-op (start end &optional elist) +;;; (if (> start end) +;;; (reverse elist) +;;; (enumerate-with-op (1+ start) end +;;; (cons start elist)))) +;;; +;;; With the ARGTAGS macro, we can write ENUMERATE like this, and not rely +;;; on tail recursion optimization: +;;; +;;; ;; should be called IOTA or some variation thereof +;;; +;;; (defun enumerate (start end) +;;; (let (result-list) +;;; (argtags nil +;;; (label enumerate start end result-list) +;;; (when (> start end) +;;; (return (nreverse result-list))) +;;; (goto enumerate (1+ start) end (cons start result-list))))) +;;; +;;; Since tail recursion /is/ a freaking goto, damn it, just express it +;;; that way! You don't need to write a compiler, and consequently you +;;; don't need to duck out of mutual tail recursion because that part of +;;; the compiler turns out to be too hard to write. +;;; +;;; Anyone have any interesting mutual tail recursion examples? I'd like +;;; to try rewriting them using ARGTAGS. +;;; +;;; The implementation of ARGTAGS follows. There is clutter due to error +;;; checking, and also due to the handling of the shadowing problem. The +;;; strategy is to turn +;;; +;;; (GOTO L A1 A2 ...) +;;; +;;; into +;;; +;;; (PROGN (PSETF #:G0100 A1 #:G0101 A2 ...) (GO #:G0001)) +;;; +;;; Where #:G0001 is a label within a thunk section that is inserted at +;;; the end of the body. The entry in the thunk section looks like this: +;;; +;;; #:G0001 (PSETF V1 #:G0100 V2 #:G0101 ...) (GO L) +;;; +;;; Where V1 V2 ... are the real variables (parameters of label L). I.e. +;;; we store the arguments into some secret local gensym variables, jump +;;; to a thunk, thereby leaving the scope where the real variables might +;;; be shadowed, then load the real variables from the secret gensyms and +;;; bounce to the real target label. +;;; + +(defmacro argtags (block-name &rest labels-and-forms) + (unless (symbolp block-name) + (error "ARGTAGS: block name must be a symbol, not ~a!" block-name)) + (let (labels forms thunks thunk-gensyms) + (dolist (item labels-and-forms) + (cond + ((symbolp item) + (push `(,item () () ,item) labels) + (push item forms)) + ((and (consp item) + (eq (first item) 'label)) + (unless (and (symbolp (second item)) + (listp (rest (rest item))) + (every #'symbolp (rest (rest item)))) + (error "ARGTAGS: bad label syntax ~a in block ~a" item block-name)) + (destructuring-bind (op label &rest vars) item + (let ((gensyms (mapcar (lambda (var) + (gensym (symbol-name var))) + vars)) + (thunk-label (gensym (symbol-name label)))) + (push `(,label ,vars ,gensyms ,thunk-label) labels) + (push thunk-label thunks) + (push + `(psetf ,@(mapcan (lambda (realvar gensym) + `(,realvar ,gensym)) + vars gensyms)) + thunks) + (push `(go ,label) thunks) + (setf thunk-gensyms (nconc gensyms thunk-gensyms)) + (push label forms)))) + (t + (push item forms)))) + `(macrolet ((goto (label &rest args) + (let* ((labels ',labels) + (matching-label (find label labels :key #'first))) + (unless matching-label + (error "ARGTAGS: goto undefined label ~a in block ~a" + label ',block-name)) + (destructuring-bind (name vars gensyms thunk-label) + matching-label + (declare (ignore name)) + (when (/= (length args) (length vars)) + (error "ARGTAGS: label ~a caled with wrong argument count in block ~a" + label ',block-name)) + `(progn + ,@(if args `((psetf ,@(mapcan (lambda (gensym arg) + `(,gensym ,arg)) + gensyms args)))) + (go ,thunk-label)))))) + (block ,block-name + (let (,@thunk-gensyms) + (tagbody + ,@(nreverse forms) + (return-from ,block-name) + ,@(nreverse thunks))))))) + + +;;; +;;; TAILPROG +;;; ======== +;;; +;;; (Thanks to Klaus Harbo for some fixes). +;;; +;;; This macro provides wraps more syntactic sugar around ARGTAGS, +;;; giving rise to a syntax which resembles the Lisp LABELS. +;;; Tail-recursive thunks are thus defined in a way such that they +;;; look like functions. Except that the calls are really goto, +;;; and never return (even if they are made in a non-tail position!) +;;; +;;; This is actually better than tail recursion, because the calls +;;; are always goto! Nothing can interfere with them. Even if you use +;;; the value of such a call, it still does not return. +;;;; + +(defmacro tailprog (let-bindings pseudo-funcs &rest forms) + (let (argtags-forms macrolet-elems) + (dolist (pfunc pseudo-funcs) + (destructuring-bind (name vars &rest forms) pfunc + (push `(label ,name ,@vars) argtags-forms) + (push `(return ,@forms) argtags-forms) + (push `(,name (&rest args) `(goto ,',name ,@args)) macrolet-elems))) + `(macrolet ,(reverse macrolet-elems) + (let ,let-bindings + (argtags nil + (return (progn ,@forms)) + ,@(reverse argtags-forms)))))) + +;;; +;;; DEFTAIL +;;; ======= +;;; This is a continuation of the same idea that tail calling is not exactly +;;; functions but more like goto with parameters. I will refer to a block of +;;; code that is the target of a goto with parameters a ``tail block'' +;;; to distinguish it from ``function''. +;;; +;;; In this prototype implementation, for pragmatic reasons, we make tail +;;; blocks compatible with functions. A tail block can be invoked from +;;; ordinary code as an ordinary function call. It distinguishes whether it +;;; was called in this ordinary way, or whether it was called from another +;;; tail block through the tail dispatch loop. +;;; +;;; The tail call mechanism is hidden behind a function called TAIL-CALL, +;;; whose interface and semantics are similar to FUNCALL. The difference is +;;; that when TAIL-CALL is invoked from a tail block, it causes that tail +;;; block to terminate before the call takes place. +;;; +;;; The basic idea is that when a tail block (that is implemented as a +;;; function) calls another tail block, it is being permanently exited (goto +;;; semantics, the tail call does not return). Therefore the underlying +;;; function which implements the tail block can simply be terminated. We +;;; don't worry about low-level details like how our target virtual machine +;;; handles stack frames. +;;; +;;; In Lisp, the abandoning an evaluation frame is done by performing a, +;;; non-local control transfer to some exit point that is dynamically +;;; outside of that activation. We must perform this abandonment first, and +;;; afterward bring into effect the tail call. This is done by transferring +;;; the information about the call we want to the exit point, which then +;;; calls the function. When functions mutually recurse, they do so by +;;; bailing out dynamically to a dispatching loop which calls the next +;;; function in the chain. +;;; +;;; It would be inconvenient to have to use TAIL-CALL everywhere in a tail +;;; block. We can hide the tail call mechanism behind lexical functions, so +;;; that a tail block can use ordinary function call syntax to call its +;;; siblings (other tail blocks involved in the cross-module loop). A tail +;;; block defining is provided which can set up these lexical functions, +;;; when given a list of sibling names, and then tail calls look like +;;; ordinary function calls. Only higher-order functional +;;; arguments have to be specially treated with the use of TAIL-CALL +;;; insteadof FUNCALL. (FUNCALL will work too, of course, but it will +;;; not terminate the tail block and so the call won't be a tail call). +;;; +;;; A very simple test case illustrates the syntax: DEFTAIL instead of +;;; DEFUN, and an optional (:OTHER-TAILS ...) at the beginning (may +;;; be mixed among declarations). +;;; +;;; (deftail even (num) +;;; (:other-tails odd) +;;; (if (zerop num) t (odd (1- num)))) +;;; +;;; (deftail odd (num) +;;; (:other-tails even) +;;; (if (zerop num) nil (even (1- num)))) +;;; +;;; This is still a GOTO-like abstraction, because tail calls are tail +;;; calls even if they are not in a tail position. They never return, +;;; just like in TAILPROG. +;;; + +(defvar *tail-escape* nil) + +(defun tail-call (fun args) + (let ((escape *tail-escape*) + (next-call (cons fun args))) + (if escape + (funcall escape next-call) + (tagbody + :repeat + (let ((*tail-escape* (lambda (next) + (setf next-call next) + (go :repeat)))) + (return-from tail-call + (apply (car next-call) (cdr next-call)))))))) + +(defmacro deftail (name lambda-list &body body) + (let ((escape (gensym "ESCAPE-")) + (other-tails) + (decls)) + (loop for f = (first body) + while (and (consp f) + (case (first f) + (:other-tails (setf other-tails + (append other-tails (rest f))) t) + (declare (setf decls (append decls (rest f))) t))) + do (pop body)) + `(defun ,name (,@lambda-list &aux (,escape *tail-escape*)) + ,@decls + (flet (,@(loop for other in other-tails + collecting `(,other (&rest args) + (return-from ,name + (let ((*tail-escape* ,escape)) + (tail-call #',other args))))) + (tail-call (fun args) + (let ((*tail-escape* ,escape)) + (tail-call fun args)))) + (let ((*tail-escape* nil)) + ,@body))))) |