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 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:
74 ;;; (($ $fun src meta free
76 ;;; ($ $kentry self ($ $cont ktail _ ($ $ktail))
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)
110 #:use-module (srfi srfi-11)
116 $letk $continue $letrec
121 ;; Continuation bodies.
122 $kif $kreceive $kargs $kentry $ktail $kclause
125 $void $const $prim $fun $call $callk $primcall $values $prompt
128 label-counter var-counter
129 fresh-label fresh-var
130 with-fresh-name-state compute-max-label-and-var
134 build-cps-term build-cps-cont build-cps-exp
135 rewrite-cps-term rewrite-cps-cont rewrite-cps-exp
138 parse-cps unparse-cps
139 make-cont-folder fold-conts fold-local-conts
140 visit-cont-successors))
142 ;; FIXME: Use SRFI-99, when Guile adds it.
143 (define-syntax define-record-type*
145 (define (id-append ctx . syms)
146 (datum->syntax ctx (apply symbol-append (map syntax->datum syms))))
149 (and (identifier? #'name) (and-map identifier? #'(field ...)))
150 (with-syntax ((cons (id-append #'name #'make- #'name))
151 (pred (id-append #'name #'name #'?))
152 ((getter ...) (map (lambda (f)
153 (id-append f #'name #'- f))
155 #'(define-record-type name
161 (define-syntax-rule (define-cps-type name field ...)
163 (define-record-type* name field ...)
164 (set-record-type-printer! name print-cps)))
166 (define (print-cps exp port)
167 (format port "#<cps ~S>" (unparse-cps exp)))
170 (define-record-type* $arity req opt rest kw allow-other-keys?)
173 (define-cps-type $letk conts body)
174 (define-cps-type $continue k src exp)
175 (define-cps-type $letrec names syms funs body)
178 (define-cps-type $cont k cont)
179 (define-cps-type $kif kt kf)
180 (define-cps-type $kreceive arity k)
181 (define-cps-type $kargs names syms body)
182 (define-cps-type $kentry self tail clause)
183 (define-cps-type $ktail)
184 (define-cps-type $kclause arity cont alternate)
187 (define-cps-type $void)
188 (define-cps-type $const val)
189 (define-cps-type $prim name)
190 (define-cps-type $fun src meta free body)
191 (define-cps-type $call proc args)
192 (define-cps-type $callk k proc args)
193 (define-cps-type $primcall name args)
194 (define-cps-type $values args)
195 (define-cps-type $prompt escape? tag handler)
197 (define label-counter (make-parameter #f))
198 (define var-counter (make-parameter #f))
200 (define (fresh-label)
201 (let ((count (or (label-counter)
202 (error "fresh-label outside with-fresh-name-state"))))
203 (label-counter (1+ count))
207 (let ((count (or (var-counter)
208 (error "fresh-var outside with-fresh-name-state"))))
209 (var-counter (1+ count))
212 (define-syntax-rule (let-fresh (label ...) (var ...) body ...)
213 (let ((label (fresh-label)) ...
214 (var (fresh-var)) ...)
217 (define-syntax-rule (with-fresh-name-state fun body ...)
218 (call-with-values (lambda ()
219 (compute-max-label-and-var fun))
220 (lambda (max-label max-var)
221 (parameterize ((label-counter (1+ max-label))
222 (var-counter (1+ max-var)))
225 (define-syntax build-arity
226 (syntax-rules (unquote)
227 ((_ (unquote exp)) exp)
228 ((_ (req opt rest kw allow-other-keys?))
229 (make-$arity req opt rest kw allow-other-keys?))))
231 (define-syntax build-cont-body
232 (syntax-rules (unquote $kif $kreceive $kargs $kentry $ktail $kclause)
237 ((_ ($kreceive req rest kargs))
238 (make-$kreceive (make-$arity req '() rest '() #f) kargs))
239 ((_ ($kargs (name ...) (unquote syms) body))
240 (make-$kargs (list name ...) syms (build-cps-term body)))
241 ((_ ($kargs (name ...) (sym ...) body))
242 (make-$kargs (list name ...) (list sym ...) (build-cps-term body)))
243 ((_ ($kargs names syms body))
244 (make-$kargs names syms (build-cps-term body)))
245 ((_ ($kentry self tail clause))
246 (make-$kentry self (build-cps-cont tail) (build-cps-cont clause)))
249 ((_ ($kclause arity cont alternate))
250 (make-$kclause (build-arity arity) (build-cps-cont cont)
251 (build-cps-cont alternate)))))
253 (define-syntax build-cps-cont
254 (syntax-rules (unquote)
255 ((_ (unquote exp)) exp)
256 ((_ (k cont)) (make-$cont k (build-cont-body cont)))))
258 (define-syntax build-cps-exp
259 (syntax-rules (unquote
260 $void $const $prim $fun $call $callk $primcall $values $prompt)
261 ((_ (unquote exp)) exp)
262 ((_ ($void)) (make-$void))
263 ((_ ($const val)) (make-$const val))
264 ((_ ($prim name)) (make-$prim name))
265 ((_ ($fun src meta free body))
266 (make-$fun src meta free (build-cps-cont body)))
267 ((_ ($call proc (unquote args))) (make-$call proc args))
268 ((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
269 ((_ ($call proc args)) (make-$call proc args))
270 ((_ ($callk k proc (unquote args))) (make-$callk k proc args))
271 ((_ ($callk k proc (arg ...))) (make-$callk k proc (list arg ...)))
272 ((_ ($callk k proc args)) (make-$callk k proc args))
273 ((_ ($primcall name (unquote args))) (make-$primcall name args))
274 ((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...)))
275 ((_ ($primcall name args)) (make-$primcall name args))
276 ((_ ($values (unquote args))) (make-$values args))
277 ((_ ($values (arg ...))) (make-$values (list arg ...)))
278 ((_ ($values args)) (make-$values args))
279 ((_ ($prompt escape? tag handler))
280 (make-$prompt escape? tag handler))))
282 (define-syntax build-cps-term
283 (syntax-rules (unquote $letk $letk* $letconst $letrec $continue)
286 ((_ ($letk (unquote conts) body))
287 (make-$letk conts (build-cps-term body)))
288 ((_ ($letk (cont ...) body))
289 (make-$letk (list (build-cps-cont cont) ...)
290 (build-cps-term body)))
291 ((_ ($letk* () body))
292 (build-cps-term body))
293 ((_ ($letk* (cont conts ...) body))
294 (build-cps-term ($letk (cont) ($letk* (conts ...) body))))
295 ((_ ($letconst () body))
296 (build-cps-term body))
297 ((_ ($letconst ((name sym val) tail ...) body))
298 (let-fresh (kconst) ()
300 ($letk ((kconst ($kargs (name) (sym) ($letconst (tail ...) body))))
301 ($continue kconst (let ((props (source-properties val)))
302 (and (pair? props) props))
304 ((_ ($letrec names gensyms funs body))
305 (make-$letrec names gensyms funs (build-cps-term body)))
306 ((_ ($continue k src exp))
307 (make-$continue k src (build-cps-exp exp)))))
309 (define-syntax-rule (rewrite-cps-term x (pat body) ...)
311 (pat (build-cps-term body)) ...))
312 (define-syntax-rule (rewrite-cps-cont x (pat body) ...)
314 (pat (build-cps-cont body)) ...))
315 (define-syntax-rule (rewrite-cps-exp x (pat body) ...)
317 (pat (build-cps-exp body)) ...))
319 (define (parse-cps exp)
321 (let ((props (source-properties exp)))
322 (and (pair? props) props)))
325 (('letconst k (name sym c) body)
327 ($letk ((k ($kargs (name) (sym)
329 ($continue k (src exp) ($const c)))))
330 (('let k (name sym val) body)
332 ($letk ((k ($kargs (name) (sym)
335 (('letk (cont ...) body)
337 ($letk ,(map parse-cps cont) ,(parse-cps body))))
340 (sym ,(parse-cps body))))
342 (build-cont-body ($kif kt kf)))
343 (('kreceive req rest k)
344 (build-cont-body ($kreceive req rest k)))
345 (('kargs names syms body)
346 (build-cont-body ($kargs names syms ,(parse-cps body))))
347 (('kentry self tail clause)
349 ($kentry self ,(parse-cps tail) ,(and=> clause parse-cps))))
353 (('kclause (req opt rest kw allow-other-keys?) body)
355 ($kclause (req opt rest kw allow-other-keys?)
358 (('kclause (req opt rest kw allow-other-keys?) body alternate)
360 ($kclause (req opt rest kw allow-other-keys?)
362 ,(parse-cps alternate))))
364 (build-cont-body ($kargs () () ,(parse-cps body))))
368 (build-cps-term ($continue k (src exp) ,(parse-cps exp))))
370 (build-cps-exp ($void)))
372 (build-cps-exp ($const exp)))
374 (build-cps-exp ($prim name)))
375 (('fun meta free body)
376 (build-cps-exp ($fun (src exp) meta free ,(parse-cps body))))
377 (('letrec ((name sym fun) ...) body)
379 ($letrec name sym (map parse-cps fun) ,(parse-cps body))))
380 (('call proc arg ...)
381 (build-cps-exp ($call proc arg)))
382 (('callk k proc arg ...)
383 (build-cps-exp ($callk k proc arg)))
384 (('primcall name arg ...)
385 (build-cps-exp ($primcall name arg)))
387 (build-cps-exp ($values arg)))
388 (('prompt escape? tag handler)
389 (build-cps-exp ($prompt escape? tag handler)))
391 (error "unexpected cps" exp))))
393 (define (unparse-cps exp)
396 (($ $letk (($ $cont k ($ $kargs (name) (sym) body)))
397 ($ $continue k src ($ $const c)))
398 `(letconst ,k (,name ,sym ,c)
399 ,(unparse-cps body)))
400 (($ $letk (($ $cont k ($ $kargs (name) (sym) body))) val)
401 `(let ,k (,name ,sym ,(unparse-cps val))
402 ,(unparse-cps body)))
403 (($ $letk conts body)
404 `(letk ,(map unparse-cps conts) ,(unparse-cps body)))
406 `(k ,sym ,(unparse-cps body)))
409 (($ $kreceive ($ $arity req () rest '() #f) k)
410 `(kreceive ,req ,rest ,k))
411 (($ $kargs () () body)
412 `(kseq ,(unparse-cps body)))
413 (($ $kargs names syms body)
414 `(kargs ,names ,syms ,(unparse-cps body)))
415 (($ $kentry self tail clause)
416 `(kentry ,self ,(unparse-cps tail) ,(unparse-cps clause)))
419 (($ $kclause ($ $arity req opt rest kw allow-other-keys?) body alternate)
420 `(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,(unparse-cps body)
421 . ,(if alternate (list (unparse-cps alternate)) '())))
424 (($ $continue k src exp)
425 `(continue ,k ,(unparse-cps exp)))
432 (($ $fun src meta free body)
433 `(fun ,meta ,free ,(unparse-cps body)))
434 (($ $letrec names syms funs body)
435 `(letrec ,(map (lambda (name sym fun)
436 (list name sym (unparse-cps fun)))
438 ,(unparse-cps body)))
440 `(call ,proc ,@args))
441 (($ $callk k proc args)
442 `(callk ,k ,proc ,@args))
443 (($ $primcall name args)
444 `(primcall ,name ,@args))
447 (($ $prompt escape? tag handler)
448 `(prompt ,escape? ,tag ,handler))
450 (error "unexpected cps" exp))))
452 (define-syntax-rule (make-cont-folder global? seed ...)
453 (lambda (proc fun seed ...)
454 (define (fold-values proc in seed ...)
457 (let-values (((seed ...) (proc (car in) seed ...)))
458 (fold-values proc (cdr in) seed ...))))
460 (define (cont-folder cont seed ...)
463 (let-values (((seed ...) (proc k cont seed ...)))
465 (($ $kargs names syms body)
466 (term-folder body seed ...))
468 (($ $kentry self tail clause)
469 (let-values (((seed ...) (cont-folder tail seed ...)))
471 (cont-folder clause seed ...)
474 (($ $kclause arity body alternate)
475 (let-values (((seed ...) (cont-folder body seed ...)))
477 (cont-folder alternate seed ...)
480 (_ (values seed ...)))))))
482 (define (fun-folder fun seed ...)
484 (($ $fun src meta free body)
485 (cont-folder body seed ...))))
487 (define (term-folder term seed ...)
489 (($ $letk conts body)
490 (let-values (((seed ...) (term-folder body seed ...)))
491 (fold-values cont-folder conts seed ...)))
493 (($ $continue k src exp)
497 (fun-folder exp seed ...)
499 (_ (values seed ...))))
501 (($ $letrec names syms funs body)
502 (let-values (((seed ...) (term-folder body seed ...)))
504 (fold-values fun-folder funs seed ...)
505 (values seed ...))))))
507 (fun-folder fun seed ...)))
509 (define (compute-max-label-and-var fun)
510 ((make-cont-folder #t max-label max-var)
511 (lambda (label cont max-label max-var)
512 (values (max label max-label)
514 (($ $kargs names vars body)
515 (let lp ((body body) (max-var (fold max max-var vars)))
517 (($ $letk conts body) (lp body max-var))
518 (($ $letrec names vars funs body)
519 (lp body (fold max max-var vars)))
528 (define (fold-conts proc seed fun)
529 ((make-cont-folder #t seed) proc fun seed))
531 (define (fold-local-conts proc seed fun)
532 ((make-cont-folder #f seed) proc fun seed))
534 (define (visit-cont-successors proc cont)
536 (($ $kargs names syms body)
537 (let lp ((body body))
539 (($ $letk conts body) (lp body))
540 (($ $letrec names vars funs body) (lp body))
541 (($ $continue k src exp)
543 (($ $prompt escape? tag handler) (proc k handler))
546 (($ $kif kt kf) (proc kt kf))
548 (($ $kreceive arity k) (proc k))
550 (($ $kclause arity ($ $cont kbody) #f) (proc kbody))
552 (($ $kclause arity ($ $cont kbody) ($ $cont kalt)) (proc kbody kalt))
554 (($ $kentry self tail ($ $cont clause)) (proc clause))
556 (($ $kentry self tail #f) (proc))
558 (($ $ktail) (proc))))