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