summaryrefslogtreecommitdiffstats
path: root/tail-recursion.lisp
blob: de3a6d2eb5643b4cb15352dcf9906b4b553bc10c (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
;;;
;;; ARGTAGS, TLET and DEFTAIL
;;; Copyright 2013 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 TLET 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.
;;;
;;; 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 all-vars 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
            (declare (ignore op))
         (let ((gensyms (mapcar (lambda (var)
                                  (gensym (symbol-name var)))
                                vars))
               (thunk-label (gensym (symbol-name label))))
                 (dolist (var vars)
                   (pushnew var all-vars))
           (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 called 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 ,@all-vars)
           (tagbody
             ,@(nreverse forms)
             (return-from ,block-name)
             ,@(nreverse thunks)))))))

;;;
;;; TLET
;;; ====
;;;
;;; (Thanks to Klaus Harbo for some fixes. to the original version
;;; which was called TAILPROG).
;;;
;;; 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 tlet (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 (progn ,@forms)) argtags-forms)
         (push `(,name (&rest args) `(goto ,',name ,@args)) macrolet-elems)))
     `(macrolet ,(reverse macrolet-elems)
        (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.
;;;
;;; NOTE: The Wikipedia describes a trampoline based approach for tail
;;; recursion, which is probably more or less equivalent to what is going on
;;; here. The *tail-escape* can be identified as the trampoline function.
;;;
;;; 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 TLET.
;;;

(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 (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))))))