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) | |
63 | (let-gensyms (k* sym*) | |
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) | |
89 | (let-gensyms (k idxsym) | |
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 | ||
6e422a35 | 131 | (($ $cont sym ($ $kentry self tail clauses)) |
4b8de65e | 132 | (receive (clauses free) (cc* clauses self (list self)) |
6e422a35 | 133 | (values (build-cps-cont (sym ($kentry self ,tail ,clauses))) |
4b8de65e AW |
134 | free))) |
135 | ||
6e422a35 | 136 | (($ $cont sym ($ $kclause arity body)) |
4b8de65e | 137 | (receive (body free) (cc body self bound) |
6e422a35 | 138 | (values (build-cps-cont (sym ($kclause ,arity ,body))) |
4b8de65e AW |
139 | free))) |
140 | ||
141 | (($ $cont) | |
142 | ;; Other kinds of continuations don't bind values and don't have | |
143 | ;; bodies. | |
144 | (values exp '())) | |
145 | ||
146 | ;; Remove letrec. | |
147 | (($ $letrec names syms funs body) | |
148 | (let ((bound (append bound syms))) | |
149 | (receive (body free) (cc body self bound) | |
150 | (let lp ((in (map list names syms funs)) | |
151 | (bindings (lambda (body) body)) | |
152 | (body body) | |
153 | (free free)) | |
154 | (match in | |
155 | (() (values (bindings body) free)) | |
6e422a35 | 156 | (((name sym ($ $fun src meta () fun-body)) . in) |
4b8de65e AW |
157 | (receive (fun-body fun-free) (cc fun-body #f '()) |
158 | (lp in | |
159 | (lambda (body) | |
160 | (let-gensyms (k) | |
161 | (build-cps-term | |
6e422a35 AW |
162 | ($letk ((k ($kargs (name) (sym) ,(bindings body)))) |
163 | ($continue k src | |
164 | ($fun src meta fun-free ,fun-body)))))) | |
165 | (init-closure src sym fun-free self bound body) | |
4b8de65e AW |
166 | (union free (difference fun-free bound)))))))))) |
167 | ||
6e422a35 | 168 | (($ $continue k src |
4b8de65e AW |
169 | (or ($ $void) |
170 | ($ $const) | |
171 | ($ $prim))) | |
172 | (values exp '())) | |
173 | ||
6e422a35 | 174 | (($ $continue k src ($ $fun src* meta () body)) |
4b8de65e AW |
175 | (receive (body free) (cc body #f '()) |
176 | (match free | |
177 | (() | |
178 | (values (build-cps-term | |
6e422a35 | 179 | ($continue k src ($fun src* meta free ,body))) |
4b8de65e AW |
180 | free)) |
181 | (_ | |
182 | (values | |
183 | (let-gensyms (kinit v) | |
184 | (build-cps-term | |
6e422a35 | 185 | ($letk ((kinit ($kargs (v) (v) |
13085a82 AW |
186 | ,(init-closure |
187 | src v free self bound | |
188 | (build-cps-term | |
189 | ($continue k src ($values (v)))))))) | |
6e422a35 | 190 | ($continue kinit src ($fun src* meta free ,body))))) |
4b8de65e AW |
191 | (difference free bound)))))) |
192 | ||
6e422a35 | 193 | (($ $continue k src ($ $call proc args)) |
4b8de65e AW |
194 | (convert-free-vars (cons proc args) self bound |
195 | (match-lambda | |
196 | ((proc . args) | |
197 | (values (build-cps-term | |
6e422a35 | 198 | ($continue k src ($call proc args))) |
4b8de65e AW |
199 | '()))))) |
200 | ||
b3ae2b50 AW |
201 | (($ $continue k src ($ $callk k* proc args)) |
202 | (convert-free-vars (cons proc args) self bound | |
203 | (match-lambda | |
204 | ((proc . args) | |
205 | (values (build-cps-term | |
206 | ($continue k src ($callk k* proc args))) | |
207 | '()))))) | |
208 | ||
6e422a35 | 209 | (($ $continue k src ($ $primcall name args)) |
4b8de65e AW |
210 | (convert-free-vars args self bound |
211 | (lambda (args) | |
212 | (values (build-cps-term | |
6e422a35 | 213 | ($continue k src ($primcall name args))) |
4b8de65e AW |
214 | '())))) |
215 | ||
6e422a35 | 216 | (($ $continue k src ($ $values args)) |
4b8de65e AW |
217 | (convert-free-vars args self bound |
218 | (lambda (args) | |
219 | (values (build-cps-term | |
6e422a35 | 220 | ($continue k src ($values args))) |
4b8de65e AW |
221 | '())))) |
222 | ||
7ab76a83 | 223 | (($ $continue k src ($ $prompt escape? tag handler)) |
4b8de65e AW |
224 | (convert-free-var |
225 | tag self bound | |
226 | (lambda (tag) | |
227 | (values (build-cps-term | |
7ab76a83 | 228 | ($continue k src ($prompt escape? tag handler))) |
4b8de65e AW |
229 | '())))) |
230 | ||
231 | (_ (error "what" exp)))) | |
232 | ||
233 | ;; Convert the slot arguments of 'free-ref' primcalls from symbols to | |
234 | ;; indices. | |
235 | (define (convert-to-indices body free) | |
236 | (define (free-index sym) | |
237 | (or (list-index (cut eq? <> sym) free) | |
238 | (error "free variable not found!" sym free))) | |
239 | (define (visit-term term) | |
240 | (rewrite-cps-term term | |
241 | (($ $letk conts body) | |
242 | ($letk ,(map visit-cont conts) ,(visit-term body))) | |
6e422a35 | 243 | (($ $continue k src ($ $primcall 'free-ref (closure sym))) |
4b8de65e AW |
244 | ,(let-gensyms (idx) |
245 | (build-cps-term | |
246 | ($letconst (('idx idx (free-index sym))) | |
6e422a35 AW |
247 | ($continue k src ($primcall 'free-ref (closure idx))))))) |
248 | (($ $continue k src ($ $fun src* meta free body)) | |
249 | ($continue k src | |
250 | ($fun src* meta free ,(convert-to-indices body free)))) | |
4b8de65e AW |
251 | (($ $continue) |
252 | ,term))) | |
253 | (define (visit-cont cont) | |
254 | (rewrite-cps-cont cont | |
6e422a35 AW |
255 | (($ $cont sym ($ $kargs names syms body)) |
256 | (sym ($kargs names syms ,(visit-term body)))) | |
257 | (($ $cont sym ($ $kclause arity body)) | |
258 | (sym ($kclause ,arity ,(visit-cont body)))) | |
4b8de65e AW |
259 | ;; Other kinds of continuations don't bind values and don't have |
260 | ;; bodies. | |
261 | (($ $cont) | |
262 | ,cont))) | |
263 | ||
264 | (rewrite-cps-cont body | |
6e422a35 AW |
265 | (($ $cont sym ($ $kentry self tail clauses)) |
266 | (sym ($kentry self ,tail ,(map visit-cont clauses)))))) | |
4b8de65e AW |
267 | |
268 | (define (convert-closures exp) | |
269 | "Convert free reference in @var{exp} to primcalls to @code{free-ref}, | |
270 | and allocate and initialize flat closures." | |
271 | (match exp | |
6e422a35 | 272 | (($ $fun src meta () body) |
4b8de65e AW |
273 | (receive (body free) (cc body #f '()) |
274 | (unless (null? free) | |
275 | (error "Expected no free vars in toplevel thunk" exp body free)) | |
276 | (build-cps-exp | |
6e422a35 | 277 | ($fun src meta free ,(convert-to-indices body free))))))) |