1 ;;; Continuation-passing style (CPS) intermediate language (IL)
3 ;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
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.
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.
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
21 ;;; Common subexpression elimination for CPS.
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))
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)))
41 ((< n (vector-length effects))
42 (when (zero? (exclude-effects (vector-ref effects n) &type-check))
43 (bitvector-set! out n #t))
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))
56 (avail-out (make-vector label-count #f)))
58 (define (label->idx label) (- label min-label))
59 (define (idx->label idx) (+ idx min-label))
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)
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)
76 (bit-set*! dst tmp #f))
77 (let lp ((n 0) (first? #t) (changed? #f))
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".
85 (let lp ((preds (lookup-predecessors (idx->label n) dfg))
90 (let ((pred (label->idx pred)))
92 ((and first? (<= n pred))
93 ;; Avoid intersecting back-edges and cross-edges on
94 ;; the first iteration.
95 (lp preds initialized?))
98 (intersect! in (vector-ref avail-out pred))
99 (bitvector-copy! in (vector-ref avail-out pred)))
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.
107 ((causes-all-effects? fx &all-effects)
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.
115 (bitvector-copy! tmp out)
116 (bit-set*! tmp always-avail #f)
118 (let ((i (bit-position #t tmp i)))
120 (unless (effects-commute? (vector-ref effects i) fx)
121 (bitvector-set! out i #f))
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
128 (bitvector-set! out n #t))
129 (lp (1+ n) first? (or changed? (not (= prev-count new-count)))))))
131 (if (or first? changed?)
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))
149 (when (< n label-count)
150 (let ((bool (make-bitvector (* label-count 2) #f)))
151 (vector-set! boolv n bool)
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)
161 (bit-set*! dst tmp #f))
162 (let lp ((n 0) (first? #t) (changed? #f))
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))
174 (let ((pidx (label->idx pred)))
176 ((and first? (<= n pidx))
177 ;; Avoid intersecting back-edges and cross-edges on
178 ;; the first iteration.
179 (lp preds initialized?))
182 (intersect! bool (vector-ref boolv pidx))
183 (bitvector-copy! bool (vector-ref boolv pidx)))
184 (match (lookup-predecessors pred dfg)
186 (let ((tidx (label->idx test)))
187 (match (lookup-cont pred dfg)
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)))
198 (not (= prev-count (bit-count #t bool)))))))
200 (if (or first? changed?)
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)
209 (define (idx->label idx) (+ idx min-label))
210 (let ((defs (make-vector label-count '())))
212 (when (< n label-count)
216 (match (lookup-cont (idx->label n) dfg)
218 (match (find-call body)
219 (($ $continue k) (cont-defs k))))
220 (($ $kreceive arity kargs)
222 (($ $kclause arity ($ $cont kargs ($ $kargs names syms)))
225 (($ $kfun src meta self) (list self))
230 (define (compute-label-and-var-ranges fun)
232 (($ $cont kfun ($ $kfun src meta self))
233 ((make-local-cont-folder min-label label-count min-var var-count)
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)))
238 (($ $kargs names vars body)
240 (min-var (fold min min-var vars))
241 (var-count (+ var-count (length vars))))
243 (($ $letrec names vars funs 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)))))
249 (($ $kfun src meta self)
250 (values min-label label-count (min self min-var) (1+ var-count)))
252 (values min-label label-count min-var var-count)))))
253 fun kfun 0 self 0))))
255 (define (compute-idoms dfg min-label label-count)
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
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)
268 (define (has-idom? pred)
269 (vector-ref idoms (label->idx pred)))
274 (let lp ((idom pred) (preds preds))
278 (lp (if (has-idom? pred)
279 (common-idom idom pred)
282 (compute-idom preds)))))
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))
290 (let ((idom (vector-ref idoms n))
291 (idom* (compute-idom (lookup-predecessors (idx->label n) dfg))))
294 (iterate (1+ n) changed?))
296 (vector-set! idoms n idom*)
297 (iterate (1+ n) #t)))))
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) '())))
312 (when (< n (vector-length idoms))
313 (let ((idom (vector-ref idoms n)))
314 (vector-push! doms (label->idx idom) (idx->label n)))
318 (define (compute-equivalent-subexpressions fun dfg)
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))
322 (defs (compute-defs dfg min-label label-count))
323 (var-substs (make-vector var-count #f))
324 (equiv-labels (make-vector label-count #f))
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))
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))
336 (f (car l1) (car l2))
337 (lp (cdr l1) (cdr l2)))))
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)))
344 (vector-ref var-substs idx)
347 (define (compute-exp-key exp)
350 (($ $const val) (cons 'const val))
351 (($ $prim name) (cons 'prim name))
352 (($ $fun free body) #f)
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)))
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)
366 ;; Traverse the labels in fun in forward order, which will visit
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))
380 ;; No matching expressions. Add our expression
381 ;; to the equivalence set, if appropriate.
383 (hash-set! equiv-set exp-key (cons label equiv))))
384 ((candidate . candidates)
386 ((not (bitvector-ref avail (label->idx candidate)))
387 ;; This expression isn't available here; try
391 ;; Yay, a match. Mark expression as equivalent.
392 (vector-set! equiv-labels (label->idx label)
394 ;; If we dominate the successor, mark vars
396 (when (= label (vector-ref idoms (label->idx k)))
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)))))))))))))
404 (values (compute-dom-edges idoms min-label)
405 equiv-labels defs min-label var-substs min-var)))
407 (call-with-values (lambda () (compute-label-and-var-ranges fun)) compute))
409 (define (apply-cse fun dfg
410 doms equiv-labels defs min-label var-substs min-var boolv)
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))
415 (define (true-idx idx) idx)
416 (define (false-idx idx) (+ idx (vector-length equiv-labels)))
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)))
423 (vector-ref var-substs idx)
426 (define (visit-fun-cont cont)
427 (rewrite-cps-cont cont
428 (($ $cont label ($ $kargs names vars body))
429 (label ($kargs names vars ,(visit-term body label))))
430 (($ $cont label ($ $kfun src meta self tail clause))
431 (label ($kfun src meta self ,tail
432 ,(and clause (visit-fun-cont clause)))))
433 (($ $cont label ($ $kclause arity ($ $cont kbody body) alternate))
434 (label ($kclause ,arity ,(visit-cont kbody body)
435 ,(and alternate (visit-fun-cont alternate)))))))
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))))
443 (define (visit-term term label)
444 (define (visit-exp exp)
445 ;; We shouldn't see $fun here.
447 ((or ($ $void) ($ $const) ($ $prim)) ,exp)
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)))
455 ($values ,(map subst-var args)))
456 (($ $prompt escape? tag handler)
457 ($prompt escape? (subst-var tag) handler))))
459 (define (visit-exp* k src exp)
464 ($fun (map subst-var free) ,(cse body dfg)))))
467 ((vector-ref equiv-labels (label->idx label))
469 (let* ((eidx (label->idx equiv))
470 (vars (vector-ref defs eidx)))
471 (rewrite-cps-term (lookup-cont k dfg)
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))))
478 ($continue k src ,(visit-exp exp)))
480 ($continue (if t kt kf) src ($values ()))))))
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
487 ($continue k src ,(visit-exp exp)))))))
490 ($continue k src ,(visit-exp exp))))))))
492 (define (visit-dom-conts label)
493 (let ((cont (lookup-cont label dfg)))
496 (($ $kargs) (list (visit-cont label cont)))
498 (cons (visit-cont label cont)
499 (append-map visit-dom-conts
500 (vector-ref doms (label->idx label))))))))
502 (rewrite-cps-term term
503 (($ $letk conts body)
504 ,(visit-term body label))
505 (($ $letrec names syms funs body)
510 ($fun (map subst-var free) ,(cse body dfg)))))
512 ,(visit-term body label)))
513 (($ $continue k src exp)
514 ,(let ((conts (append-map visit-dom-conts
515 (vector-ref doms (label->idx label)))))
517 (visit-exp* k src exp)
519 ($letk ,conts ,(visit-exp* k src exp))))))))
521 (visit-fun-cont fun))
523 (define (cse fun dfg)
524 (call-with-values (lambda () (compute-equivalent-subexpressions fun dfg))
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))))))
530 (define (eliminate-common-subexpressions fun)
531 (call-with-values (lambda () (renumber fun))
532 (lambda (fun nlabels nvars)
533 (cse fun (compute-dfg fun)))))