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) | |
6fe36f22 AW |
32 | #:use-module (language cps intset) |
33 | #:use-module (rnrs bytevectors) | |
7a08e479 AW |
34 | #:export (eliminate-common-subexpressions)) |
35 | ||
6fe36f22 AW |
36 | (define (cont-successors cont) |
37 | (match cont | |
38 | (($ $kargs names syms body) | |
39 | (let lp ((body body)) | |
40 | (match body | |
41 | (($ $letk conts body) (lp body)) | |
42 | (($ $letrec names vars funs body) (lp body)) | |
43 | (($ $continue k src exp) | |
44 | (match exp | |
45 | (($ $prompt escape? tag handler) (list k handler)) | |
46 | (($ $branch kt) (list k kt)) | |
47 | (_ (list k))))))) | |
48 | ||
49 | (($ $kreceive arity k) (list k)) | |
50 | ||
51 | (($ $kclause arity ($ $cont kbody)) (list kbody)) | |
52 | ||
53 | (($ $kfun src meta self tail clause) | |
54 | (let lp ((clause clause)) | |
55 | (match clause | |
56 | (($ $cont kclause ($ $kclause _ _ alt)) | |
57 | (cons kclause (lp alt))) | |
58 | (#f '())))) | |
59 | ||
60 | (($ $kfun src meta self tail #f) '()) | |
61 | ||
62 | (($ $ktail) '()))) | |
63 | ||
64 | (define (compute-available-expressions dfg min-label label-count idoms) | |
7a08e479 | 65 | "Compute and return the continuations that may be reached if flow |
072b5a27 | 66 | reaches a continuation N. Returns a vector of intsets, whose first |
7a08e479 AW |
67 | index corresponds to MIN-LABEL, and so on." |
68 | (let* ((effects (compute-effects dfg min-label label-count)) | |
6fe36f22 AW |
69 | ;; Vector of intsets, indicating that at a continuation N, the |
70 | ;; values from continuations M... are available. | |
71 | (avail (make-vector label-count #f)) | |
72 | (revisit-label #f)) | |
7a08e479 AW |
73 | |
74 | (define (label->idx label) (- label min-label)) | |
75 | (define (idx->label idx) (+ idx min-label)) | |
6fe36f22 | 76 | (define (get-effects label) (vector-ref effects (label->idx label))) |
7a08e479 | 77 | |
6fe36f22 AW |
78 | (define (propagate! pred succ out) |
79 | (let* ((succ-idx (label->idx succ)) | |
80 | (in (match (lookup-predecessors succ dfg) | |
81 | ;; Fast path: normal control flow. | |
82 | ((_) out) | |
83 | ;; Slow path: control-flow join. | |
84 | (_ (cond | |
85 | ((vector-ref avail succ-idx) | |
86 | => (lambda (in) | |
87 | (intset-intersect in out))) | |
88 | (else out)))))) | |
89 | (when (and (<= succ pred) | |
90 | (or (not revisit-label) (< succ revisit-label)) | |
91 | (not (eq? in (vector-ref avail succ-idx)))) | |
92 | ;; Arrange to revisit if this is not a forward edge and the | |
93 | ;; available set changed. | |
94 | (set! revisit-label succ)) | |
95 | (vector-set! avail succ-idx in))) | |
6119a905 | 96 | |
6fe36f22 AW |
97 | (define (clobber label in) |
98 | (let ((fx (get-effects label))) | |
7a08e479 | 99 | (cond |
6fe36f22 AW |
100 | ((not (causes-effect? fx &write)) |
101 | ;; Fast-path if this expression clobbers nothing. | |
102 | in) | |
7a08e479 | 103 | (else |
6fe36f22 AW |
104 | ;; Kill clobbered expressions. |
105 | (let ((first (let lp ((dom label)) | |
106 | (let* ((dom (vector-ref idoms (label->idx dom)))) | |
107 | (and (< min-label dom) | |
108 | (let ((fx (vector-ref effects (label->idx dom)))) | |
109 | (if (causes-all-effects? fx) | |
110 | dom | |
111 | (lp dom)))))))) | |
112 | (let lp ((i first) (in in)) | |
113 | (cond | |
114 | ((intset-next in i) | |
115 | => (lambda (i) | |
116 | (if (effect-clobbers? fx (vector-ref effects (label->idx i))) | |
117 | (lp (1+ i) (intset-remove in i)) | |
118 | (lp (1+ i) in)))) | |
119 | (else in)))))))) | |
120 | ||
121 | (synthesize-definition-effects! effects dfg min-label label-count) | |
122 | ||
123 | (vector-set! avail 0 empty-intset) | |
124 | ||
125 | (let lp ((n 0)) | |
126 | (cond | |
127 | ((< n label-count) | |
128 | (let* ((label (idx->label n)) | |
129 | ;; It's possible for "in" to be #f if it has no | |
130 | ;; predecessors, as is the case for the ktail of a | |
131 | ;; function with an iloop. | |
132 | (in (or (vector-ref avail n) empty-intset)) | |
133 | (out (intset-add (clobber label in) label))) | |
134 | (lookup-predecessors label dfg) | |
135 | (let visit-succs ((succs (cont-successors (lookup-cont label dfg)))) | |
136 | (match succs | |
137 | (() (lp (1+ n))) | |
138 | ((succ . succs) | |
139 | (propagate! label succ out) | |
140 | (visit-succs succs)))))) | |
141 | (revisit-label | |
142 | (let ((n (label->idx revisit-label))) | |
143 | (set! revisit-label #f) | |
144 | (lp n))) | |
145 | (else | |
146 | (values avail effects)))))) | |
7a08e479 | 147 | |
d03c3c77 AW |
148 | (define (compute-truthy-expressions dfg min-label label-count) |
149 | "Compute a \"truth map\", indicating which expressions can be shown to | |
150 | be true and/or false at each of LABEL-COUNT expressions in DFG, starting | |
072b5a27 AW |
151 | from MIN-LABEL. Returns a vector of intsets, each intset twice as long |
152 | as LABEL-COUNT. The even elements of the intset indicate labels that | |
153 | may be true, and the odd ones indicate those that may be false. It | |
154 | could be that both true and false proofs are available." | |
155 | (let ((boolv (make-vector label-count #f)) | |
156 | (revisit-label #f)) | |
d03c3c77 AW |
157 | (define (label->idx label) (- label min-label)) |
158 | (define (idx->label idx) (+ idx min-label)) | |
072b5a27 AW |
159 | (define (true-idx idx) (ash idx 1)) |
160 | (define (false-idx idx) (1+ (ash idx 1))) | |
161 | ||
162 | (define (propagate! pred succ out) | |
163 | (let* ((succ-idx (label->idx succ)) | |
164 | (in (match (lookup-predecessors succ dfg) | |
165 | ;; Fast path: normal control flow. | |
166 | ((_) out) | |
167 | ;; Slow path: control-flow join. | |
168 | (_ (cond | |
169 | ((vector-ref boolv succ-idx) | |
170 | => (lambda (in) | |
171 | (intset-intersect in out))) | |
172 | (else out)))))) | |
173 | (when (and (<= succ pred) | |
174 | (or (not revisit-label) (< succ revisit-label)) | |
175 | (not (eq? in (vector-ref boolv succ-idx)))) | |
176 | (set! revisit-label succ)) | |
177 | (vector-set! boolv succ-idx in))) | |
178 | ||
179 | (vector-set! boolv 0 empty-intset) | |
d03c3c77 AW |
180 | |
181 | (let lp ((n 0)) | |
072b5a27 AW |
182 | (cond |
183 | ((< n label-count) | |
184 | (let* ((label (idx->label n)) | |
185 | ;; It's possible for "in" to be #f if it has no | |
186 | ;; predecessors, as is the case for the ktail of a | |
187 | ;; function with an iloop. | |
188 | (in (or (vector-ref boolv n) empty-intset))) | |
189 | (define (default-propagate) | |
190 | (let visit-succs ((succs (cont-successors (lookup-cont label dfg)))) | |
191 | (match succs | |
192 | (() (lp (1+ n))) | |
193 | ((succ . succs) | |
194 | (propagate! label succ in) | |
195 | (visit-succs succs))))) | |
196 | (match (lookup-cont label dfg) | |
197 | (($ $kargs names syms body) | |
198 | (match (find-call body) | |
199 | (($ $continue k src ($ $branch kt)) | |
200 | (propagate! label k (intset-add in (false-idx n))) | |
201 | (propagate! label kt (intset-add in (true-idx n))) | |
202 | (lp (1+ n))) | |
203 | (_ (default-propagate)))) | |
204 | (_ (default-propagate))))) | |
205 | (revisit-label | |
206 | (let ((n (label->idx revisit-label))) | |
207 | (set! revisit-label #f) | |
208 | (lp n))) | |
209 | (else boolv))))) | |
d03c3c77 | 210 | |
6119a905 AW |
211 | ;; Returns a map of label-idx -> (var-idx ...) indicating the variables |
212 | ;; defined by a given labelled expression. | |
7a08e479 AW |
213 | (define (compute-defs dfg min-label label-count) |
214 | (define (cont-defs k) | |
215 | (match (lookup-cont k dfg) | |
216 | (($ $kargs names vars) vars) | |
217 | (_ '()))) | |
218 | (define (idx->label idx) (+ idx min-label)) | |
219 | (let ((defs (make-vector label-count '()))) | |
220 | (let lp ((n 0)) | |
221 | (when (< n label-count) | |
222 | (vector-set! | |
223 | defs | |
224 | n | |
225 | (match (lookup-cont (idx->label n) dfg) | |
226 | (($ $kargs _ _ body) | |
227 | (match (find-call body) | |
228 | (($ $continue k) (cont-defs k)))) | |
229 | (($ $kreceive arity kargs) | |
230 | (cont-defs kargs)) | |
231 | (($ $kclause arity ($ $cont kargs ($ $kargs names syms))) | |
232 | syms) | |
8320f504 | 233 | (($ $kfun src meta self) (list self)) |
7a08e479 AW |
234 | (($ $ktail) '()))) |
235 | (lp (1+ n)))) | |
236 | defs)) | |
237 | ||
238 | (define (compute-label-and-var-ranges fun) | |
239 | (match fun | |
a0329d01 | 240 | (($ $cont kfun ($ $kfun src meta self)) |
405805fb | 241 | ((make-local-cont-folder min-label label-count min-var var-count) |
7a08e479 AW |
242 | (lambda (k cont min-label label-count min-var var-count) |
243 | (let ((min-label (min k min-label)) | |
244 | (label-count (1+ label-count))) | |
245 | (match cont | |
246 | (($ $kargs names vars body) | |
247 | (let lp ((body body) | |
248 | (min-var (fold min min-var vars)) | |
249 | (var-count (+ var-count (length vars)))) | |
250 | (match body | |
251 | (($ $letrec names vars funs body) | |
252 | (lp body | |
253 | (fold min min-var vars) | |
254 | (+ var-count (length vars)))) | |
255 | (($ $letk conts body) (lp body min-var var-count)) | |
256 | (_ (values min-label label-count min-var var-count))))) | |
8320f504 | 257 | (($ $kfun src meta self) |
7a08e479 AW |
258 | (values min-label label-count (min self min-var) (1+ var-count))) |
259 | (_ | |
260 | (values min-label label-count min-var var-count))))) | |
a0329d01 | 261 | fun kfun 0 self 0)))) |
7a08e479 | 262 | |
7a08e479 AW |
263 | ;; Compute a vector containing, for each node, a list of the nodes that |
264 | ;; it immediately dominates. These are the "D" edges in the DJ tree. | |
7a08e479 AW |
265 | |
266 | (define (compute-equivalent-subexpressions fun dfg) | |
6fe36f22 AW |
267 | (define (compute min-label label-count min-var var-count idoms avail effects) |
268 | (let ((defs (compute-defs dfg min-label label-count)) | |
8c6a0b7e | 269 | (var-substs (make-vector var-count #f)) |
d03c3c77 | 270 | (equiv-labels (make-vector label-count #f)) |
8c6a0b7e AW |
271 | (equiv-set (make-hash-table))) |
272 | (define (idx->label idx) (+ idx min-label)) | |
273 | (define (label->idx label) (- label min-label)) | |
274 | (define (idx->var idx) (+ idx min-var)) | |
275 | (define (var->idx var) (- var min-var)) | |
276 | ||
df1bdc1e AW |
277 | (define (for-each/2 f l1 l2) |
278 | (unless (= (length l1) (length l2)) | |
279 | (error "bad lengths" l1 l2)) | |
280 | (let lp ((l1 l1) (l2 l2)) | |
281 | (when (pair? l1) | |
282 | (f (car l1) (car l2)) | |
283 | (lp (cdr l1) (cdr l2))))) | |
284 | ||
8c6a0b7e AW |
285 | (define (subst-var var) |
286 | ;; It could be that the var is free in this function; if so, its | |
287 | ;; name will be less than min-var. | |
288 | (let ((idx (var->idx var))) | |
289 | (if (<= 0 idx) | |
290 | (vector-ref var-substs idx) | |
291 | var))) | |
292 | ||
293 | (define (compute-exp-key exp) | |
294 | (match exp | |
295 | (($ $void) 'void) | |
296 | (($ $const val) (cons 'const val)) | |
297 | (($ $prim name) (cons 'prim name)) | |
24b611e8 | 298 | (($ $fun free body) #f) |
8c6a0b7e AW |
299 | (($ $call proc args) #f) |
300 | (($ $callk k proc args) #f) | |
301 | (($ $primcall name args) | |
302 | (cons* 'primcall name (map subst-var args))) | |
92805e21 AW |
303 | (($ $branch _ ($ $primcall name args)) |
304 | (cons* 'primcall name (map subst-var args))) | |
305 | (($ $branch) #f) | |
8c6a0b7e AW |
306 | (($ $values args) #f) |
307 | (($ $prompt escape? tag handler) #f))) | |
308 | ||
6119a905 AW |
309 | (define (add-auxiliary-definitions! label exp-key) |
310 | (let ((defs (vector-ref defs (label->idx label)))) | |
311 | (define (add-def! aux-key var) | |
312 | (let ((equiv (hash-ref equiv-set aux-key '()))) | |
313 | (hash-set! equiv-set aux-key | |
314 | (acons label (list var) equiv)))) | |
315 | (match exp-key | |
41812daa AW |
316 | (('primcall 'box val) |
317 | (match defs | |
318 | ((box) | |
c8d87b47 | 319 | (add-def! `(primcall box-ref ,(subst-var box)) val)))) |
41812daa AW |
320 | (('primcall 'box-set! box val) |
321 | (add-def! `(primcall box-ref ,box) val)) | |
6119a905 AW |
322 | (('primcall 'cons car cdr) |
323 | (match defs | |
324 | ((pair) | |
c8d87b47 AW |
325 | (add-def! `(primcall car ,(subst-var pair)) car) |
326 | (add-def! `(primcall cdr ,(subst-var pair)) cdr)))) | |
6119a905 AW |
327 | (('primcall 'set-car! pair car) |
328 | (add-def! `(primcall car ,pair) car)) | |
329 | (('primcall 'set-cdr! pair cdr) | |
330 | (add-def! `(primcall cdr ,pair) cdr)) | |
331 | (('primcall (or 'make-vector 'make-vector/immediate) len fill) | |
332 | (match defs | |
333 | ((vec) | |
c8d87b47 | 334 | (add-def! `(primcall vector-length ,(subst-var vec)) len)))) |
6119a905 AW |
335 | (('primcall 'vector-set! vec idx val) |
336 | (add-def! `(primcall vector-ref ,vec ,idx) val)) | |
337 | (('primcall 'vector-set!/immediate vec idx val) | |
338 | (add-def! `(primcall vector-ref/immediate ,vec ,idx) val)) | |
339 | (('primcall (or 'allocate-struct 'allocate-struct/immediate) | |
340 | vtable size) | |
341 | (match defs | |
342 | ((struct) | |
c8d87b47 AW |
343 | (add-def! `(primcall struct-vtable ,(subst-var struct)) |
344 | vtable)))) | |
6119a905 AW |
345 | (('primcall 'struct-set! struct n val) |
346 | (add-def! `(primcall struct-ref ,struct ,n) val)) | |
347 | (('primcall 'struct-set!/immediate struct n val) | |
348 | (add-def! `(primcall struct-ref/immediate ,struct ,n) val)) | |
349 | (_ #t)))) | |
350 | ||
8c6a0b7e AW |
351 | ;; The initial substs vector is the identity map. |
352 | (let lp ((var min-var)) | |
353 | (when (< (var->idx var) var-count) | |
354 | (vector-set! var-substs (var->idx var) var) | |
355 | (lp (1+ var)))) | |
356 | ||
357 | ;; Traverse the labels in fun in forward order, which will visit | |
358 | ;; dominators first. | |
359 | (let lp ((label min-label)) | |
360 | (when (< (label->idx label) label-count) | |
361 | (match (lookup-cont label dfg) | |
362 | (($ $kargs names vars body) | |
363 | (match (find-call body) | |
364 | (($ $continue k src exp) | |
365 | (let* ((exp-key (compute-exp-key exp)) | |
366 | (equiv (hash-ref equiv-set exp-key '())) | |
6119a905 | 367 | (lidx (label->idx label)) |
5d25fdae | 368 | (fx (vector-ref effects lidx)) |
6119a905 | 369 | (avail (vector-ref avail lidx))) |
8c6a0b7e AW |
370 | (let lp ((candidates equiv)) |
371 | (match candidates | |
372 | (() | |
373 | ;; No matching expressions. Add our expression | |
6119a905 AW |
374 | ;; to the equivalence set, if appropriate. Note |
375 | ;; that expressions that allocate a fresh object | |
376 | ;; or change the current fluid environment can't | |
377 | ;; be eliminated by CSE (though DCE might do it | |
378 | ;; if the value proves to be unused, in the | |
379 | ;; allocation case). | |
380 | (when (and exp-key | |
5d25fdae AW |
381 | (not (causes-effect? fx &allocation)) |
382 | (not (effect-clobbers? | |
383 | fx | |
384 | (&read-object &fluid)))) | |
6119a905 AW |
385 | (hash-set! equiv-set exp-key |
386 | (acons label (vector-ref defs lidx) | |
387 | equiv)))) | |
388 | (((and head (candidate . vars)) . candidates) | |
d03c3c77 | 389 | (cond |
6fe36f22 | 390 | ((not (intset-ref avail candidate)) |
d03c3c77 AW |
391 | ;; This expression isn't available here; try |
392 | ;; the next one. | |
393 | (lp candidates)) | |
394 | (else | |
395 | ;; Yay, a match. Mark expression as equivalent. | |
6119a905 | 396 | (vector-set! equiv-labels lidx head) |
d03c3c77 AW |
397 | ;; If we dominate the successor, mark vars |
398 | ;; for substitution. | |
399 | (when (= label (vector-ref idoms (label->idx k))) | |
400 | (for-each/2 | |
401 | (lambda (var subst-var) | |
402 | (vector-set! var-substs (var->idx var) subst-var)) | |
6119a905 | 403 | (vector-ref defs lidx) |
c8d87b47 AW |
404 | vars))))))) |
405 | ;; If this expression defines auxiliary definitions, | |
406 | ;; as `cons' does for the results of `car' and `cdr', | |
407 | ;; define those. Do so after finding equivalent | |
408 | ;; expressions, so that we can take advantage of | |
409 | ;; subst'd output vars. | |
410 | (add-auxiliary-definitions! label exp-key))))) | |
8c6a0b7e AW |
411 | (_ #f)) |
412 | (lp (1+ label)))) | |
413 | (values (compute-dom-edges idoms min-label) | |
6119a905 | 414 | equiv-labels min-label var-substs min-var))) |
8c6a0b7e | 415 | |
6119a905 AW |
416 | (call-with-values (lambda () (compute-label-and-var-ranges fun)) |
417 | (lambda (min-label label-count min-var var-count) | |
6fe36f22 AW |
418 | (let ((idoms (compute-idoms dfg min-label label-count))) |
419 | (call-with-values | |
420 | (lambda () | |
421 | (compute-available-expressions dfg min-label label-count idoms)) | |
422 | (lambda (avail effects) | |
423 | (compute min-label label-count min-var var-count | |
424 | idoms avail effects))))))) | |
8c6a0b7e | 425 | |
d03c3c77 | 426 | (define (apply-cse fun dfg |
6119a905 | 427 | doms equiv-labels min-label var-substs min-var boolv) |
7a08e479 AW |
428 | (define (idx->label idx) (+ idx min-label)) |
429 | (define (label->idx label) (- label min-label)) | |
430 | (define (idx->var idx) (+ idx min-var)) | |
431 | (define (var->idx var) (- var min-var)) | |
072b5a27 AW |
432 | (define (true-idx idx) (ash idx 1)) |
433 | (define (false-idx idx) (1+ (ash idx 1))) | |
7a08e479 AW |
434 | |
435 | (define (subst-var var) | |
436 | ;; It could be that the var is free in this function; if so, | |
437 | ;; its name will be less than min-var. | |
438 | (let ((idx (var->idx var))) | |
439 | (if (<= 0 idx) | |
440 | (vector-ref var-substs idx) | |
441 | var))) | |
442 | ||
8320f504 | 443 | (define (visit-fun-cont cont) |
7a08e479 AW |
444 | (rewrite-cps-cont cont |
445 | (($ $cont label ($ $kargs names vars body)) | |
446 | (label ($kargs names vars ,(visit-term body label)))) | |
8320f504 AW |
447 | (($ $cont label ($ $kfun src meta self tail clause)) |
448 | (label ($kfun src meta self ,tail | |
449 | ,(and clause (visit-fun-cont clause))))) | |
7a08e479 AW |
450 | (($ $cont label ($ $kclause arity ($ $cont kbody body) alternate)) |
451 | (label ($kclause ,arity ,(visit-cont kbody body) | |
8320f504 | 452 | ,(and alternate (visit-fun-cont alternate))))))) |
7a08e479 AW |
453 | |
454 | (define (visit-cont label cont) | |
455 | (rewrite-cps-cont cont | |
456 | (($ $kargs names vars body) | |
457 | (label ($kargs names vars ,(visit-term body label)))) | |
458 | (_ (label ,cont)))) | |
459 | ||
460 | (define (visit-term term label) | |
461 | (define (visit-exp exp) | |
462 | ;; We shouldn't see $fun here. | |
463 | (rewrite-cps-exp exp | |
464 | ((or ($ $void) ($ $const) ($ $prim)) ,exp) | |
465 | (($ $call proc args) | |
466 | ($call (subst-var proc) ,(map subst-var args))) | |
467 | (($ $callk k proc args) | |
468 | ($callk k (subst-var proc) ,(map subst-var args))) | |
469 | (($ $primcall name args) | |
470 | ($primcall name ,(map subst-var args))) | |
92805e21 AW |
471 | (($ $branch k exp) |
472 | ($branch k ,(visit-exp exp))) | |
7a08e479 AW |
473 | (($ $values args) |
474 | ($values ,(map subst-var args))) | |
475 | (($ $prompt escape? tag handler) | |
476 | ($prompt escape? (subst-var tag) handler)))) | |
477 | ||
d03c3c77 | 478 | (define (visit-exp* k src exp) |
7a08e479 | 479 | (match exp |
a0329d01 AW |
480 | (($ $fun free body) |
481 | (build-cps-term | |
482 | ($continue k src | |
483 | ($fun (map subst-var free) ,(cse body dfg))))) | |
7a08e479 | 484 | (_ |
d03c3c77 AW |
485 | (cond |
486 | ((vector-ref equiv-labels (label->idx label)) | |
6119a905 AW |
487 | => (match-lambda |
488 | ((equiv . vars) | |
489 | (let* ((eidx (label->idx equiv))) | |
92805e21 AW |
490 | (match exp |
491 | (($ $branch kt exp) | |
492 | (let* ((bool (vector-ref boolv (label->idx label))) | |
072b5a27 AW |
493 | (t (intset-ref bool (true-idx eidx))) |
494 | (f (intset-ref bool (false-idx eidx)))) | |
92805e21 AW |
495 | (if (eqv? t f) |
496 | (build-cps-term | |
497 | ($continue k src | |
498 | ($branch kt ,(visit-exp exp)))) | |
499 | (build-cps-term | |
500 | ($continue (if t kt k) src ($values ())))))) | |
d03c3c77 | 501 | (_ |
59258f7c AW |
502 | ;; FIXME: can we always continue with $values? why |
503 | ;; or why not? | |
92805e21 | 504 | (rewrite-cps-term (lookup-cont k dfg) |
92805e21 AW |
505 | (($ $kargs) |
506 | ($continue k src ($values vars))) | |
507 | (_ | |
508 | ($continue k src ,(visit-exp exp)))))))))) | |
d03c3c77 AW |
509 | (else |
510 | (build-cps-term | |
511 | ($continue k src ,(visit-exp exp)))))))) | |
7a08e479 AW |
512 | |
513 | (define (visit-dom-conts label) | |
514 | (let ((cont (lookup-cont label dfg))) | |
515 | (match cont | |
516 | (($ $ktail) '()) | |
517 | (($ $kargs) (list (visit-cont label cont))) | |
518 | (else | |
519 | (cons (visit-cont label cont) | |
520 | (append-map visit-dom-conts | |
521 | (vector-ref doms (label->idx label)))))))) | |
522 | ||
523 | (rewrite-cps-term term | |
524 | (($ $letk conts body) | |
525 | ,(visit-term body label)) | |
526 | (($ $letrec names syms funs body) | |
a0329d01 AW |
527 | ($letrec names syms |
528 | (map (lambda (fun) | |
529 | (rewrite-cps-exp fun | |
530 | (($ $fun free body) | |
531 | ($fun (map subst-var free) ,(cse body dfg))))) | |
532 | funs) | |
533 | ,(visit-term body label))) | |
7a08e479 | 534 | (($ $continue k src exp) |
d03c3c77 AW |
535 | ,(let ((conts (append-map visit-dom-conts |
536 | (vector-ref doms (label->idx label))))) | |
7a08e479 | 537 | (if (null? conts) |
d03c3c77 AW |
538 | (visit-exp* k src exp) |
539 | (build-cps-term | |
540 | ($letk ,conts ,(visit-exp* k src exp)))))))) | |
7a08e479 | 541 | |
a0329d01 | 542 | (visit-fun-cont fun)) |
7a08e479 | 543 | |
7a08e479 AW |
544 | (define (cse fun dfg) |
545 | (call-with-values (lambda () (compute-equivalent-subexpressions fun dfg)) | |
6119a905 AW |
546 | (lambda (doms equiv-labels min-label var-substs min-var) |
547 | (apply-cse fun dfg doms equiv-labels min-label var-substs min-var | |
d03c3c77 AW |
548 | (compute-truthy-expressions dfg |
549 | min-label (vector-length doms)))))) | |
7a08e479 AW |
550 | |
551 | (define (eliminate-common-subexpressions fun) | |
552 | (call-with-values (lambda () (renumber fun)) | |
553 | (lambda (fun nlabels nvars) | |
a0329d01 | 554 | (cse fun (compute-dfg fun))))) |