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 ;;; $kargs for continuations that bind values, $ktail for the tail
31 ;;; continuation, etc.
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 ;;; - $kfun 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 ;;; - $kfun also contain a $kclause continuation, corresponding to
65 ;;; the first case-lambda clause of the function. $kclause actually
66 ;;; contains the clause body, and the subsequent clause (if any).
67 ;;; This is because the $kclause logically matches or doesn't match
68 ;;; a given set of actual arguments against a formal arity, then
69 ;;; proceeds to a "body" continuation (which is a $kargs).
71 ;;; That's to say that a $fun can be matched like this:
76 ;;; ($ $kfun src meta self ($ $cont ktail ($ $ktail))
78 ;;; ($ $cont kbody ($ $kargs names syms body))
82 ;;; A $continue to ktail is in tail position. $kfun, $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)
110 #:use-module (srfi srfi-11)
116 $letk $continue $letrec
121 ;; Continuation bodies.
122 $kreceive $kargs $kfun $ktail $kclause
125 $void $const $prim $fun $closure $branch
126 $call $callk $primcall $values $prompt
128 ;; First-order CPS root.
132 label-counter var-counter
133 fresh-label fresh-var
134 with-fresh-name-state compute-max-label-and-var
138 build-cps-term build-cps-cont build-cps-exp
139 rewrite-cps-term rewrite-cps-cont rewrite-cps-exp
142 parse-cps unparse-cps
143 make-global-cont-folder make-local-cont-folder
144 fold-conts fold-local-conts
145 visit-cont-successors))
147 ;; FIXME: Use SRFI-99, when Guile adds it.
148 (define-syntax define-record-type*
150 (define (id-append ctx . syms)
151 (datum->syntax ctx (apply symbol-append (map syntax->datum syms))))
154 (and (identifier? #'name) (and-map identifier? #'(field ...)))
155 (with-syntax ((cons (id-append #'name #'make- #'name))
156 (pred (id-append #'name #'name #'?))
157 ((getter ...) (map (lambda (f)
158 (id-append f #'name #'- f))
160 #'(define-record-type name
166 (define-syntax-rule (define-cps-type name field ...)
168 (define-record-type* name field ...)
169 (set-record-type-printer! name print-cps)))
171 (define (print-cps exp port)
172 (format port "#<cps ~S>" (unparse-cps exp)))
175 (define-record-type* $arity req opt rest kw allow-other-keys?)
178 (define-cps-type $letk conts body)
179 (define-cps-type $continue k src exp)
180 (define-cps-type $letrec names syms funs body) ; Higher-order.
183 (define-cps-type $cont k cont)
184 (define-cps-type $kreceive arity k)
185 (define-cps-type $kargs names syms body)
186 (define-cps-type $kfun src meta self tail clause)
187 (define-cps-type $ktail)
188 (define-cps-type $kclause arity cont alternate)
191 (define-cps-type $void)
192 (define-cps-type $const val)
193 (define-cps-type $prim name)
194 (define-cps-type $fun free body) ; Higher-order.
195 (define-cps-type $closure label nfree) ; First-order.
196 (define-cps-type $branch k exp)
197 (define-cps-type $call proc args)
198 (define-cps-type $callk k proc args) ; First-order.
199 (define-cps-type $primcall name args)
200 (define-cps-type $values args)
201 (define-cps-type $prompt escape? tag handler)
203 ;; The root of a higher-order CPS term is $cont containing a $kfun. The
204 ;; root of a first-order CPS term is a $program.
205 (define-cps-type $program funs)
207 (define label-counter (make-parameter #f))
208 (define var-counter (make-parameter #f))
210 (define (fresh-label)
211 (let ((count (or (label-counter)
212 (error "fresh-label outside with-fresh-name-state"))))
213 (label-counter (1+ count))
217 (let ((count (or (var-counter)
218 (error "fresh-var outside with-fresh-name-state"))))
219 (var-counter (1+ count))
222 (define-syntax-rule (let-fresh (label ...) (var ...) body ...)
223 (let ((label (fresh-label)) ...
224 (var (fresh-var)) ...)
227 (define-syntax-rule (with-fresh-name-state fun body ...)
228 (call-with-values (lambda () (compute-max-label-and-var fun))
229 (lambda (max-label max-var)
230 (parameterize ((label-counter (1+ max-label))
231 (var-counter (1+ max-var)))
234 (define-syntax build-arity
235 (syntax-rules (unquote)
236 ((_ (unquote exp)) exp)
237 ((_ (req opt rest kw allow-other-keys?))
238 (make-$arity req opt rest kw allow-other-keys?))))
240 (define-syntax build-cont-body
241 (syntax-rules (unquote $kreceive $kargs $kfun $ktail $kclause)
244 ((_ ($kreceive req rest kargs))
245 (make-$kreceive (make-$arity req '() rest '() #f) kargs))
246 ((_ ($kargs (name ...) (unquote syms) body))
247 (make-$kargs (list name ...) syms (build-cps-term body)))
248 ((_ ($kargs (name ...) (sym ...) body))
249 (make-$kargs (list name ...) (list sym ...) (build-cps-term body)))
250 ((_ ($kargs names syms body))
251 (make-$kargs names syms (build-cps-term body)))
252 ((_ ($kfun src meta self tail clause))
253 (make-$kfun src meta self (build-cps-cont tail) (build-cps-cont clause)))
256 ((_ ($kclause arity cont alternate))
257 (make-$kclause (build-arity arity) (build-cps-cont cont)
258 (build-cps-cont alternate)))))
260 (define-syntax build-cps-cont
261 (syntax-rules (unquote)
262 ((_ (unquote exp)) exp)
263 ((_ (k cont)) (make-$cont k (build-cont-body cont)))))
265 (define-syntax build-cps-exp
266 (syntax-rules (unquote
267 $void $const $prim $fun $closure $branch
268 $call $callk $primcall $values $prompt)
269 ((_ (unquote exp)) exp)
270 ((_ ($void)) (make-$void))
271 ((_ ($const val)) (make-$const val))
272 ((_ ($prim name)) (make-$prim name))
273 ((_ ($fun free body)) (make-$fun free (build-cps-cont body)))
274 ((_ ($closure k nfree)) (make-$closure k nfree))
275 ((_ ($call proc (unquote args))) (make-$call proc args))
276 ((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
277 ((_ ($call proc args)) (make-$call proc args))
278 ((_ ($callk k proc (unquote args))) (make-$callk k proc args))
279 ((_ ($callk k proc (arg ...))) (make-$callk k proc (list arg ...)))
280 ((_ ($callk k proc args)) (make-$callk k proc args))
281 ((_ ($primcall name (unquote args))) (make-$primcall name args))
282 ((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...)))
283 ((_ ($primcall name args)) (make-$primcall name args))
284 ((_ ($values (unquote args))) (make-$values args))
285 ((_ ($values (arg ...))) (make-$values (list arg ...)))
286 ((_ ($values args)) (make-$values args))
287 ((_ ($branch k exp)) (make-$branch k (build-cps-exp exp)))
288 ((_ ($prompt escape? tag handler))
289 (make-$prompt escape? tag handler))))
291 (define-syntax build-cps-term
292 (syntax-rules (unquote $letk $letk* $letconst $letrec $program $continue)
295 ((_ ($letk (unquote conts) body))
296 (make-$letk conts (build-cps-term body)))
297 ((_ ($letk (cont ...) body))
298 (make-$letk (list (build-cps-cont cont) ...)
299 (build-cps-term body)))
300 ((_ ($letk* () body))
301 (build-cps-term body))
302 ((_ ($letk* (cont conts ...) body))
303 (build-cps-term ($letk (cont) ($letk* (conts ...) body))))
304 ((_ ($letconst () body))
305 (build-cps-term body))
306 ((_ ($letconst ((name sym val) tail ...) body))
307 (let-fresh (kconst) ()
309 ($letk ((kconst ($kargs (name) (sym) ($letconst (tail ...) body))))
310 ($continue kconst (let ((props (source-properties val)))
311 (and (pair? props) props))
313 ((_ ($letrec names gensyms funs body))
314 (make-$letrec names gensyms funs (build-cps-term body)))
315 ((_ ($program (unquote conts)))
316 (make-$program conts))
317 ((_ ($program (cont ...)))
318 (make-$program (list (build-cps-cont cont) ...)))
319 ((_ ($program conts))
320 (make-$program conts))
321 ((_ ($continue k src exp))
322 (make-$continue k src (build-cps-exp exp)))))
324 (define-syntax-rule (rewrite-cps-term x (pat body) ...)
326 (pat (build-cps-term body)) ...))
327 (define-syntax-rule (rewrite-cps-cont x (pat body) ...)
329 (pat (build-cps-cont body)) ...))
330 (define-syntax-rule (rewrite-cps-exp x (pat body) ...)
332 (pat (build-cps-exp body)) ...))
334 (define (parse-cps exp)
336 (let ((props (source-properties exp)))
337 (and (pair? props) props)))
340 (('letconst k (name sym c) body)
342 ($letk ((k ($kargs (name) (sym)
344 ($continue k (src exp) ($const c)))))
345 (('let k (name sym val) body)
347 ($letk ((k ($kargs (name) (sym)
350 (('letk (cont ...) body)
352 ($letk ,(map parse-cps cont) ,(parse-cps body))))
355 (sym ,(parse-cps body))))
356 (('kreceive req rest k)
357 (build-cont-body ($kreceive req rest k)))
358 (('kargs names syms body)
359 (build-cont-body ($kargs names syms ,(parse-cps body))))
360 (('kfun src meta self tail clause)
362 ($kfun (src exp) meta self ,(parse-cps tail)
363 ,(and=> clause parse-cps))))
367 (('kclause (req opt rest kw allow-other-keys?) body)
369 ($kclause (req opt rest kw allow-other-keys?)
372 (('kclause (req opt rest kw allow-other-keys?) body alternate)
374 ($kclause (req opt rest kw allow-other-keys?)
376 ,(parse-cps alternate))))
378 (build-cont-body ($kargs () () ,(parse-cps body))))
382 (build-cps-term ($continue k (src exp) ,(parse-cps exp))))
384 (build-cps-exp ($void)))
386 (build-cps-exp ($const exp)))
388 (build-cps-exp ($prim name)))
390 (build-cps-exp ($fun free ,(parse-cps body))))
392 (build-cps-exp ($closure k nfree)))
393 (('letrec ((name sym fun) ...) body)
395 ($letrec name sym (map parse-cps fun) ,(parse-cps body))))
396 (('program (cont ...))
397 (build-cps-term ($program ,(map parse-cps cont))))
398 (('call proc arg ...)
399 (build-cps-exp ($call proc arg)))
400 (('callk k proc arg ...)
401 (build-cps-exp ($callk k proc arg)))
402 (('primcall name arg ...)
403 (build-cps-exp ($primcall name arg)))
405 (build-cps-exp ($branch k ,(parse-cps exp))))
407 (build-cps-exp ($values arg)))
408 (('prompt escape? tag handler)
409 (build-cps-exp ($prompt escape? tag handler)))
411 (error "unexpected cps" exp))))
413 (define (unparse-cps exp)
416 (($ $letk (($ $cont k ($ $kargs (name) (sym) body)))
417 ($ $continue k src ($ $const c)))
418 `(letconst ,k (,name ,sym ,c)
419 ,(unparse-cps body)))
420 (($ $letk (($ $cont k ($ $kargs (name) (sym) body))) val)
421 `(let ,k (,name ,sym ,(unparse-cps val))
422 ,(unparse-cps body)))
423 (($ $letk conts body)
424 `(letk ,(map unparse-cps conts) ,(unparse-cps body)))
426 `(k ,sym ,(unparse-cps body)))
427 (($ $kreceive ($ $arity req () rest '() #f) k)
428 `(kreceive ,req ,rest ,k))
429 (($ $kargs () () body)
430 `(kseq ,(unparse-cps body)))
431 (($ $kargs names syms body)
432 `(kargs ,names ,syms ,(unparse-cps body)))
433 (($ $kfun src meta self tail clause)
434 `(kfun ,meta ,self ,(unparse-cps tail) ,(unparse-cps clause)))
437 (($ $kclause ($ $arity req opt rest kw allow-other-keys?) body alternate)
438 `(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,(unparse-cps body)
439 . ,(if alternate (list (unparse-cps alternate)) '())))
442 (($ $continue k src exp)
443 `(continue ,k ,(unparse-cps exp)))
451 `(fun ,free ,(unparse-cps body)))
452 (($ $closure k nfree)
453 `(closure ,k ,nfree))
454 (($ $letrec names syms funs body)
455 `(letrec ,(map (lambda (name sym fun)
456 (list name sym (unparse-cps fun)))
458 ,(unparse-cps body)))
460 `(program ,(map unparse-cps conts)))
462 `(call ,proc ,@args))
463 (($ $callk k proc args)
464 `(callk ,k ,proc ,@args))
465 (($ $primcall name args)
466 `(primcall ,name ,@args))
468 `(branch ,k ,(unparse-cps exp)))
471 (($ $prompt escape? tag handler)
472 `(prompt ,escape? ,tag ,handler))
474 (error "unexpected cps" exp))))
476 (define-syntax-rule (make-global-cont-folder seed ...)
477 (lambda (proc cont seed ...)
478 (define (cont-folder cont seed ...)
481 (let-values (((seed ...) (proc k cont seed ...)))
483 (($ $kargs names syms body)
484 (term-folder body seed ...))
486 (($ $kfun src meta self tail clause)
487 (let-values (((seed ...) (cont-folder tail seed ...)))
489 (cont-folder clause seed ...)
492 (($ $kclause arity body alternate)
493 (let-values (((seed ...) (cont-folder body seed ...)))
495 (cont-folder alternate seed ...)
498 (_ (values seed ...)))))))
500 (define (fun-folder fun seed ...)
503 (cont-folder body seed ...))))
505 (define (term-folder term seed ...)
507 (($ $letk conts body)
508 (let-values (((seed ...) (term-folder body seed ...)))
509 (let lp ((conts conts) (seed seed) ...)
512 (let-values (((seed ...) (cont-folder (car conts) seed ...)))
513 (lp (cdr conts) seed ...))))))
515 (($ $continue k src exp)
517 (($ $fun) (fun-folder exp seed ...))
518 (_ (values seed ...))))
520 (($ $letrec names syms funs body)
521 (let-values (((seed ...) (term-folder body seed ...)))
522 (let lp ((funs funs) (seed seed) ...)
525 (let-values (((seed ...) (fun-folder (car funs) seed ...)))
526 (lp (cdr funs) seed ...))))))))
528 (cont-folder cont seed ...)))
530 (define-syntax-rule (make-local-cont-folder seed ...)
531 (lambda (proc cont seed ...)
532 (define (cont-folder cont seed ...)
534 (($ $cont k (and cont ($ $kargs names syms body)))
535 (let-values (((seed ...) (proc k cont seed ...)))
536 (term-folder body seed ...)))
538 (proc k cont seed ...))))
539 (define (term-folder term seed ...)
541 (($ $letk conts body)
542 (let-values (((seed ...) (term-folder body seed ...)))
543 (let lp ((conts conts) (seed seed) ...)
545 (() (values seed ...))
546 ((cont) (cont-folder cont seed ...))
548 (let-values (((seed ...) (cont-folder cont seed ...)))
549 (lp conts seed ...)))))))
550 (($ $letrec names syms funs body) (term-folder body seed ...))
551 (_ (values seed ...))))
552 (define (clause-folder clause seed ...)
554 (($ $cont k (and cont ($ $kclause arity body alternate)))
555 (let-values (((seed ...) (proc k cont seed ...)))
557 (let-values (((seed ...) (cont-folder body seed ...)))
558 (clause-folder alternate seed ...))
559 (cont-folder body seed ...))))))
561 (($ $cont k (and cont ($ $kfun src meta self tail clause)))
562 (let*-values (((seed ...) (proc k cont seed ...))
563 ((seed ...) (if clause
564 (clause-folder clause seed ...)
566 (cont-folder tail seed ...))))))
568 (define (compute-max-label-and-var fun)
571 ((make-global-cont-folder max-label max-var)
572 (lambda (label cont max-label max-var)
573 (values (max label max-label)
575 (($ $kargs names vars body)
576 (let lp ((body body) (max-var (fold max max-var vars)))
578 (($ $letk conts body) (lp body max-var))
579 (($ $letrec names vars funs body)
580 (lp body (fold max max-var vars)))
582 (($ $kfun src meta self)
587 (define (fold/2 proc in s0 s1)
590 (let-values (((s0 s1) (proc (car in) s0 s1)))
591 (fold/2 proc (cdr in) s0 s1))))
592 (let lp ((conts conts) (max-label -1) (max-var -1))
594 (values max-label max-var)
595 (call-with-values (lambda ()
596 ((make-local-cont-folder max-label max-var)
597 (lambda (label cont max-label max-var)
598 (values (max label max-label)
600 (($ $kargs names vars body)
601 (fold max max-var vars))
602 (($ $kfun src meta self)
605 (car conts) max-label max-var))
606 (lambda (max-label max-var)
607 (lp (cdr conts) max-label max-var))))))))
609 (define (fold-conts proc seed fun)
610 ((make-global-cont-folder seed) proc fun seed))
612 (define (fold-local-conts proc seed fun)
613 ((make-local-cont-folder seed) proc fun seed))
615 (define (visit-cont-successors proc cont)
617 (($ $kargs names syms body)
618 (let lp ((body body))
620 (($ $letk conts body) (lp body))
621 (($ $letrec names vars funs body) (lp body))
622 (($ $continue k src exp)
624 (($ $prompt escape? tag handler) (proc k handler))
625 (($ $branch kt) (proc k kt))
628 (($ $kreceive arity k) (proc k))
630 (($ $kclause arity ($ $cont kbody) #f) (proc kbody))
632 (($ $kclause arity ($ $cont kbody) ($ $cont kalt)) (proc kbody kalt))
634 (($ $kfun src meta self tail ($ $cont clause)) (proc clause))
636 (($ $kfun src meta self tail #f) (proc))
638 (($ $ktail) (proc))))