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