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)) | |
8c6a0b7e AW |
56 | (avail-out (make-vector label-count #f)) |
57 | (bailouts (make-bitvector label-count #f))) | |
7a08e479 AW |
58 | |
59 | (define (label->idx label) (- label min-label)) | |
60 | (define (idx->label idx) (+ idx min-label)) | |
61 | ||
62 | (define (for-each f l) | |
63 | (let lp ((l l)) | |
64 | (when (pair? l) | |
65 | (f (car l)) | |
66 | (lp (cdr l))))) | |
67 | ||
68 | (let lp ((n 0)) | |
69 | (when (< n label-count) | |
70 | (let ((in (make-bitvector label-count #f)) | |
71 | (out (make-bitvector label-count #f))) | |
72 | (vector-set! avail-in n in) | |
73 | (vector-set! avail-out n out) | |
8c6a0b7e AW |
74 | #; |
75 | (bitvector-set! bailouts n | |
76 | (causes-effects? (vector-ref effects n) &bailout)) | |
7a08e479 AW |
77 | (lp (1+ n))))) |
78 | ||
79 | (let ((tmp (make-bitvector label-count #f))) | |
80 | (define (bitvector-copy! dst src) | |
81 | (bitvector-fill! dst #f) | |
82 | (bit-set*! dst src #t)) | |
83 | (define (intersect! dst src) | |
84 | (bitvector-copy! tmp src) | |
85 | (bit-invert! tmp) | |
86 | (bit-set*! dst tmp #f)) | |
87 | (let lp ((n 0) (first? #t) (changed? #f)) | |
88 | (cond | |
89 | ((< n label-count) | |
90 | (let* ((in (vector-ref avail-in n)) | |
91 | (prev-count (bit-count #t in)) | |
92 | (out (vector-ref avail-out n)) | |
93 | (fx (vector-ref effects n))) | |
94 | ;; Intersect avail-out from predecessors into "in". | |
780ad383 AW |
95 | (let lp ((preds (lookup-predecessors (idx->label n) dfg)) |
96 | (initialized? #f)) | |
97 | (match preds | |
98 | (() #t) | |
99 | ((pred . preds) | |
100 | (let ((pred (label->idx pred))) | |
101 | (cond | |
102 | ((or (and first? (<= n pred)) | |
103 | ;; Here it would be nice to avoid intersecting | |
104 | ;; with predecessors that bail out, which might | |
105 | ;; allow expressions from the other (if there's | |
106 | ;; only one) predecessor to propagate past the | |
107 | ;; join. However that would require the tree | |
108 | ;; to be rewritten so that the successor is | |
109 | ;; correctly scoped, and gets the right | |
110 | ;; dominator. Punt for now. | |
111 | ||
112 | ;; (bitvector-ref bailouts pred) | |
113 | ) | |
114 | ;; Avoid intersecting back-edges and cross-edges on | |
115 | ;; the first iteration. | |
116 | (lp preds initialized?)) | |
117 | (else | |
118 | (if initialized? | |
119 | (intersect! in (vector-ref avail-out pred)) | |
120 | (bitvector-copy! in (vector-ref avail-out pred))) | |
121 | (lp preds #t))))))) | |
7a08e479 AW |
122 | (let ((new-count (bit-count #t in))) |
123 | (unless (= prev-count new-count) | |
124 | ;; Copy "in" to "out". | |
125 | (bitvector-copy! out in) | |
126 | ;; Kill expressions that don't commute. | |
127 | (cond | |
780ad383 | 128 | ((causes-all-effects? fx &unknown-effects) |
7a08e479 AW |
129 | ;; Fast-path if this expression clobbers the world. |
130 | (intersect! out always-avail)) | |
131 | ((effect-free? (exclude-effects fx &type-check)) | |
132 | ;; Fast-path if this expression clobbers nothing. | |
133 | #t) | |
134 | (else | |
135 | ;; Loop of sadness. | |
136 | (bitvector-copy! tmp out) | |
137 | (bit-set*! tmp always-avail #f) | |
138 | (let lp ((i 0)) | |
139 | (let ((i (bit-position #t tmp i))) | |
140 | (when i | |
141 | (unless (effects-commute? (vector-ref effects i) fx) | |
142 | (bitvector-set! out i #f)) | |
143 | (lp (1+ i)))))))) | |
144 | ;; Unless this expression allocates a fresh object or | |
145 | ;; changes the current fluid environment, mark expressions | |
146 | ;; that match it as available for elimination. | |
147 | (unless (causes-effects? fx (logior &fluid-environment | |
148 | &allocation)) | |
149 | (bitvector-set! out n #t)) | |
150 | (lp (1+ n) first? (or changed? (not (= prev-count new-count))))))) | |
151 | (else | |
780ad383 | 152 | (if (or first? changed?) |
7a08e479 | 153 | (lp 0 #f #f) |
8c6a0b7e | 154 | (values avail-in bailouts)))))))) |
7a08e479 AW |
155 | |
156 | (define (compute-defs dfg min-label label-count) | |
157 | (define (cont-defs k) | |
158 | (match (lookup-cont k dfg) | |
159 | (($ $kargs names vars) vars) | |
160 | (_ '()))) | |
161 | (define (idx->label idx) (+ idx min-label)) | |
162 | (let ((defs (make-vector label-count '()))) | |
163 | (let lp ((n 0)) | |
164 | (when (< n label-count) | |
165 | (vector-set! | |
166 | defs | |
167 | n | |
168 | (match (lookup-cont (idx->label n) dfg) | |
169 | (($ $kargs _ _ body) | |
170 | (match (find-call body) | |
171 | (($ $continue k) (cont-defs k)))) | |
172 | (($ $kreceive arity kargs) | |
173 | (cont-defs kargs)) | |
174 | (($ $kclause arity ($ $cont kargs ($ $kargs names syms))) | |
175 | syms) | |
176 | (($ $kif) '()) | |
177 | (($ $kentry self) (list self)) | |
178 | (($ $ktail) '()))) | |
179 | (lp (1+ n)))) | |
180 | defs)) | |
181 | ||
182 | (define (compute-label-and-var-ranges fun) | |
183 | (match fun | |
184 | (($ $fun src meta free ($ $cont kentry ($ $kentry self))) | |
185 | ((make-cont-folder #f min-label label-count min-var var-count) | |
186 | (lambda (k cont min-label label-count min-var var-count) | |
187 | (let ((min-label (min k min-label)) | |
188 | (label-count (1+ label-count))) | |
189 | (match cont | |
190 | (($ $kargs names vars body) | |
191 | (let lp ((body body) | |
192 | (min-var (fold min min-var vars)) | |
193 | (var-count (+ var-count (length vars)))) | |
194 | (match body | |
195 | (($ $letrec names vars funs body) | |
196 | (lp body | |
197 | (fold min min-var vars) | |
198 | (+ var-count (length vars)))) | |
199 | (($ $letk conts body) (lp body min-var var-count)) | |
200 | (_ (values min-label label-count min-var var-count))))) | |
201 | (($ $kentry self) | |
202 | (values min-label label-count (min self min-var) (1+ var-count))) | |
203 | (_ | |
204 | (values min-label label-count min-var var-count))))) | |
205 | fun kentry 0 self 0)))) | |
206 | ||
8c6a0b7e | 207 | (define (compute-idoms dfg bailouts min-label label-count) |
7a08e479 AW |
208 | (define (label->idx label) (- label min-label)) |
209 | (define (idx->label idx) (+ idx min-label)) | |
210 | (let ((idoms (make-vector label-count #f))) | |
211 | (define (common-idom d0 d1) | |
212 | ;; We exploit the fact that a reverse post-order is a topological | |
213 | ;; sort, and so the idom of a node is always numerically less than | |
214 | ;; the node itself. | |
215 | (cond | |
216 | ((= d0 d1) d0) | |
217 | ((< d0 d1) (common-idom d0 (vector-ref idoms (label->idx d1)))) | |
218 | (else (common-idom (vector-ref idoms (label->idx d0)) d1)))) | |
219 | (define (compute-idom preds) | |
8c6a0b7e AW |
220 | (define (has-idom? pred) |
221 | (and (vector-ref idoms (label->idx pred)) | |
222 | (not (bitvector-ref bailouts (label->idx pred))))) | |
7a08e479 AW |
223 | (match preds |
224 | (() min-label) | |
225 | ((pred . preds) | |
8c6a0b7e AW |
226 | (if (has-idom? pred) |
227 | (let lp ((idom pred) (preds preds)) | |
228 | (match preds | |
229 | (() idom) | |
230 | ((pred . preds) | |
231 | (lp (if (has-idom? pred) | |
232 | (common-idom idom pred) | |
233 | idom) | |
234 | preds)))) | |
235 | (compute-idom preds))))) | |
7a08e479 AW |
236 | ;; This is the iterative O(n^2) fixpoint algorithm, originally from |
237 | ;; Allen and Cocke ("Graph-theoretic constructs for program flow | |
238 | ;; analysis", 1972). See the discussion in Cooper, Harvey, and | |
239 | ;; Kennedy's "A Simple, Fast Dominance Algorithm", 2001. | |
240 | (let iterate ((n 0) (changed? #f)) | |
241 | (cond | |
242 | ((< n label-count) | |
243 | (let ((idom (vector-ref idoms n)) | |
8c6a0b7e | 244 | (idom* (compute-idom (lookup-predecessors (idx->label n) dfg)))) |
7a08e479 AW |
245 | (cond |
246 | ((eqv? idom idom*) | |
247 | (iterate (1+ n) changed?)) | |
248 | (else | |
249 | (vector-set! idoms n idom*) | |
250 | (iterate (1+ n) #t))))) | |
251 | (changed? | |
252 | (iterate 0 #f)) | |
253 | (else idoms))))) | |
254 | ||
255 | ;; Compute a vector containing, for each node, a list of the nodes that | |
256 | ;; it immediately dominates. These are the "D" edges in the DJ tree. | |
257 | (define (compute-dom-edges idoms min-label) | |
258 | (define (label->idx label) (- label min-label)) | |
259 | (define (idx->label idx) (+ idx min-label)) | |
260 | (define (vector-push! vec idx val) | |
261 | (let ((v vec) (i idx)) | |
262 | (vector-set! v i (cons val (vector-ref v i))))) | |
263 | (let ((doms (make-vector (vector-length idoms) '()))) | |
264 | (let lp ((n 0)) | |
265 | (when (< n (vector-length idoms)) | |
266 | (let ((idom (vector-ref idoms n))) | |
267 | (vector-push! doms (label->idx idom) (idx->label n))) | |
268 | (lp (1+ n)))) | |
269 | doms)) | |
270 | ||
271 | (define (compute-equivalent-subexpressions fun dfg) | |
8c6a0b7e AW |
272 | (define (compute min-label label-count min-var var-count avail bailouts) |
273 | (let ((idoms (compute-idoms dfg bailouts min-label label-count)) | |
274 | (defs (compute-defs dfg min-label label-count)) | |
275 | (var-substs (make-vector var-count #f)) | |
276 | (label-substs (make-vector label-count #f)) | |
277 | (equiv-set (make-hash-table))) | |
278 | (define (idx->label idx) (+ idx min-label)) | |
279 | (define (label->idx label) (- label min-label)) | |
280 | (define (idx->var idx) (+ idx min-var)) | |
281 | (define (var->idx var) (- var min-var)) | |
282 | ||
283 | (define (subst-var var) | |
284 | ;; It could be that the var is free in this function; if so, its | |
285 | ;; name will be less than min-var. | |
286 | (let ((idx (var->idx var))) | |
287 | (if (<= 0 idx) | |
288 | (vector-ref var-substs idx) | |
289 | var))) | |
290 | ||
291 | (define (compute-exp-key exp) | |
292 | (match exp | |
293 | (($ $void) 'void) | |
294 | (($ $const val) (cons 'const val)) | |
295 | (($ $prim name) (cons 'prim name)) | |
296 | (($ $fun src meta free body) #f) | |
297 | (($ $call proc args) #f) | |
298 | (($ $callk k proc args) #f) | |
299 | (($ $primcall name args) | |
300 | (cons* 'primcall name (map subst-var args))) | |
301 | (($ $values args) #f) | |
302 | (($ $prompt escape? tag handler) #f))) | |
303 | ||
304 | ;; The initial substs vector is the identity map. | |
305 | (let lp ((var min-var)) | |
306 | (when (< (var->idx var) var-count) | |
307 | (vector-set! var-substs (var->idx var) var) | |
308 | (lp (1+ var)))) | |
309 | ||
310 | ;; Traverse the labels in fun in forward order, which will visit | |
311 | ;; dominators first. | |
312 | (let lp ((label min-label)) | |
313 | (when (< (label->idx label) label-count) | |
314 | (match (lookup-cont label dfg) | |
315 | (($ $kargs names vars body) | |
316 | (match (find-call body) | |
317 | (($ $continue k src exp) | |
318 | (let* ((exp-key (compute-exp-key exp)) | |
319 | (equiv (hash-ref equiv-set exp-key '())) | |
320 | (avail (vector-ref avail (label->idx label)))) | |
321 | (let lp ((candidates equiv)) | |
322 | (match candidates | |
323 | (() | |
324 | ;; No matching expressions. Add our expression | |
325 | ;; to the equivalence set, if appropriate. | |
326 | (when exp-key | |
327 | (hash-set! equiv-set exp-key (cons label equiv)))) | |
328 | ((candidate . candidates) | |
329 | (let ((subst (vector-ref defs (label->idx candidate)))) | |
330 | (cond | |
331 | ((not (bitvector-ref avail (label->idx candidate))) | |
332 | ;; This expression isn't available here; try | |
333 | ;; the next one. | |
334 | (lp candidates)) | |
335 | (else | |
336 | ;; Yay, a match. Mark expression for | |
337 | ;; replacement with $values. | |
338 | (vector-set! label-substs (label->idx label) subst) | |
339 | ;; If we dominate the successor, mark vars | |
340 | ;; for substitution. | |
341 | (when (= label (vector-ref idoms (label->idx k))) | |
342 | (for-each | |
343 | (lambda (var subst-var) | |
344 | (vector-set! var-substs (var->idx var) subst-var)) | |
345 | (vector-ref defs (label->idx label)) | |
346 | subst)))))))))))) | |
347 | (_ #f)) | |
348 | (lp (1+ label)))) | |
349 | (values (compute-dom-edges idoms min-label) | |
350 | label-substs min-label var-substs min-var | |
351 | bailouts))) | |
352 | ||
7a08e479 AW |
353 | (call-with-values (lambda () (compute-label-and-var-ranges fun)) |
354 | (lambda (min-label label-count min-var var-count) | |
8c6a0b7e AW |
355 | (call-with-values |
356 | (lambda () | |
357 | (compute-available-expressions dfg min-label label-count)) | |
358 | (lambda (avail bailouts) | |
359 | (compute min-label label-count min-var var-count avail bailouts)))))) | |
360 | ||
361 | (define (apply-cse fun dfg doms label-substs min-label var-substs min-var | |
362 | bailouts) | |
7a08e479 AW |
363 | (define (idx->label idx) (+ idx min-label)) |
364 | (define (label->idx label) (- label min-label)) | |
365 | (define (idx->var idx) (+ idx min-var)) | |
366 | (define (var->idx var) (- var min-var)) | |
367 | ||
368 | (define (subst-var var) | |
369 | ;; It could be that the var is free in this function; if so, | |
370 | ;; its name will be less than min-var. | |
371 | (let ((idx (var->idx var))) | |
372 | (if (<= 0 idx) | |
373 | (vector-ref var-substs idx) | |
374 | var))) | |
375 | ||
376 | (define (visit-entry-cont cont) | |
377 | (rewrite-cps-cont cont | |
378 | (($ $cont label ($ $kargs names vars body)) | |
379 | (label ($kargs names vars ,(visit-term body label)))) | |
380 | (($ $cont label ($ $kentry self tail clause)) | |
381 | (label ($kentry self ,tail | |
382 | ,(and clause (visit-entry-cont clause))))) | |
383 | (($ $cont label ($ $kclause arity ($ $cont kbody body) alternate)) | |
384 | (label ($kclause ,arity ,(visit-cont kbody body) | |
385 | ,(and alternate (visit-entry-cont alternate))))))) | |
386 | ||
387 | (define (visit-cont label cont) | |
388 | (rewrite-cps-cont cont | |
389 | (($ $kargs names vars body) | |
390 | (label ($kargs names vars ,(visit-term body label)))) | |
391 | (_ (label ,cont)))) | |
392 | ||
393 | (define (visit-term term label) | |
394 | (define (visit-exp exp) | |
395 | ;; We shouldn't see $fun here. | |
396 | (rewrite-cps-exp exp | |
397 | ((or ($ $void) ($ $const) ($ $prim)) ,exp) | |
398 | (($ $call proc args) | |
399 | ($call (subst-var proc) ,(map subst-var args))) | |
400 | (($ $callk k proc args) | |
401 | ($callk k (subst-var proc) ,(map subst-var args))) | |
402 | (($ $primcall name args) | |
403 | ($primcall name ,(map subst-var args))) | |
404 | (($ $values args) | |
405 | ($values ,(map subst-var args))) | |
406 | (($ $prompt escape? tag handler) | |
407 | ($prompt escape? (subst-var tag) handler)))) | |
408 | ||
409 | (define (visit-exp* k exp) | |
410 | (match exp | |
411 | ((and fun ($ $fun)) (cse fun dfg)) | |
412 | (_ | |
413 | (match (lookup-cont k dfg) | |
414 | (($ $kargs names vars) | |
415 | (cond | |
416 | ((vector-ref label-substs (label->idx label)) | |
417 | => (lambda (vars) | |
418 | (build-cps-exp ($values vars)))) | |
419 | (else (visit-exp exp)))) | |
420 | (_ (visit-exp exp)))))) | |
421 | ||
422 | (define (visit-dom-conts label) | |
423 | (let ((cont (lookup-cont label dfg))) | |
424 | (match cont | |
425 | (($ $ktail) '()) | |
426 | (($ $kargs) (list (visit-cont label cont))) | |
427 | (else | |
428 | (cons (visit-cont label cont) | |
429 | (append-map visit-dom-conts | |
430 | (vector-ref doms (label->idx label)))))))) | |
431 | ||
432 | (rewrite-cps-term term | |
433 | (($ $letk conts body) | |
434 | ,(visit-term body label)) | |
435 | (($ $letrec names syms funs body) | |
436 | ($letrec names syms (map (lambda (fun) (cse fun dfg)) funs) | |
437 | ,(visit-term body label))) | |
438 | (($ $continue k src exp) | |
8c6a0b7e AW |
439 | ,(let* ((k (if (bitvector-ref bailouts (label->idx label)) |
440 | (match fun | |
441 | (($ $fun src meta free ($ $kentry self ($ $cont ktail))) | |
442 | ktail)) | |
443 | k)) | |
444 | (exp (visit-exp* k exp)) | |
445 | (conts (append-map visit-dom-conts | |
446 | (vector-ref doms (label->idx label))))) | |
7a08e479 AW |
447 | (if (null? conts) |
448 | (build-cps-term ($continue k src ,exp)) | |
449 | (build-cps-term ($letk ,conts ($continue k src ,exp)))))))) | |
450 | ||
451 | (rewrite-cps-exp fun | |
452 | (($ $fun src meta free body) | |
453 | ($fun src meta (map subst-var free) ,(visit-entry-cont body))))) | |
454 | ||
455 | ;; TODO: Bailout branches, truth values, and interprocedural CSE. | |
456 | (define (cse fun dfg) | |
457 | (call-with-values (lambda () (compute-equivalent-subexpressions fun dfg)) | |
8c6a0b7e AW |
458 | (lambda (doms label-substs min-label var-substs min-var bailouts) |
459 | (apply-cse fun dfg doms label-substs min-label var-substs min-var | |
460 | bailouts)))) | |
7a08e479 AW |
461 | |
462 | (define (eliminate-common-subexpressions fun) | |
463 | (call-with-values (lambda () (renumber fun)) | |
464 | (lambda (fun nlabels nvars) | |
465 | (cse fun (compute-dfg fun))))) |