Commit | Line | Data |
---|---|---|
4b8de65e AW |
1 | ;;; Continuation-passing style (CPS) intermediate language (IL) |
2 | ||
7ab76a83 | 3 | ;; Copyright (C) 2013, 2014 Free Software Foundation, Inc. |
4b8de65e AW |
4 | |
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. | |
9 | ;;;; | |
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. | |
14 | ;;;; | |
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 | |
18 | ||
19 | ;;; Commentary: | |
20 | ;;; | |
21 | ;;; This pass converts a CPS term in such a way that no function has any | |
22 | ;;; free variables. Instead, closures are built explicitly with | |
23 | ;;; make-closure primcalls, and free variables are referenced through | |
24 | ;;; the closure. | |
25 | ;;; | |
26 | ;;; Closure conversion also removes any $letrec forms that contification | |
27 | ;;; did not handle. See (language cps) for a further discussion of | |
28 | ;;; $letrec. | |
29 | ;;; | |
30 | ;;; Code: | |
31 | ||
32 | (define-module (language cps closure-conversion) | |
33 | #:use-module (ice-9 match) | |
34 | #:use-module ((srfi srfi-1) #:select (fold | |
35 | lset-union lset-difference | |
36 | list-index)) | |
37 | #:use-module (ice-9 receive) | |
38 | #:use-module (srfi srfi-26) | |
39 | #:use-module (language cps) | |
40 | #:export (convert-closures)) | |
41 | ||
42 | (define (union s1 s2) | |
43 | (lset-union eq? s1 s2)) | |
44 | ||
45 | (define (difference s1 s2) | |
46 | (lset-difference eq? s1 s2)) | |
47 | ||
48 | ;; bound := sym ... | |
49 | ;; free := sym ... | |
50 | ||
51 | (define (convert-free-var sym self bound k) | |
52 | "Convert one possibly free variable reference to a bound reference. | |
53 | ||
54 | If @var{sym} is free (i.e., not present in @var{bound},), it is replaced | |
55 | by a closure reference via a @code{free-ref} primcall, and @var{k} is | |
56 | called with the new var. Otherwise @var{sym} is bound, so @var{k} is | |
57 | called with @var{sym}. | |
58 | ||
59 | @var{k} should return two values: a term and a list of additional free | |
60 | values in the term." | |
61 | (if (memq sym bound) | |
62 | (k sym) | |
828ed944 | 63 | (let-fresh (k*) (sym*) |
4b8de65e AW |
64 | (receive (exp free) (k sym*) |
65 | (values (build-cps-term | |
6e422a35 AW |
66 | ($letk ((k* ($kargs (sym*) (sym*) ,exp))) |
67 | ($continue k* #f ($primcall 'free-ref (self sym))))) | |
4b8de65e AW |
68 | (cons sym free)))))) |
69 | ||
70 | (define (convert-free-vars syms self bound k) | |
71 | "Convert a number of possibly free references to bound references. | |
72 | @var{k} is called with the bound references, and should return two | |
73 | values: the term and a list of additional free variables in the term." | |
74 | (match syms | |
75 | (() (k '())) | |
76 | ((sym . syms) | |
77 | (convert-free-var sym self bound | |
78 | (lambda (sym) | |
79 | (convert-free-vars syms self bound | |
80 | (lambda (syms) | |
81 | (k (cons sym syms))))))))) | |
82 | ||
83 | (define (init-closure src v free outer-self outer-bound body) | |
84 | "Initialize the free variables @var{free} in a closure bound to | |
85 | @var{v}, and continue with @var{body}. @var{outer-self} must be the | |
86 | label of the outer procedure, where the initialization will be | |
87 | performed, and @var{outer-bound} is the list of bound variables there." | |
88 | (fold (lambda (free idx body) | |
828ed944 | 89 | (let-fresh (k) (idxsym) |
4b8de65e | 90 | (build-cps-term |
6e422a35 | 91 | ($letk ((k ($kargs () () ,body))) |
4b8de65e AW |
92 | ,(convert-free-var |
93 | free outer-self outer-bound | |
94 | (lambda (free) | |
95 | (values (build-cps-term | |
96 | ($letconst (('idx idxsym idx)) | |
6e422a35 | 97 | ($continue k src |
4b8de65e AW |
98 | ($primcall 'free-set! (v idxsym free))))) |
99 | '()))))))) | |
100 | body | |
101 | free | |
102 | (iota (length free)))) | |
103 | ||
104 | (define (cc* exps self bound) | |
105 | "Convert all free references in the list of expressions @var{exps} to | |
106 | bound references, and convert functions to flat closures. Returns two | |
107 | values: the transformed list, and a cumulative set of free variables." | |
108 | (let lp ((exps exps) (exps* '()) (free '())) | |
109 | (match exps | |
110 | (() (values (reverse exps*) free)) | |
111 | ((exp . exps) | |
112 | (receive (exp* free*) (cc exp self bound) | |
113 | (lp exps (cons exp* exps*) (union free free*))))))) | |
114 | ||
115 | ;; Closure conversion. | |
116 | (define (cc exp self bound) | |
117 | "Convert all free references in @var{exp} to bound references, and | |
118 | convert functions to flat closures." | |
119 | (match exp | |
120 | (($ $letk conts body) | |
121 | (receive (conts free) (cc* conts self bound) | |
122 | (receive (body free*) (cc body self bound) | |
123 | (values (build-cps-term ($letk ,conts ,body)) | |
124 | (union free free*))))) | |
125 | ||
6e422a35 | 126 | (($ $cont sym ($ $kargs names syms body)) |
4b8de65e | 127 | (receive (body free) (cc body self (append syms bound)) |
6e422a35 | 128 | (values (build-cps-cont (sym ($kargs names syms ,body))) |
4b8de65e AW |
129 | free))) |
130 | ||
24b611e8 | 131 | (($ $cont sym ($ $kentry src meta self tail clause)) |
90dce16d AW |
132 | (receive (clause free) (if clause |
133 | (cc clause self (list self)) | |
134 | (values #f '())) | |
24b611e8 | 135 | (values (build-cps-cont (sym ($kentry src meta self ,tail ,clause))) |
4b8de65e AW |
136 | free))) |
137 | ||
90dce16d | 138 | (($ $cont sym ($ $kclause arity body alternate)) |
4b8de65e | 139 | (receive (body free) (cc body self bound) |
90dce16d AW |
140 | (receive (alternate free*) (if alternate |
141 | (cc alternate self bound) | |
142 | (values #f '())) | |
143 | (values (build-cps-cont (sym ($kclause ,arity ,body ,alternate))) | |
144 | (union free free*))))) | |
4b8de65e AW |
145 | |
146 | (($ $cont) | |
147 | ;; Other kinds of continuations don't bind values and don't have | |
148 | ;; bodies. | |
149 | (values exp '())) | |
150 | ||
151 | ;; Remove letrec. | |
152 | (($ $letrec names syms funs body) | |
153 | (let ((bound (append bound syms))) | |
154 | (receive (body free) (cc body self bound) | |
155 | (let lp ((in (map list names syms funs)) | |
156 | (bindings (lambda (body) body)) | |
157 | (body body) | |
158 | (free free)) | |
159 | (match in | |
160 | (() (values (bindings body) free)) | |
24b611e8 AW |
161 | (((name sym ($ $fun () (and fun-body |
162 | ($ $cont _ ($ $kentry src))))) . in) | |
4b8de65e AW |
163 | (receive (fun-body fun-free) (cc fun-body #f '()) |
164 | (lp in | |
165 | (lambda (body) | |
828ed944 | 166 | (let-fresh (k) () |
4b8de65e | 167 | (build-cps-term |
6e422a35 AW |
168 | ($letk ((k ($kargs (name) (sym) ,(bindings body)))) |
169 | ($continue k src | |
24b611e8 | 170 | ($fun fun-free ,fun-body)))))) |
6e422a35 | 171 | (init-closure src sym fun-free self bound body) |
4b8de65e AW |
172 | (union free (difference fun-free bound)))))))))) |
173 | ||
6e422a35 | 174 | (($ $continue k src |
4b8de65e AW |
175 | (or ($ $void) |
176 | ($ $const) | |
177 | ($ $prim))) | |
178 | (values exp '())) | |
179 | ||
24b611e8 | 180 | (($ $continue k src ($ $fun () body)) |
4b8de65e AW |
181 | (receive (body free) (cc body #f '()) |
182 | (match free | |
183 | (() | |
184 | (values (build-cps-term | |
24b611e8 | 185 | ($continue k src ($fun free ,body))) |
4b8de65e AW |
186 | free)) |
187 | (_ | |
188 | (values | |
828ed944 | 189 | (let-fresh (kinit) (v) |
4b8de65e | 190 | (build-cps-term |
6e422a35 | 191 | ($letk ((kinit ($kargs (v) (v) |
13085a82 AW |
192 | ,(init-closure |
193 | src v free self bound | |
194 | (build-cps-term | |
195 | ($continue k src ($values (v)))))))) | |
24b611e8 | 196 | ($continue kinit src ($fun free ,body))))) |
4b8de65e AW |
197 | (difference free bound)))))) |
198 | ||
6e422a35 | 199 | (($ $continue k src ($ $call proc args)) |
4b8de65e AW |
200 | (convert-free-vars (cons proc args) self bound |
201 | (match-lambda | |
202 | ((proc . args) | |
203 | (values (build-cps-term | |
6e422a35 | 204 | ($continue k src ($call proc args))) |
4b8de65e AW |
205 | '()))))) |
206 | ||
b3ae2b50 AW |
207 | (($ $continue k src ($ $callk k* proc args)) |
208 | (convert-free-vars (cons proc args) self bound | |
209 | (match-lambda | |
210 | ((proc . args) | |
211 | (values (build-cps-term | |
212 | ($continue k src ($callk k* proc args))) | |
213 | '()))))) | |
214 | ||
6e422a35 | 215 | (($ $continue k src ($ $primcall name args)) |
4b8de65e AW |
216 | (convert-free-vars args self bound |
217 | (lambda (args) | |
218 | (values (build-cps-term | |
6e422a35 | 219 | ($continue k src ($primcall name args))) |
4b8de65e AW |
220 | '())))) |
221 | ||
6e422a35 | 222 | (($ $continue k src ($ $values args)) |
4b8de65e AW |
223 | (convert-free-vars args self bound |
224 | (lambda (args) | |
225 | (values (build-cps-term | |
6e422a35 | 226 | ($continue k src ($values args))) |
4b8de65e AW |
227 | '())))) |
228 | ||
7ab76a83 | 229 | (($ $continue k src ($ $prompt escape? tag handler)) |
4b8de65e AW |
230 | (convert-free-var |
231 | tag self bound | |
232 | (lambda (tag) | |
233 | (values (build-cps-term | |
7ab76a83 | 234 | ($continue k src ($prompt escape? tag handler))) |
4b8de65e AW |
235 | '())))) |
236 | ||
237 | (_ (error "what" exp)))) | |
238 | ||
239 | ;; Convert the slot arguments of 'free-ref' primcalls from symbols to | |
240 | ;; indices. | |
241 | (define (convert-to-indices body free) | |
242 | (define (free-index sym) | |
243 | (or (list-index (cut eq? <> sym) free) | |
244 | (error "free variable not found!" sym free))) | |
245 | (define (visit-term term) | |
246 | (rewrite-cps-term term | |
247 | (($ $letk conts body) | |
248 | ($letk ,(map visit-cont conts) ,(visit-term body))) | |
6e422a35 | 249 | (($ $continue k src ($ $primcall 'free-ref (closure sym))) |
828ed944 | 250 | ,(let-fresh () (idx) |
4b8de65e AW |
251 | (build-cps-term |
252 | ($letconst (('idx idx (free-index sym))) | |
6e422a35 | 253 | ($continue k src ($primcall 'free-ref (closure idx))))))) |
24b611e8 | 254 | (($ $continue k src ($ $fun free body)) |
6e422a35 | 255 | ($continue k src |
24b611e8 | 256 | ($fun free ,(convert-to-indices body free)))) |
4b8de65e AW |
257 | (($ $continue) |
258 | ,term))) | |
259 | (define (visit-cont cont) | |
260 | (rewrite-cps-cont cont | |
6e422a35 AW |
261 | (($ $cont sym ($ $kargs names syms body)) |
262 | (sym ($kargs names syms ,(visit-term body)))) | |
90dce16d AW |
263 | (($ $cont sym ($ $kclause arity body alternate)) |
264 | (sym ($kclause ,arity ,(visit-cont body) | |
265 | ,(and alternate (visit-cont alternate))))) | |
4b8de65e AW |
266 | ;; Other kinds of continuations don't bind values and don't have |
267 | ;; bodies. | |
268 | (($ $cont) | |
269 | ,cont))) | |
270 | ||
271 | (rewrite-cps-cont body | |
24b611e8 AW |
272 | (($ $cont sym ($ $kentry src meta self tail clause)) |
273 | (sym ($kentry src meta self ,tail ,(and clause (visit-cont clause))))))) | |
4b8de65e AW |
274 | |
275 | (define (convert-closures exp) | |
276 | "Convert free reference in @var{exp} to primcalls to @code{free-ref}, | |
277 | and allocate and initialize flat closures." | |
828ed944 AW |
278 | (with-fresh-name-state exp |
279 | (match exp | |
24b611e8 | 280 | (($ $fun () body) |
828ed944 AW |
281 | (receive (body free) (cc body #f '()) |
282 | (unless (null? free) | |
283 | (error "Expected no free vars in toplevel thunk" exp body free)) | |
284 | (build-cps-exp | |
24b611e8 | 285 | ($fun free ,(convert-to-indices body free)))))))) |