1 ;;; Continuation-passing style (CPS) intermediate language (IL)
3 ;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
5 ;;;; This library is free software; you can redistribute it and/or
6 ;;;; modify it under the terms of the GNU Lesser General Public
7 ;;;; License as published by the Free Software Foundation; either
8 ;;;; version 3 of the License, or (at your option) any later version.
10 ;;;; This library is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;;; Lesser General Public License for more details.
15 ;;;; You should have received a copy of the GNU Lesser General Public
16 ;;;; License along with this library; if not, write to the Free Software
17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
21 ;;; This is the continuation-passing style (CPS) intermediate language
24 ;;; There are two kinds of terms in CPS: terms that bind continuations,
25 ;;; and terms that call continuations.
27 ;;; $letk binds a set of mutually recursive continuations, each one an
28 ;;; instance of $cont. A $cont declares the name of a continuation, and
29 ;;; then contains as a subterm the particular continuation instance:
30 ;;; $kif for test continuations, $kargs for continuations that bind
33 ;;; $continue nodes call continuations. The expression contained in the
34 ;;; $continue node determines the value or values that are passed to the
35 ;;; target continuation: $const to pass a constant value, $values to
36 ;;; pass multiple named values, etc. $continue nodes also record the source at which
38 ;;; Additionally there is $letrec, a term that binds mutually recursive
39 ;;; functions. The contification pass will turn $letrec into $letk if
40 ;;; it can do so. Otherwise, the closure conversion pass will desugar
41 ;;; $letrec into an equivalent sequence of make-closure primcalls and
42 ;;; subsequent initializations of the captured variables of the
43 ;;; closures. You can think of $letrec as pertaining to "high CPS",
44 ;;; whereas later passes will only see "low CPS", which does not have
47 ;;; This particular formulation of CPS was inspired by Andrew Kennedy's
48 ;;; 2007 paper, "Compiling with Continuations, Continued". All Guile
49 ;;; hackers should read that excellent paper! As in Kennedy's paper,
50 ;;; continuations are second-class, and may be thought of as basic block
51 ;;; labels. All values are bound to variables using continuation calls:
54 ;;; There are some Guile-specific quirks as well:
56 ;;; - $kreceive represents a continuation that receives multiple values,
57 ;;; but which truncates them to some number of required values,
58 ;;; possibly with a rest list.
60 ;;; - $kentry labels an entry point for a $fun (a function), and
61 ;;; contains a $ktail representing the formal argument which is the
62 ;;; function's continuation.
64 ;;; - $kentry also contains $kclause continuations, corresponding to
65 ;;; the case-lambda clauses of the function. $kclause actually
66 ;;; contains the clause body. This is because the $kclause
67 ;;; logically matches or doesn't match a given set of actual
68 ;;; arguments against a formal arity, then proceeds to a "body"
69 ;;; continuation (which is a $kargs).
71 ;;; That's to say that a $fun can be matched like this:
74 ;;; (($ $fun src meta free
76 ;;; ($ $kentry self ($ $cont ktail _ ($ $ktail))
77 ;;; (($ $kclause arity
78 ;;; ($ $cont kbody _ ($ $kargs names syms body)))
82 ;;; A $continue to ktail is in tail position. $kentry, $kclause,
83 ;;; and $ktail will never be seen elsewhere in a CPS term.
85 ;;; - $prompt continues to the body of the prompt, having pushed on a
86 ;;; prompt whose handler will continue at its "handler"
87 ;;; continuation. The continuation of the prompt is responsible for
88 ;;; popping the prompt.
92 ;;; - $letk, $letrec, and $continue are terms.
94 ;;; - $cont is a continuation, containing a continuation body ($kargs,
97 ;;; - $continue terms contain an expression ($call, $const, $fun,
100 ;;; See (language tree-il compile-cps) for details on how Tree-IL
105 (define-module (language cps)
106 #:use-module (ice-9 match)
107 #:use-module ((srfi srfi-1) #:select (fold))
108 #:use-module (srfi srfi-9)
109 #:use-module (srfi srfi-9 gnu)
115 $letk $continue $letrec
120 ;; Continuation bodies.
121 $kif $kreceive $kargs $kentry $ktail $kclause
124 $void $const $prim $fun $call $callk $primcall $values $prompt
127 label-counter var-counter
128 fresh-label fresh-var
129 let-fresh let-gensyms
132 build-cps-term build-cps-cont build-cps-exp
133 rewrite-cps-term rewrite-cps-cont rewrite-cps-exp
136 parse-cps unparse-cps
137 fold-conts fold-local-conts))
139 ;; FIXME: Use SRFI-99, when Guile adds it.
140 (define-syntax define-record-type*
142 (define (id-append ctx . syms)
143 (datum->syntax ctx (apply symbol-append (map syntax->datum syms))))
146 (and (identifier? #'name) (and-map identifier? #'(field ...)))
147 (with-syntax ((cons (id-append #'name #'make- #'name))
148 (pred (id-append #'name #'name #'?))
149 ((getter ...) (map (lambda (f)
150 (id-append f #'name #'- f))
152 #'(define-record-type name
158 (define-syntax-rule (define-cps-type name field ...)
160 (define-record-type* name field ...)
161 (set-record-type-printer! name print-cps)))
163 (define (print-cps exp port)
164 (format port "#<cps ~S>" (unparse-cps exp)))
167 (define-record-type* $arity req opt rest kw allow-other-keys?)
170 (define-cps-type $letk conts body)
171 (define-cps-type $continue k src exp)
172 (define-cps-type $letrec names syms funs body)
175 (define-cps-type $cont k cont)
176 (define-cps-type $kif kt kf)
177 (define-cps-type $kreceive arity k)
178 (define-cps-type $kargs names syms body)
179 (define-cps-type $kentry self tail clauses)
180 (define-cps-type $ktail)
181 (define-cps-type $kclause arity cont)
184 (define-cps-type $void)
185 (define-cps-type $const val)
186 (define-cps-type $prim name)
187 (define-cps-type $fun src meta free body)
188 (define-cps-type $call proc args)
189 (define-cps-type $callk k proc args)
190 (define-cps-type $primcall name args)
191 (define-cps-type $values args)
192 (define-cps-type $prompt escape? tag handler)
194 (define label-counter (make-parameter #f))
195 (define var-counter (make-parameter #f))
197 (define (fresh-label)
198 (let ((count (label-counter)))
199 (label-counter (1+ count))
202 ;; FIXME: Currently vars and labels need to be unique, so we use the
205 (let ((count (label-counter)))
206 (label-counter (1+ count))
209 (define-syntax-rule (let-fresh (label ...) (var ...) body ...)
210 (let ((label (fresh-label)) ...
211 (var (fresh-var)) ...)
214 (define-syntax let-gensyms
216 ((_ (sym ...) body body* ...)
217 (let ((sym (gensym (symbol->string 'sym))) ...)
220 (define-syntax build-arity
221 (syntax-rules (unquote)
222 ((_ (unquote exp)) exp)
223 ((_ (req opt rest kw allow-other-keys?))
224 (make-$arity req opt rest kw allow-other-keys?))))
226 (define-syntax build-cont-body
227 (syntax-rules (unquote $kif $kreceive $kargs $kentry $ktail $kclause)
232 ((_ ($kreceive req rest kargs))
233 (make-$kreceive (make-$arity req '() rest '() #f) kargs))
234 ((_ ($kargs (name ...) (sym ...) body))
235 (make-$kargs (list name ...) (list sym ...) (build-cps-term body)))
236 ((_ ($kargs names syms body))
237 (make-$kargs names syms (build-cps-term body)))
238 ((_ ($kentry self tail (unquote clauses)))
239 (make-$kentry self (build-cps-cont tail) clauses))
240 ((_ ($kentry self tail (clause ...)))
241 (make-$kentry self (build-cps-cont tail) (list (build-cps-cont clause) ...)))
244 ((_ ($kclause arity cont))
245 (make-$kclause (build-arity arity) (build-cps-cont cont)))))
247 (define-syntax build-cps-cont
248 (syntax-rules (unquote)
249 ((_ (unquote exp)) exp)
250 ((_ (k cont)) (make-$cont k (build-cont-body cont)))))
252 (define-syntax build-cps-exp
253 (syntax-rules (unquote
254 $void $const $prim $fun $call $callk $primcall $values $prompt)
255 ((_ (unquote exp)) exp)
256 ((_ ($void)) (make-$void))
257 ((_ ($const val)) (make-$const val))
258 ((_ ($prim name)) (make-$prim name))
259 ((_ ($fun src meta free body))
260 (make-$fun src meta free (build-cps-cont body)))
261 ((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
262 ((_ ($call proc args)) (make-$call proc args))
263 ((_ ($callk k proc (arg ...))) (make-$callk k proc (list arg ...)))
264 ((_ ($callk k proc args)) (make-$callk k proc args))
265 ((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...)))
266 ((_ ($primcall name args)) (make-$primcall name args))
267 ((_ ($values (arg ...))) (make-$values (list arg ...)))
268 ((_ ($values args)) (make-$values args))
269 ((_ ($prompt escape? tag handler))
270 (make-$prompt escape? tag handler))))
272 (define-syntax build-cps-term
273 (syntax-rules (unquote $letk $letk* $letconst $letrec $continue)
276 ((_ ($letk (unquote conts) body))
277 (make-$letk conts (build-cps-term body)))
278 ((_ ($letk (cont ...) body))
279 (make-$letk (list (build-cps-cont cont) ...)
280 (build-cps-term body)))
281 ((_ ($letk* () body))
282 (build-cps-term body))
283 ((_ ($letk* (cont conts ...) body))
284 (build-cps-term ($letk (cont) ($letk* (conts ...) body))))
285 ((_ ($letconst () body))
286 (build-cps-term body))
287 ((_ ($letconst ((name sym val) tail ...) body))
288 (let-fresh (kconst) ()
290 ($letk ((kconst ($kargs (name) (sym) ($letconst (tail ...) body))))
291 ($continue kconst (let ((props (source-properties val)))
292 (and (pair? props) props))
294 ((_ ($letrec names gensyms funs body))
295 (make-$letrec names gensyms funs (build-cps-term body)))
296 ((_ ($continue k src exp))
297 (make-$continue k src (build-cps-exp exp)))))
299 (define-syntax-rule (rewrite-cps-term x (pat body) ...)
301 (pat (build-cps-term body)) ...))
302 (define-syntax-rule (rewrite-cps-cont x (pat body) ...)
304 (pat (build-cps-cont body)) ...))
305 (define-syntax-rule (rewrite-cps-exp x (pat body) ...)
307 (pat (build-cps-exp body)) ...))
309 (define (parse-cps exp)
311 (let ((props (source-properties exp)))
312 (and (pair? props) props)))
315 (('letconst k (name sym c) body)
317 ($letk ((k ($kargs (name) (sym)
319 ($continue k (src exp) ($const c)))))
320 (('let k (name sym val) body)
322 ($letk ((k ($kargs (name) (sym)
325 (('letk (cont ...) body)
327 ($letk ,(map parse-cps cont) ,(parse-cps body))))
330 (sym ,(parse-cps body))))
332 (build-cont-body ($kif kt kf)))
333 (('kreceive req rest k)
334 (build-cont-body ($kreceive req rest k)))
335 (('kargs names syms body)
336 (build-cont-body ($kargs names syms ,(parse-cps body))))
337 (('kentry self tail clauses)
339 ($kentry self ,(parse-cps tail) ,(map parse-cps clauses))))
343 (('kclause (req opt rest kw allow-other-keys?) body)
345 ($kclause (req opt rest kw allow-other-keys?)
348 (build-cont-body ($kargs () () ,(parse-cps body))))
352 (build-cps-term ($continue k (src exp) ,(parse-cps exp))))
354 (build-cps-exp ($void)))
356 (build-cps-exp ($const exp)))
358 (build-cps-exp ($prim name)))
359 (('fun meta free body)
360 (build-cps-exp ($fun (src exp) meta free ,(parse-cps body))))
361 (('letrec ((name sym fun) ...) body)
363 ($letrec name sym (map parse-cps fun) ,(parse-cps body))))
364 (('call proc arg ...)
365 (build-cps-exp ($call proc arg)))
366 (('callk k proc arg ...)
367 (build-cps-exp ($callk k proc arg)))
368 (('primcall name arg ...)
369 (build-cps-exp ($primcall name arg)))
371 (build-cps-exp ($values arg)))
372 (('prompt escape? tag handler)
373 (build-cps-exp ($prompt escape? tag handler)))
375 (error "unexpected cps" exp))))
377 (define (unparse-cps exp)
380 (($ $letk (($ $cont k ($ $kargs (name) (sym) body)))
381 ($ $continue k src ($ $const c)))
382 `(letconst ,k (,name ,sym ,c)
383 ,(unparse-cps body)))
384 (($ $letk (($ $cont k ($ $kargs (name) (sym) body))) val)
385 `(let ,k (,name ,sym ,(unparse-cps val))
386 ,(unparse-cps body)))
387 (($ $letk conts body)
388 `(letk ,(map unparse-cps conts) ,(unparse-cps body)))
390 `(k ,sym ,(unparse-cps body)))
393 (($ $kreceive ($ $arity req () rest '() #f) k)
394 `(kreceive ,req ,rest ,k))
395 (($ $kargs () () body)
396 `(kseq ,(unparse-cps body)))
397 (($ $kargs names syms body)
398 `(kargs ,names ,syms ,(unparse-cps body)))
399 (($ $kentry self tail clauses)
400 `(kentry ,self ,(unparse-cps tail) ,(map unparse-cps clauses)))
403 (($ $kclause ($ $arity req opt rest kw allow-other-keys?) body)
404 `(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,(unparse-cps body)))
407 (($ $continue k src exp)
408 `(continue ,k ,(unparse-cps exp)))
415 (($ $fun src meta free body)
416 `(fun ,meta ,free ,(unparse-cps body)))
417 (($ $letrec names syms funs body)
418 `(letrec ,(map (lambda (name sym fun)
419 (list name sym (unparse-cps fun)))
421 ,(unparse-cps body)))
423 `(call ,proc ,@args))
424 (($ $callk k proc args)
425 `(callk ,k ,proc ,@args))
426 (($ $primcall name args)
427 `(primcall ,name ,@args))
430 (($ $prompt escape? tag handler)
431 `(prompt ,escape? ,tag ,handler))
433 (error "unexpected cps" exp))))
435 (define (fold-conts proc seed fun)
436 (define (cont-folder cont seed)
439 (let ((seed (proc k cont seed)))
441 (($ $kargs names syms body)
442 (term-folder body seed))
444 (($ $kentry self tail clauses)
445 (fold cont-folder (cont-folder tail seed) clauses))
447 (($ $kclause arity body)
448 (cont-folder body seed))
452 (define (fun-folder fun seed)
454 (($ $fun src meta free body)
455 (cont-folder body seed))))
457 (define (term-folder term seed)
459 (($ $letk conts body)
460 (fold cont-folder (term-folder body seed) conts))
462 (($ $continue k src exp)
464 (($ $fun) (fun-folder exp seed))
467 (($ $letrec names syms funs body)
468 (fold fun-folder (term-folder body seed) funs))))
470 (fun-folder fun seed))
472 (define (fold-local-conts proc seed cont)
473 (define (cont-folder cont seed)
476 (let ((seed (proc k cont seed)))
478 (($ $kargs names syms body)
479 (term-folder body seed))
481 (($ $kentry self tail clauses)
482 (fold cont-folder (cont-folder tail seed) clauses))
484 (($ $kclause arity body)
485 (cont-folder body seed))
489 (define (term-folder term seed)
491 (($ $letk conts body)
492 (fold cont-folder (term-folder body seed) conts))
496 (($ $letrec names syms funs body) (term-folder body seed))))
498 (cont-folder cont seed))