Commit | Line | Data |
---|---|---|
7a08e479 AW |
1 | ;;; Continuation-passing style (CPS) intermediate language (IL) |
2 | ||
3 | ;; Copyright (C) 2013, 2014 Free Software Foundation, Inc. | |
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 | ;;; Common subexpression elimination for CPS. | |
22 | ;;; | |
23 | ;;; Code: | |
24 | ||
25 | (define-module (language cps cse) | |
26 | #:use-module (ice-9 match) | |
27 | #:use-module (srfi srfi-1) | |
28 | #:use-module (language cps) | |
29 | #:use-module (language cps dfg) | |
30 | #:use-module (language cps effects-analysis) | |
31 | #:use-module (language cps renumber) | |
32 | #:export (eliminate-common-subexpressions)) | |
33 | ||
34 | (define (compute-always-available-expressions effects) | |
35 | "Return the set of continuations whose values are always available | |
36 | within their dominance frontier. This is the case for effects that have | |
37 | no dependencies and which cause no effects besides &type-check." | |
38 | (let ((out (make-bitvector (vector-length effects) #f))) | |
39 | (let lp ((n 0)) | |
40 | (cond | |
41 | ((< n (vector-length effects)) | |
42 | (when (zero? (exclude-effects (vector-ref effects n) &type-check)) | |
43 | (bitvector-set! out n #t)) | |
44 | (lp (1+ n))) | |
45 | (else out))))) | |
46 | ||
47 | (define (compute-available-expressions dfg min-label label-count) | |
48 | "Compute and return the continuations that may be reached if flow | |
49 | reaches a continuation N. Returns a vector of bitvectors, whose first | |
50 | index corresponds to MIN-LABEL, and so on." | |
51 | (let* ((effects (compute-effects dfg min-label label-count)) | |
52 | (always-avail (compute-always-available-expressions effects)) | |
53 | ;; Vector of bitvectors, indicating that at a continuation N, | |
54 | ;; the values from continuations M... are available. | |
55 | (avail-in (make-vector label-count #f)) | |
9382794a | 56 | (avail-out (make-vector label-count #f))) |
7a08e479 AW |
57 | |
58 | (define (label->idx label) (- label min-label)) | |
59 | (define (idx->label idx) (+ idx min-label)) | |
60 | ||
7a08e479 AW |
61 | (let lp ((n 0)) |
62 | (when (< n label-count) | |
63 | (let ((in (make-bitvector label-count #f)) | |
64 | (out (make-bitvector label-count #f))) | |
65 | (vector-set! avail-in n in) | |
66 | (vector-set! avail-out n out) | |
67 | (lp (1+ n))))) | |
68 | ||
69 | (let ((tmp (make-bitvector label-count #f))) | |
70 | (define (bitvector-copy! dst src) | |
71 | (bitvector-fill! dst #f) | |
72 | (bit-set*! dst src #t)) | |
73 | (define (intersect! dst src) | |
74 | (bitvector-copy! tmp src) | |
75 | (bit-invert! tmp) | |
76 | (bit-set*! dst tmp #f)) | |
77 | (let lp ((n 0) (first? #t) (changed? #f)) | |
78 | (cond | |
79 | ((< n label-count) | |
80 | (let* ((in (vector-ref avail-in n)) | |
81 | (prev-count (bit-count #t in)) | |
82 | (out (vector-ref avail-out n)) | |
83 | (fx (vector-ref effects n))) | |
84 | ;; Intersect avail-out from predecessors into "in". | |
780ad383 AW |
85 | (let lp ((preds (lookup-predecessors (idx->label n) dfg)) |
86 | (initialized? #f)) | |
87 | (match preds | |
88 | (() #t) | |
89 | ((pred . preds) | |
90 | (let ((pred (label->idx pred))) | |
91 | (cond | |
9382794a | 92 | ((and first? (<= n pred)) |
780ad383 AW |
93 | ;; Avoid intersecting back-edges and cross-edges on |
94 | ;; the first iteration. | |
95 | (lp preds initialized?)) | |
96 | (else | |
97 | (if initialized? | |
98 | (intersect! in (vector-ref avail-out pred)) | |
99 | (bitvector-copy! in (vector-ref avail-out pred))) | |
100 | (lp preds #t))))))) | |
7a08e479 AW |
101 | (let ((new-count (bit-count #t in))) |
102 | (unless (= prev-count new-count) | |
103 | ;; Copy "in" to "out". | |
104 | (bitvector-copy! out in) | |
105 | ;; Kill expressions that don't commute. | |
106 | (cond | |
4fef6373 | 107 | ((causes-all-effects? fx &all-effects) |
7a08e479 AW |
108 | ;; Fast-path if this expression clobbers the world. |
109 | (intersect! out always-avail)) | |
110 | ((effect-free? (exclude-effects fx &type-check)) | |
111 | ;; Fast-path if this expression clobbers nothing. | |
112 | #t) | |
113 | (else | |
114 | ;; Loop of sadness. | |
115 | (bitvector-copy! tmp out) | |
116 | (bit-set*! tmp always-avail #f) | |
117 | (let lp ((i 0)) | |
118 | (let ((i (bit-position #t tmp i))) | |
119 | (when i | |
120 | (unless (effects-commute? (vector-ref effects i) fx) | |
121 | (bitvector-set! out i #f)) | |
122 | (lp (1+ i)))))))) | |
123 | ;; Unless this expression allocates a fresh object or | |
124 | ;; changes the current fluid environment, mark expressions | |
125 | ;; that match it as available for elimination. | |
126 | (unless (causes-effects? fx (logior &fluid-environment | |
127 | &allocation)) | |
128 | (bitvector-set! out n #t)) | |
129 | (lp (1+ n) first? (or changed? (not (= prev-count new-count))))))) | |
130 | (else | |
780ad383 | 131 | (if (or first? changed?) |
7a08e479 | 132 | (lp 0 #f #f) |
9382794a | 133 | avail-in))))))) |
7a08e479 | 134 | |
d03c3c77 AW |
135 | (define (compute-truthy-expressions dfg min-label label-count) |
136 | "Compute a \"truth map\", indicating which expressions can be shown to | |
137 | be true and/or false at each of LABEL-COUNT expressions in DFG, starting | |
138 | from MIN-LABEL. Returns a vector of bitvectors, each bitvector twice as | |
139 | long as LABEL-COUNT. The first half of the bitvector indicates labels | |
140 | that may be true, and the second half those that may be false. It could | |
141 | be that both true and false proofs are available." | |
142 | (let ((boolv (make-vector label-count #f))) | |
143 | (define (label->idx label) (- label min-label)) | |
144 | (define (idx->label idx) (+ idx min-label)) | |
145 | (define (true-idx idx) idx) | |
146 | (define (false-idx idx) (+ idx label-count)) | |
147 | ||
148 | (let lp ((n 0)) | |
149 | (when (< n label-count) | |
150 | (let ((bool (make-bitvector (* label-count 2) #f))) | |
151 | (vector-set! boolv n bool) | |
152 | (lp (1+ n))))) | |
153 | ||
154 | (let ((tmp (make-bitvector (* label-count 2) #f))) | |
155 | (define (bitvector-copy! dst src) | |
156 | (bitvector-fill! dst #f) | |
157 | (bit-set*! dst src #t)) | |
158 | (define (intersect! dst src) | |
159 | (bitvector-copy! tmp src) | |
160 | (bit-invert! tmp) | |
161 | (bit-set*! dst tmp #f)) | |
162 | (let lp ((n 0) (first? #t) (changed? #f)) | |
163 | (cond | |
164 | ((< n label-count) | |
165 | (let* ((label (idx->label n)) | |
166 | (bool (vector-ref boolv n)) | |
167 | (prev-count (bit-count #t bool))) | |
168 | ;; Intersect truthiness from all predecessors. | |
169 | (let lp ((preds (lookup-predecessors label dfg)) | |
170 | (initialized? #f)) | |
171 | (match preds | |
172 | (() #t) | |
173 | ((pred . preds) | |
174 | (let ((pidx (label->idx pred))) | |
175 | (cond | |
176 | ((and first? (<= n pidx)) | |
177 | ;; Avoid intersecting back-edges and cross-edges on | |
178 | ;; the first iteration. | |
179 | (lp preds initialized?)) | |
180 | (else | |
181 | (if initialized? | |
182 | (intersect! bool (vector-ref boolv pidx)) | |
183 | (bitvector-copy! bool (vector-ref boolv pidx))) | |
184 | (match (lookup-predecessors pred dfg) | |
185 | ((test) | |
186 | (let ((tidx (label->idx test))) | |
187 | (match (lookup-cont pred dfg) | |
188 | (($ $kif kt kf) | |
189 | (when (eqv? kt label) | |
190 | (bitvector-set! bool (true-idx tidx) #t)) | |
191 | (when (eqv? kf label) | |
192 | (bitvector-set! bool (false-idx tidx) #t))) | |
193 | (_ #t)))) | |
194 | (_ #t)) | |
195 | (lp preds #t))))))) | |
196 | (lp (1+ n) first? | |
197 | (or changed? | |
198 | (not (= prev-count (bit-count #t bool))))))) | |
199 | (else | |
200 | (if (or first? changed?) | |
201 | (lp 0 #f #f) | |
202 | boolv))))))) | |
203 | ||
7a08e479 AW |
204 | (define (compute-defs dfg min-label label-count) |
205 | (define (cont-defs k) | |
206 | (match (lookup-cont k dfg) | |
207 | (($ $kargs names vars) vars) | |
208 | (_ '()))) | |
209 | (define (idx->label idx) (+ idx min-label)) | |
210 | (let ((defs (make-vector label-count '()))) | |
211 | (let lp ((n 0)) | |
212 | (when (< n label-count) | |
213 | (vector-set! | |
214 | defs | |
215 | n | |
216 | (match (lookup-cont (idx->label n) dfg) | |
217 | (($ $kargs _ _ body) | |
218 | (match (find-call body) | |
219 | (($ $continue k) (cont-defs k)))) | |
220 | (($ $kreceive arity kargs) | |
221 | (cont-defs kargs)) | |
222 | (($ $kclause arity ($ $cont kargs ($ $kargs names syms))) | |
223 | syms) | |
224 | (($ $kif) '()) | |
8320f504 | 225 | (($ $kfun src meta self) (list self)) |
7a08e479 AW |
226 | (($ $ktail) '()))) |
227 | (lp (1+ n)))) | |
228 | defs)) | |
229 | ||
230 | (define (compute-label-and-var-ranges fun) | |
231 | (match fun | |
a0329d01 | 232 | (($ $cont kfun ($ $kfun src meta self)) |
405805fb | 233 | ((make-local-cont-folder min-label label-count min-var var-count) |
7a08e479 AW |
234 | (lambda (k cont min-label label-count min-var var-count) |
235 | (let ((min-label (min k min-label)) | |
236 | (label-count (1+ label-count))) | |
237 | (match cont | |
238 | (($ $kargs names vars body) | |
239 | (let lp ((body body) | |
240 | (min-var (fold min min-var vars)) | |
241 | (var-count (+ var-count (length vars)))) | |
242 | (match body | |
243 | (($ $letrec names vars funs body) | |
244 | (lp body | |
245 | (fold min min-var vars) | |
246 | (+ var-count (length vars)))) | |
247 | (($ $letk conts body) (lp body min-var var-count)) | |
248 | (_ (values min-label label-count min-var var-count))))) | |
8320f504 | 249 | (($ $kfun src meta self) |
7a08e479 AW |
250 | (values min-label label-count (min self min-var) (1+ var-count))) |
251 | (_ | |
252 | (values min-label label-count min-var var-count))))) | |
a0329d01 | 253 | fun kfun 0 self 0)))) |
7a08e479 | 254 | |
9382794a | 255 | (define (compute-idoms dfg min-label label-count) |
7a08e479 AW |
256 | (define (label->idx label) (- label min-label)) |
257 | (define (idx->label idx) (+ idx min-label)) | |
258 | (let ((idoms (make-vector label-count #f))) | |
259 | (define (common-idom d0 d1) | |
260 | ;; We exploit the fact that a reverse post-order is a topological | |
261 | ;; sort, and so the idom of a node is always numerically less than | |
262 | ;; the node itself. | |
263 | (cond | |
264 | ((= d0 d1) d0) | |
265 | ((< d0 d1) (common-idom d0 (vector-ref idoms (label->idx d1)))) | |
266 | (else (common-idom (vector-ref idoms (label->idx d0)) d1)))) | |
267 | (define (compute-idom preds) | |
8c6a0b7e | 268 | (define (has-idom? pred) |
9382794a | 269 | (vector-ref idoms (label->idx pred))) |
7a08e479 AW |
270 | (match preds |
271 | (() min-label) | |
272 | ((pred . preds) | |
8c6a0b7e AW |
273 | (if (has-idom? pred) |
274 | (let lp ((idom pred) (preds preds)) | |
275 | (match preds | |
276 | (() idom) | |
277 | ((pred . preds) | |
278 | (lp (if (has-idom? pred) | |
279 | (common-idom idom pred) | |
280 | idom) | |
281 | preds)))) | |
282 | (compute-idom preds))))) | |
7a08e479 AW |
283 | ;; This is the iterative O(n^2) fixpoint algorithm, originally from |
284 | ;; Allen and Cocke ("Graph-theoretic constructs for program flow | |
285 | ;; analysis", 1972). See the discussion in Cooper, Harvey, and | |
286 | ;; Kennedy's "A Simple, Fast Dominance Algorithm", 2001. | |
287 | (let iterate ((n 0) (changed? #f)) | |
288 | (cond | |
289 | ((< n label-count) | |
290 | (let ((idom (vector-ref idoms n)) | |
8c6a0b7e | 291 | (idom* (compute-idom (lookup-predecessors (idx->label n) dfg)))) |
7a08e479 AW |
292 | (cond |
293 | ((eqv? idom idom*) | |
294 | (iterate (1+ n) changed?)) | |
295 | (else | |
296 | (vector-set! idoms n idom*) | |
297 | (iterate (1+ n) #t))))) | |
298 | (changed? | |
299 | (iterate 0 #f)) | |
300 | (else idoms))))) | |
301 | ||
302 | ;; Compute a vector containing, for each node, a list of the nodes that | |
303 | ;; it immediately dominates. These are the "D" edges in the DJ tree. | |
304 | (define (compute-dom-edges idoms min-label) | |
305 | (define (label->idx label) (- label min-label)) | |
306 | (define (idx->label idx) (+ idx min-label)) | |
307 | (define (vector-push! vec idx val) | |
308 | (let ((v vec) (i idx)) | |
309 | (vector-set! v i (cons val (vector-ref v i))))) | |
310 | (let ((doms (make-vector (vector-length idoms) '()))) | |
311 | (let lp ((n 0)) | |
312 | (when (< n (vector-length idoms)) | |
313 | (let ((idom (vector-ref idoms n))) | |
314 | (vector-push! doms (label->idx idom) (idx->label n))) | |
315 | (lp (1+ n)))) | |
316 | doms)) | |
317 | ||
318 | (define (compute-equivalent-subexpressions fun dfg) | |
9382794a AW |
319 | (define (compute min-label label-count min-var var-count) |
320 | (let ((avail (compute-available-expressions dfg min-label label-count)) | |
321 | (idoms (compute-idoms dfg min-label label-count)) | |
8c6a0b7e AW |
322 | (defs (compute-defs dfg min-label label-count)) |
323 | (var-substs (make-vector var-count #f)) | |
d03c3c77 | 324 | (equiv-labels (make-vector label-count #f)) |
8c6a0b7e AW |
325 | (equiv-set (make-hash-table))) |
326 | (define (idx->label idx) (+ idx min-label)) | |
327 | (define (label->idx label) (- label min-label)) | |
328 | (define (idx->var idx) (+ idx min-var)) | |
329 | (define (var->idx var) (- var min-var)) | |
330 | ||
df1bdc1e AW |
331 | (define (for-each/2 f l1 l2) |
332 | (unless (= (length l1) (length l2)) | |
333 | (error "bad lengths" l1 l2)) | |
334 | (let lp ((l1 l1) (l2 l2)) | |
335 | (when (pair? l1) | |
336 | (f (car l1) (car l2)) | |
337 | (lp (cdr l1) (cdr l2))))) | |
338 | ||
8c6a0b7e AW |
339 | (define (subst-var var) |
340 | ;; It could be that the var is free in this function; if so, its | |
341 | ;; name will be less than min-var. | |
342 | (let ((idx (var->idx var))) | |
343 | (if (<= 0 idx) | |
344 | (vector-ref var-substs idx) | |
345 | var))) | |
346 | ||
347 | (define (compute-exp-key exp) | |
348 | (match exp | |
349 | (($ $void) 'void) | |
350 | (($ $const val) (cons 'const val)) | |
351 | (($ $prim name) (cons 'prim name)) | |
24b611e8 | 352 | (($ $fun free body) #f) |
8c6a0b7e AW |
353 | (($ $call proc args) #f) |
354 | (($ $callk k proc args) #f) | |
355 | (($ $primcall name args) | |
356 | (cons* 'primcall name (map subst-var args))) | |
357 | (($ $values args) #f) | |
358 | (($ $prompt escape? tag handler) #f))) | |
359 | ||
360 | ;; The initial substs vector is the identity map. | |
361 | (let lp ((var min-var)) | |
362 | (when (< (var->idx var) var-count) | |
363 | (vector-set! var-substs (var->idx var) var) | |
364 | (lp (1+ var)))) | |
365 | ||
366 | ;; Traverse the labels in fun in forward order, which will visit | |
367 | ;; dominators first. | |
368 | (let lp ((label min-label)) | |
369 | (when (< (label->idx label) label-count) | |
370 | (match (lookup-cont label dfg) | |
371 | (($ $kargs names vars body) | |
372 | (match (find-call body) | |
373 | (($ $continue k src exp) | |
374 | (let* ((exp-key (compute-exp-key exp)) | |
375 | (equiv (hash-ref equiv-set exp-key '())) | |
376 | (avail (vector-ref avail (label->idx label)))) | |
377 | (let lp ((candidates equiv)) | |
378 | (match candidates | |
379 | (() | |
380 | ;; No matching expressions. Add our expression | |
381 | ;; to the equivalence set, if appropriate. | |
382 | (when exp-key | |
383 | (hash-set! equiv-set exp-key (cons label equiv)))) | |
384 | ((candidate . candidates) | |
d03c3c77 AW |
385 | (cond |
386 | ((not (bitvector-ref avail (label->idx candidate))) | |
387 | ;; This expression isn't available here; try | |
388 | ;; the next one. | |
389 | (lp candidates)) | |
390 | (else | |
391 | ;; Yay, a match. Mark expression as equivalent. | |
392 | (vector-set! equiv-labels (label->idx label) | |
393 | candidate) | |
394 | ;; If we dominate the successor, mark vars | |
395 | ;; for substitution. | |
396 | (when (= label (vector-ref idoms (label->idx k))) | |
397 | (for-each/2 | |
398 | (lambda (var subst-var) | |
399 | (vector-set! var-substs (var->idx var) subst-var)) | |
400 | (vector-ref defs (label->idx label)) | |
401 | (vector-ref defs (label->idx candidate))))))))))))) | |
8c6a0b7e AW |
402 | (_ #f)) |
403 | (lp (1+ label)))) | |
404 | (values (compute-dom-edges idoms min-label) | |
d03c3c77 | 405 | equiv-labels defs min-label var-substs min-var))) |
8c6a0b7e | 406 | |
9382794a | 407 | (call-with-values (lambda () (compute-label-and-var-ranges fun)) compute)) |
8c6a0b7e | 408 | |
d03c3c77 AW |
409 | (define (apply-cse fun dfg |
410 | doms equiv-labels defs min-label var-substs min-var boolv) | |
7a08e479 AW |
411 | (define (idx->label idx) (+ idx min-label)) |
412 | (define (label->idx label) (- label min-label)) | |
413 | (define (idx->var idx) (+ idx min-var)) | |
414 | (define (var->idx var) (- var min-var)) | |
d03c3c77 AW |
415 | (define (true-idx idx) idx) |
416 | (define (false-idx idx) (+ idx (vector-length equiv-labels))) | |
7a08e479 AW |
417 | |
418 | (define (subst-var var) | |
419 | ;; It could be that the var is free in this function; if so, | |
420 | ;; its name will be less than min-var. | |
421 | (let ((idx (var->idx var))) | |
422 | (if (<= 0 idx) | |
423 | (vector-ref var-substs idx) | |
424 | var))) | |
425 | ||
8320f504 | 426 | (define (visit-fun-cont cont) |
7a08e479 AW |
427 | (rewrite-cps-cont cont |
428 | (($ $cont label ($ $kargs names vars body)) | |
429 | (label ($kargs names vars ,(visit-term body label)))) | |
8320f504 AW |
430 | (($ $cont label ($ $kfun src meta self tail clause)) |
431 | (label ($kfun src meta self ,tail | |
432 | ,(and clause (visit-fun-cont clause))))) | |
7a08e479 AW |
433 | (($ $cont label ($ $kclause arity ($ $cont kbody body) alternate)) |
434 | (label ($kclause ,arity ,(visit-cont kbody body) | |
8320f504 | 435 | ,(and alternate (visit-fun-cont alternate))))))) |
7a08e479 AW |
436 | |
437 | (define (visit-cont label cont) | |
438 | (rewrite-cps-cont cont | |
439 | (($ $kargs names vars body) | |
440 | (label ($kargs names vars ,(visit-term body label)))) | |
441 | (_ (label ,cont)))) | |
442 | ||
443 | (define (visit-term term label) | |
444 | (define (visit-exp exp) | |
445 | ;; We shouldn't see $fun here. | |
446 | (rewrite-cps-exp exp | |
447 | ((or ($ $void) ($ $const) ($ $prim)) ,exp) | |
448 | (($ $call proc args) | |
449 | ($call (subst-var proc) ,(map subst-var args))) | |
450 | (($ $callk k proc args) | |
451 | ($callk k (subst-var proc) ,(map subst-var args))) | |
452 | (($ $primcall name args) | |
453 | ($primcall name ,(map subst-var args))) | |
454 | (($ $values args) | |
455 | ($values ,(map subst-var args))) | |
456 | (($ $prompt escape? tag handler) | |
457 | ($prompt escape? (subst-var tag) handler)))) | |
458 | ||
d03c3c77 | 459 | (define (visit-exp* k src exp) |
7a08e479 | 460 | (match exp |
a0329d01 AW |
461 | (($ $fun free body) |
462 | (build-cps-term | |
463 | ($continue k src | |
464 | ($fun (map subst-var free) ,(cse body dfg))))) | |
7a08e479 | 465 | (_ |
d03c3c77 AW |
466 | (cond |
467 | ((vector-ref equiv-labels (label->idx label)) | |
468 | => (lambda (equiv) | |
469 | (let* ((eidx (label->idx equiv)) | |
470 | (vars (vector-ref defs eidx))) | |
471 | (rewrite-cps-term (lookup-cont k dfg) | |
472 | (($ $kif kt kf) | |
473 | ,(let* ((bool (vector-ref boolv (label->idx label))) | |
474 | (t (bitvector-ref bool (true-idx eidx))) | |
475 | (f (bitvector-ref bool (false-idx eidx)))) | |
476 | (if (eqv? t f) | |
477 | (build-cps-term | |
478 | ($continue k src ,(visit-exp exp))) | |
479 | (build-cps-term | |
480 | ($continue (if t kt kf) src ($values ())))))) | |
481 | (($ $kargs) | |
482 | ($continue k src ($values vars))) | |
483 | ;; There is no point in adding a case for $ktail, as | |
484 | ;; only $values, $call, or $callk can continue to | |
485 | ;; $ktail. | |
486 | (_ | |
487 | ($continue k src ,(visit-exp exp))))))) | |
488 | (else | |
489 | (build-cps-term | |
490 | ($continue k src ,(visit-exp exp)))))))) | |
7a08e479 AW |
491 | |
492 | (define (visit-dom-conts label) | |
493 | (let ((cont (lookup-cont label dfg))) | |
494 | (match cont | |
495 | (($ $ktail) '()) | |
496 | (($ $kargs) (list (visit-cont label cont))) | |
497 | (else | |
498 | (cons (visit-cont label cont) | |
499 | (append-map visit-dom-conts | |
500 | (vector-ref doms (label->idx label)))))))) | |
501 | ||
502 | (rewrite-cps-term term | |
503 | (($ $letk conts body) | |
504 | ,(visit-term body label)) | |
505 | (($ $letrec names syms funs body) | |
a0329d01 AW |
506 | ($letrec names syms |
507 | (map (lambda (fun) | |
508 | (rewrite-cps-exp fun | |
509 | (($ $fun free body) | |
510 | ($fun (map subst-var free) ,(cse body dfg))))) | |
511 | funs) | |
512 | ,(visit-term body label))) | |
7a08e479 | 513 | (($ $continue k src exp) |
d03c3c77 AW |
514 | ,(let ((conts (append-map visit-dom-conts |
515 | (vector-ref doms (label->idx label))))) | |
7a08e479 | 516 | (if (null? conts) |
d03c3c77 AW |
517 | (visit-exp* k src exp) |
518 | (build-cps-term | |
519 | ($letk ,conts ,(visit-exp* k src exp)))))))) | |
7a08e479 | 520 | |
a0329d01 | 521 | (visit-fun-cont fun)) |
7a08e479 | 522 | |
7a08e479 AW |
523 | (define (cse fun dfg) |
524 | (call-with-values (lambda () (compute-equivalent-subexpressions fun dfg)) | |
d03c3c77 AW |
525 | (lambda (doms equiv-labels defs min-label var-substs min-var) |
526 | (apply-cse fun dfg doms equiv-labels defs min-label var-substs min-var | |
527 | (compute-truthy-expressions dfg | |
528 | min-label (vector-length doms)))))) | |
7a08e479 AW |
529 | |
530 | (define (eliminate-common-subexpressions fun) | |
531 | (call-with-values (lambda () (renumber fun)) | |
532 | (lambda (fun nlabels nvars) | |
a0329d01 | 533 | (cse fun (compute-dfg fun))))) |