;;; 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.
;;; 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
;;; 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 ...)
;;; (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)
(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)))
(thunk-label (gensym (symbol-name label))))
(push `(,label ,vars ,gensyms ,thunk-label) labels)
(push thunk-label thunks)
`(psetf ,@(mapcan (lambda (realvar gensym)
(push `(go ,label) thunks)
(setf thunk-gensyms (nconc gensyms thunk-gensyms))
(push label forms))))
(push item forms))))
`(macrolet ((goto (label &rest args)
(let* ((labels ',labels)
(matching-label (find label labels :key #'first)))
(error "ARGTAGS: goto undefined label ~a in block ~a"
(destructuring-bind (name vars gensyms thunk-label)
(declare (ignore name))
(when (/= (length args) (length vars))
(error "ARGTAGS: label ~a caled with wrong argument count in block ~a"
,@(if args `((psetf ,@(mapcan (lambda (gensym arg)
;;; (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)
(return (progn ,@forms))
;;; 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)))
(funcall escape next-call)
(let ((*tail-escape* (lambda (next)
(setf next-call next)
(apply (car next-call) (cdr next-call))))))))
(defmacro deftail (name lambda-list &body body)
(let ((escape (gensym "ESCAPE-"))
(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*))
(flet (,@(loop for other in other-tails
collecting `(,other (&rest args)
(let ((*tail-escape* ,escape))
(tail-call #',other args)))))
(tail-call (fun args)
(let ((*tail-escape* ,escape))
(tail-call fun args))))
(let ((*tail-escape* nil))