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