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)) | |
8b1a4b23 | 37 | #:use-module (srfi srfi-9) |
4b8de65e AW |
38 | #:use-module (srfi srfi-26) |
39 | #:use-module (language cps) | |
8b1a4b23 | 40 | #:use-module (language cps dfg) |
4b8de65e AW |
41 | #:export (convert-closures)) |
42 | ||
cf8bb037 | 43 | ;; free := var ... |
4b8de65e | 44 | |
8b1a4b23 | 45 | (define (analyze-closures exp dfg) |
cf8bb037 AW |
46 | "Compute the set of free variables for all $fun instances in |
47 | @var{exp}." | |
fcb31f29 AW |
48 | (let ((bound-vars (make-hash-table)) |
49 | (free-vars (make-hash-table)) | |
983413a1 | 50 | (named-funs (make-hash-table)) |
6dc886fa | 51 | (well-known-vars (make-bitvector (var-counter) #t))) |
983413a1 | 52 | (define (add-named-fun! var cont) |
fcb31f29 AW |
53 | (hashq-set! named-funs var cont) |
54 | (match cont | |
55 | (($ $cont label ($ $kfun src meta self)) | |
56 | (unless (eq? var self) | |
57 | (hashq-set! bound-vars label var))))) | |
8b1a4b23 | 58 | (define (clear-well-known! var) |
6dc886fa AW |
59 | (bitvector-set! well-known-vars var #f)) |
60 | (define (compute-well-known-labels) | |
61 | (let ((bv (make-bitvector (label-counter) #f))) | |
62 | (hash-for-each | |
63 | (lambda (var cont) | |
64 | (match cont | |
65 | (($ $cont label ($ $kfun src meta self)) | |
66 | (unless (equal? var self) | |
67 | (bitvector-set! bv label | |
68 | (and (bitvector-ref well-known-vars var) | |
69 | (bitvector-ref well-known-vars self))))))) | |
70 | named-funs) | |
71 | bv)) | |
cf8bb037 AW |
72 | (define (union a b) |
73 | (lset-union eq? a b)) | |
74 | (define (difference a b) | |
75 | (lset-difference eq? a b)) | |
76 | (define (visit-cont cont bound) | |
77 | (match cont | |
78 | (($ $cont label ($ $kargs names vars body)) | |
79 | (visit-term body (append vars bound))) | |
80 | (($ $cont label ($ $kfun src meta self tail clause)) | |
983413a1 | 81 | (add-named-fun! self cont) |
cf8bb037 AW |
82 | (let ((free (if clause |
83 | (visit-cont clause (list self)) | |
84 | '()))) | |
6dc886fa | 85 | (hashq-set! free-vars label free) |
cf8bb037 AW |
86 | (difference free bound))) |
87 | (($ $cont label ($ $kclause arity body alternate)) | |
88 | (let ((free (visit-cont body bound))) | |
89 | (if alternate | |
90 | (union (visit-cont alternate bound) free) | |
4b8de65e | 91 | free))) |
cf8bb037 AW |
92 | (($ $cont) '()))) |
93 | (define (visit-term term bound) | |
94 | (match term | |
95 | (($ $letk conts body) | |
96 | (fold (lambda (cont free) | |
97 | (union (visit-cont cont bound) free)) | |
98 | (visit-term body bound) | |
99 | conts)) | |
100 | (($ $letrec names vars (($ $fun () cont) ...) body) | |
101 | (let ((bound (append vars bound))) | |
983413a1 | 102 | (for-each add-named-fun! vars cont) |
cf8bb037 AW |
103 | (fold (lambda (cont free) |
104 | (union (visit-cont cont bound) free)) | |
105 | (visit-term body bound) | |
106 | cont))) | |
107 | (($ $continue k src ($ $fun () body)) | |
8b1a4b23 AW |
108 | (match (lookup-predecessors k dfg) |
109 | ((_) (match (lookup-cont k dfg) | |
110 | (($ $kargs (name) (var)) | |
983413a1 | 111 | (add-named-fun! var body)))) |
8b1a4b23 | 112 | (_ #f)) |
cf8bb037 AW |
113 | (visit-cont body bound)) |
114 | (($ $continue k src exp) | |
115 | (visit-exp exp bound)))) | |
116 | (define (visit-exp exp bound) | |
117 | (define (adjoin var free) | |
118 | (if (or (memq var bound) (memq var free)) | |
119 | free | |
120 | (cons var free))) | |
121 | (match exp | |
122 | ((or ($ $void) ($ $const) ($ $prim)) '()) | |
123 | (($ $call proc args) | |
8b1a4b23 | 124 | (for-each clear-well-known! args) |
cf8bb037 AW |
125 | (fold adjoin (adjoin proc '()) args)) |
126 | (($ $primcall name args) | |
8b1a4b23 | 127 | (for-each clear-well-known! args) |
cf8bb037 | 128 | (fold adjoin '() args)) |
92805e21 AW |
129 | (($ $branch kt exp) |
130 | (visit-exp exp bound)) | |
cf8bb037 | 131 | (($ $values args) |
8b1a4b23 | 132 | (for-each clear-well-known! args) |
cf8bb037 AW |
133 | (fold adjoin '() args)) |
134 | (($ $prompt escape? tag handler) | |
8b1a4b23 | 135 | (clear-well-known! tag) |
cf8bb037 | 136 | (adjoin tag '())))) |
4b8de65e | 137 | |
cf8bb037 AW |
138 | (let ((free (visit-cont exp '()))) |
139 | (unless (null? free) | |
140 | (error "Expected no free vars in toplevel thunk" free exp)) | |
fcb31f29 | 141 | (values bound-vars free-vars named-funs (compute-well-known-labels))))) |
4b8de65e | 142 | |
32e62c2d | 143 | (define (prune-free-vars free-vars named-funs well-known var-aliases) |
cd130361 AW |
144 | (define (well-known? label) |
145 | (bitvector-ref well-known label)) | |
32e62c2d AW |
146 | (let ((eliminated (make-bitvector (label-counter) #f)) |
147 | (label-aliases (make-vector (label-counter) #f))) | |
cd130361 AW |
148 | (let lp ((label 0)) |
149 | (let ((label (bit-position #t well-known label))) | |
150 | (when label | |
151 | (match (hashq-ref free-vars label) | |
32e62c2d AW |
152 | ;; Mark all well-known closures that have no free variables |
153 | ;; for elimination. | |
cd130361 | 154 | (() (bitvector-set! eliminated label #t)) |
32e62c2d AW |
155 | ;; Replace well-known closures that have just one free |
156 | ;; variable by references to that free variable. | |
157 | ((var) | |
158 | (vector-set! label-aliases label var)) | |
cd130361 AW |
159 | (_ #f)) |
160 | (lp (1+ label))))) | |
32e62c2d | 161 | ;; Iterative free variable elimination. |
cd130361 AW |
162 | (let lp () |
163 | (let ((recurse? #f)) | |
32e62c2d AW |
164 | (define (adjoin elt list) |
165 | ;; Normally you wouldn't see duplicates in a free variable | |
166 | ;; list, but with aliases that is possible. | |
167 | (if (memq elt list) list (cons elt list))) | |
fcb31f29 | 168 | (define (prune-free closure-label free) |
32e62c2d AW |
169 | (match free |
170 | (() '()) | |
171 | ((var . free) | |
172 | (let lp ((var var) (alias-stack '())) | |
173 | (match (hashq-ref named-funs var) | |
174 | (($ $cont label) | |
175 | (cond | |
176 | ((bitvector-ref eliminated label) | |
fcb31f29 | 177 | (prune-free closure-label free)) |
32e62c2d AW |
178 | ((vector-ref label-aliases label) |
179 | => (lambda (var) | |
180 | (cond | |
181 | ((memq label alias-stack) | |
182 | ;; We have found a set of mutually recursive | |
183 | ;; well-known procedures, each of which only | |
184 | ;; closes over one of the others. Mark them | |
185 | ;; all for elimination. | |
186 | (for-each (lambda (label) | |
187 | (bitvector-set! eliminated label #t) | |
188 | (set! recurse? #t)) | |
189 | alias-stack) | |
fcb31f29 | 190 | (prune-free closure-label free)) |
32e62c2d AW |
191 | (else |
192 | (lp var (cons label alias-stack)))))) | |
fcb31f29 AW |
193 | ((eq? closure-label label) |
194 | ;; Eliminate self-reference. | |
fcb31f29 | 195 | (prune-free closure-label free)) |
32e62c2d | 196 | (else |
fcb31f29 AW |
197 | (adjoin var (prune-free closure-label free))))) |
198 | (_ (adjoin var (prune-free closure-label free)))))))) | |
cd130361 AW |
199 | (hash-for-each-handle |
200 | (lambda (pair) | |
201 | (match pair | |
202 | ((label . ()) #t) | |
203 | ((label . free) | |
32e62c2d | 204 | (let ((orig-nfree (length free)) |
fcb31f29 | 205 | (free (prune-free label free))) |
cd130361 | 206 | (set-cdr! pair free) |
32e62c2d AW |
207 | ;; If we managed to eliminate one or more free variables |
208 | ;; from a well-known function, it could be that we can | |
209 | ;; eliminate or alias this function as well. | |
210 | (when (and (well-known? label) | |
211 | (< (length free) orig-nfree)) | |
212 | (match free | |
213 | (() | |
214 | (bitvector-set! eliminated label #t) | |
215 | (set! recurse? #t)) | |
216 | ((var) | |
217 | (vector-set! label-aliases label var) | |
218 | (set! recurse? #t)) | |
219 | (_ #t))))))) | |
cd130361 AW |
220 | free-vars) |
221 | ;; Iterate to fixed point. | |
32e62c2d AW |
222 | (when recurse? (lp)))) |
223 | ;; Populate var-aliases from label-aliases. | |
224 | (hash-for-each (lambda (var cont) | |
225 | (match cont | |
226 | (($ $cont label) | |
227 | (let ((alias (vector-ref label-aliases label))) | |
228 | (when alias | |
229 | (vector-set! var-aliases var alias)))))) | |
230 | named-funs))) | |
cd130361 | 231 | |
fcb31f29 | 232 | (define (convert-one bound label fun free-vars named-funs well-known aliases) |
cd130361 AW |
233 | (define (well-known? label) |
234 | (bitvector-ref well-known label)) | |
235 | ||
6dc886fa | 236 | (let ((free (hashq-ref free-vars label)) |
cd130361 | 237 | (self-known? (well-known? label)) |
6dc886fa | 238 | (self (match fun (($ $kfun _ _ self) self)))) |
2920554a AW |
239 | (define (convert-free-var var k) |
240 | "Convert one possibly free variable reference to a bound reference. | |
241 | ||
242 | If @var{var} is free, it is replaced by a closure reference via a | |
243 | @code{free-ref} primcall, and @var{k} is called with the new var. | |
244 | Otherwise @var{var} is bound, so @var{k} is called with @var{var}." | |
245 | (cond | |
246 | ((list-index (cut eq? <> var) free) | |
247 | => (lambda (free-idx) | |
248 | (match (cons self-known? free) | |
249 | ;; A reference to the one free var of a well-known function. | |
250 | ((#t _) (k self)) | |
251 | ;; A reference to one of the two free vars in a well-known | |
252 | ;; function. | |
253 | ((#t _ _) | |
254 | (let-fresh (k*) (var*) | |
255 | (build-cps-term | |
256 | ($letk ((k* ($kargs (var*) (var*) ,(k var*)))) | |
257 | ($continue k* #f | |
258 | ($primcall (match free-idx (0 'car) (1 'cdr)) (self))))))) | |
259 | (_ | |
260 | (let-fresh (k* kidx) (idx var*) | |
261 | (build-cps-term | |
262 | ($letk ((kidx ($kargs ('idx) (idx) | |
263 | ($letk ((k* ($kargs (var*) (var*) ,(k var*)))) | |
264 | ($continue k* #f | |
265 | ($primcall | |
266 | (cond | |
267 | ((not self-known?) 'free-ref) | |
268 | ((<= free-idx #xff) 'vector-ref/immediate) | |
269 | (else 'vector-ref)) | |
270 | (self idx))))))) | |
271 | ($continue kidx #f ($const free-idx))))))))) | |
fcb31f29 | 272 | ((eq? var bound) (k self)) |
2920554a AW |
273 | (else (k var)))) |
274 | ||
275 | (define (convert-free-vars vars k) | |
276 | "Convert a number of possibly free references to bound references. | |
277 | @var{k} is called with the bound references, and should return the | |
278 | term." | |
279 | (match vars | |
280 | (() (k '())) | |
281 | ((var . vars) | |
282 | (convert-free-var var | |
283 | (lambda (var) | |
284 | (convert-free-vars vars | |
285 | (lambda (vars) | |
286 | (k (cons var vars))))))))) | |
287 | ||
288 | (define (allocate-closure src name var label known? free body) | |
289 | "Allocate a new closure." | |
290 | (match (cons known? free) | |
291 | ((#f . _) | |
292 | (let-fresh (k*) () | |
293 | (build-cps-term | |
294 | ($letk ((k* ($kargs (name) (var) ,body))) | |
295 | ($continue k* src | |
296 | ($closure label (length free))))))) | |
297 | ((#t) | |
298 | ;; Well-known closure with no free variables; elide the | |
299 | ;; binding entirely. | |
300 | body) | |
301 | ((#t _) | |
302 | ;; Well-known closure with one free variable; the free var is the | |
303 | ;; closure, and no new binding need be made. | |
304 | body) | |
305 | ((#t _ _) | |
306 | ;; Well-known closure with two free variables; the closure is a | |
307 | ;; pair. | |
308 | (let-fresh (kinit kfalse) (false) | |
309 | (build-cps-term | |
310 | ($letk ((kinit ($kargs (name) (var) | |
311 | ,body)) | |
312 | (kfalse ($kargs ('false) (false) | |
313 | ($continue kinit src | |
314 | ($primcall 'cons (false false)))))) | |
315 | ($continue kfalse src ($const #f)))))) | |
316 | ;; Well-known callee with more than two free variables; the closure | |
317 | ;; is a vector. | |
318 | ((#t . _) | |
319 | (let ((nfree (length free))) | |
320 | (let-fresh (kinit klen kfalse) (false len-var) | |
321 | (build-cps-term | |
322 | ($letk ((kinit ($kargs (name) (var) ,body)) | |
323 | (kfalse | |
324 | ($kargs ('false) (false) | |
325 | ($letk ((klen | |
326 | ($kargs ('len) (len-var) | |
327 | ($continue kinit src | |
328 | ($primcall (if (<= nfree #xff) | |
329 | 'make-vector/immediate | |
330 | 'make-vector) | |
331 | (len-var false)))))) | |
332 | ($continue klen src ($const nfree)))))) | |
333 | ($continue kfalse src ($const #f))))))))) | |
334 | ||
335 | (define (init-closure src var known? closure-free body) | |
336 | "Initialize the free variables @var{closure-free} in a closure | |
337 | bound to @var{var}, and continue with @var{body}." | |
338 | (match (cons known? closure-free) | |
339 | ;; Well-known callee with no free variables; no initialization | |
340 | ;; necessary. | |
341 | ((#t) body) | |
342 | ;; Well-known callee with one free variable; no initialization | |
343 | ;; necessary. | |
344 | ((#t _) body) | |
345 | ;; Well-known callee with two free variables; do a set-car! and | |
346 | ;; set-cdr!. | |
347 | ((#t v0 v1) | |
348 | (let-fresh (kcar kcdr) () | |
349 | (convert-free-var | |
350 | v0 | |
351 | (lambda (v0) | |
352 | (build-cps-term | |
353 | ($letk ((kcar ($kargs () () | |
354 | ,(convert-free-var | |
355 | v1 | |
356 | (lambda (v1) | |
357 | (build-cps-term | |
358 | ($letk ((kcdr ($kargs () () ,body))) | |
359 | ($continue kcdr src | |
360 | ($primcall 'set-cdr! (var v1)))))))))) | |
361 | ($continue kcar src | |
362 | ($primcall 'set-car! (var v0))))))))) | |
363 | ;; Otherwise residualize a sequence of vector-set! or free-set!, | |
364 | ;; depending on whether the callee is well-known or not. | |
365 | (_ | |
366 | (fold (lambda (free idx body) | |
367 | (let-fresh (k) (idxvar) | |
368 | (build-cps-term | |
369 | ($letk ((k ($kargs () () ,body))) | |
370 | ,(convert-free-var | |
371 | free | |
372 | (lambda (free) | |
373 | (build-cps-term | |
374 | ($letconst (('idx idxvar idx)) | |
375 | ($continue k src | |
376 | ($primcall (cond | |
377 | ((not known?) 'free-set!) | |
378 | ((<= idx #xff) 'vector-set!/immediate) | |
379 | (else 'vector-set!)) | |
380 | (var idxvar free))))))))))) | |
381 | body | |
382 | closure-free | |
383 | (iota (length closure-free)))))) | |
384 | ||
385 | ;; Load the closure for a known call. The callee may or may not be | |
386 | ;; known at all call sites. | |
387 | (define (convert-known-proc-call var label self self-known? free k) | |
388 | ;; Well-known closures with one free variable are replaced at their | |
389 | ;; use sites by uses of the one free variable. The use sites of a | |
390 | ;; well-known closures are only in well-known proc calls, and in | |
391 | ;; free lists of other closures. Here we handle the call case; the | |
392 | ;; free list case is handled by prune-free-vars. | |
393 | (define (rename var) | |
394 | (let ((var* (vector-ref aliases var))) | |
395 | (if var* | |
396 | (rename var*) | |
397 | var))) | |
398 | (match (cons (well-known? label) | |
399 | (hashq-ref free-vars label)) | |
400 | ((#t) | |
401 | ;; Calling a well-known procedure with no free variables; pass #f | |
402 | ;; as the closure. | |
403 | (let-fresh (k*) (v*) | |
404 | (build-cps-term | |
405 | ($letk ((k* ($kargs (v*) (v*) ,(k v*)))) | |
406 | ($continue k* #f ($const #f)))))) | |
407 | ((#t _) | |
408 | ;; Calling a well-known procedure with one free variable; pass | |
409 | ;; the free variable as the closure. | |
410 | (convert-free-var (rename var) k)) | |
411 | (_ | |
412 | (convert-free-var var k)))) | |
413 | ||
6dc886fa AW |
414 | (define (visit-cont cont) |
415 | (rewrite-cps-cont cont | |
416 | (($ $cont label ($ $kargs names vars body)) | |
417 | (label ($kargs names vars ,(visit-term body)))) | |
418 | (($ $cont label ($ $kfun src meta self tail clause)) | |
419 | (label ($kfun src meta self ,tail | |
420 | ,(and clause (visit-cont clause))))) | |
421 | (($ $cont label ($ $kclause arity body alternate)) | |
422 | (label ($kclause ,arity ,(visit-cont body) | |
423 | ,(and alternate (visit-cont alternate))))) | |
424 | (($ $cont) ,cont))) | |
425 | (define (visit-term term) | |
426 | (match term | |
427 | (($ $letk conts body) | |
428 | (build-cps-term | |
429 | ($letk ,(map visit-cont conts) ,(visit-term body)))) | |
4b8de65e | 430 | |
6dc886fa AW |
431 | ;; Remove letrec. |
432 | (($ $letrec names vars funs body) | |
433 | (let lp ((in (map list names vars funs)) | |
434 | (bindings (lambda (body) body)) | |
435 | (body (visit-term body))) | |
436 | (match in | |
437 | (() (bindings body)) | |
438 | (((name var ($ $fun () | |
439 | (and fun-body | |
440 | ($ $cont kfun ($ $kfun src))))) . in) | |
cd130361 AW |
441 | (let ((fun-free (hashq-ref free-vars kfun))) |
442 | (lp in | |
443 | (lambda (body) | |
444 | (allocate-closure | |
445 | src name var kfun (well-known? kfun) fun-free | |
446 | (bindings body))) | |
447 | (init-closure | |
2920554a | 448 | src var (well-known? kfun) fun-free |
cd130361 | 449 | body))))))) |
4b8de65e | 450 | |
6dc886fa AW |
451 | (($ $continue k src (or ($ $void) ($ $const) ($ $prim))) |
452 | term) | |
b3ae2b50 | 453 | |
6dc886fa | 454 | (($ $continue k src ($ $fun () ($ $cont kfun))) |
cd130361 | 455 | (let ((fun-free (hashq-ref free-vars kfun))) |
32e62c2d AW |
456 | (match (cons (well-known? kfun) fun-free) |
457 | ((known?) | |
6dc886fa | 458 | (build-cps-term |
32e62c2d | 459 | ($continue k src ,(if known? |
cd130361 AW |
460 | (build-cps-exp ($const #f)) |
461 | (build-cps-exp ($closure kfun 0)))))) | |
32e62c2d AW |
462 | ((#t _) |
463 | ;; A well-known closure of one free variable is replaced | |
464 | ;; at each use with the free variable itself, so we don't | |
465 | ;; need a binding at all; and yet, the continuation | |
466 | ;; expects one value, so give it something. DCE should | |
467 | ;; clean up later. | |
468 | (build-cps-term | |
469 | ($continue k src ,(build-cps-exp ($const #f))))) | |
cd130361 AW |
470 | (_ |
471 | (let-fresh () (var) | |
472 | (allocate-closure | |
473 | src #f var kfun (well-known? kfun) fun-free | |
474 | (init-closure | |
2920554a | 475 | src var (well-known? kfun) fun-free |
cd130361 | 476 | (build-cps-term ($continue k src ($values (var))))))))))) |
6dc886fa AW |
477 | |
478 | (($ $continue k src ($ $call proc args)) | |
479 | (match (hashq-ref named-funs proc) | |
cd130361 | 480 | (($ $cont kfun) |
6dc886fa | 481 | (convert-known-proc-call |
cd130361 | 482 | proc kfun self self-known? free |
6dc886fa | 483 | (lambda (proc) |
2920554a | 484 | (convert-free-vars args |
6dc886fa AW |
485 | (lambda (args) |
486 | (build-cps-term | |
487 | ($continue k src | |
cd130361 | 488 | ($callk kfun proc args)))))))) |
6dc886fa | 489 | (#f |
2920554a | 490 | (convert-free-vars (cons proc args) |
983413a1 AW |
491 | (match-lambda |
492 | ((proc . args) | |
6dc886fa AW |
493 | (build-cps-term |
494 | ($continue k src | |
495 | ($call proc args))))))))) | |
4b8de65e | 496 | |
6dc886fa | 497 | (($ $continue k src ($ $primcall name args)) |
2920554a | 498 | (convert-free-vars args |
6dc886fa AW |
499 | (lambda (args) |
500 | (build-cps-term | |
501 | ($continue k src ($primcall name args)))))) | |
4b8de65e | 502 | |
92805e21 AW |
503 | (($ $continue k src ($ $branch kt ($ $primcall name args))) |
504 | (convert-free-vars args | |
505 | (lambda (args) | |
506 | (build-cps-term | |
507 | ($continue k src | |
508 | ($branch kt ($primcall name args))))))) | |
509 | ||
510 | (($ $continue k src ($ $branch kt ($ $values (arg)))) | |
511 | (convert-free-var arg | |
512 | (lambda (arg) | |
513 | (build-cps-term | |
514 | ($continue k src | |
515 | ($branch kt ($values (arg)))))))) | |
516 | ||
6dc886fa | 517 | (($ $continue k src ($ $values args)) |
2920554a | 518 | (convert-free-vars args |
6dc886fa AW |
519 | (lambda (args) |
520 | (build-cps-term | |
521 | ($continue k src ($values args)))))) | |
4b8de65e | 522 | |
6dc886fa | 523 | (($ $continue k src ($ $prompt escape? tag handler)) |
2920554a | 524 | (convert-free-var tag |
6dc886fa AW |
525 | (lambda (tag) |
526 | (build-cps-term | |
527 | ($continue k src | |
528 | ($prompt escape? tag handler)))))))) | |
529 | (visit-cont (build-cps-cont (label ,fun))))) | |
4b8de65e | 530 | |
a0329d01 | 531 | (define (convert-closures fun) |
4b8de65e AW |
532 | "Convert free reference in @var{exp} to primcalls to @code{free-ref}, |
533 | and allocate and initialize flat closures." | |
8b1a4b23 AW |
534 | (let ((dfg (compute-dfg fun))) |
535 | (with-fresh-name-state-from-dfg dfg | |
536 | (call-with-values (lambda () (analyze-closures fun dfg)) | |
fcb31f29 | 537 | (lambda (bound-vars free-vars named-funs well-known) |
32e62c2d AW |
538 | (let ((labels (sort (hash-map->list (lambda (k v) k) free-vars) <)) |
539 | (aliases (make-vector (var-counter) #f))) | |
540 | (prune-free-vars free-vars named-funs well-known aliases) | |
8b1a4b23 | 541 | (build-cps-term |
983413a1 | 542 | ($program |
6dc886fa | 543 | ,(map (lambda (label) |
fcb31f29 AW |
544 | (convert-one (hashq-ref bound-vars label) label |
545 | (lookup-cont label dfg) | |
32e62c2d | 546 | free-vars named-funs well-known aliases)) |
983413a1 | 547 | labels))))))))) |