;;; ;;; ARGTAGS, TAILPROG and DEFTAIL ;;; Copyright 2012 Kaz Kylheku ;;; ;;; ;;; 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 `(,name)) (anon-block (gensym)) (docstring) (decls)) (when (stringp (first body)) (setf docstring (list (first body))) (pop body)) (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*)) ,@docstring ,@decls (block ,anon-block (flet (,@(loop for other in other-tails collecting `(,other (&rest args) (return-from ,anon-block (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))))))