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 #:use-module (language cps intset)
33 #:use-module (rnrs bytevectors)
34 #:export (eliminate-common-subexpressions))
36 (define (cont-successors cont)
38 (($ $kargs names syms body)
41 (($ $letk conts body) (lp body))
42 (($ $letrec names vars funs body) (lp body))
43 (($ $continue k src exp)
45 (($ $prompt escape? tag handler) (list k handler))
46 (($ $branch kt) (list k kt))
49 (($ $kreceive arity k) (list k))
51 (($ $kclause arity ($ $cont kbody)) (list kbody))
53 (($ $kfun src meta self tail clause)
54 (let lp ((clause clause))
56 (($ $cont kclause ($ $kclause _ _ alt))
57 (cons kclause (lp alt)))
60 (($ $kfun src meta self tail #f) '())
64 (define (compute-available-expressions dfg min-label label-count idoms)
65 "Compute and return the continuations that may be reached if flow
66 reaches a continuation N. Returns a vector of intsets, whose first
67 index corresponds to MIN-LABEL, and so on."
68 (let* ((effects (compute-effects dfg min-label label-count))
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))
74 (define (label->idx label) (- label min-label))
75 (define (idx->label idx) (+ idx min-label))
76 (define (get-effects label) (vector-ref effects (label->idx label)))
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.
83 ;; Slow path: control-flow join.
85 ((vector-ref avail succ-idx)
87 (intset-intersect in 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)))
97 (define (clobber label in)
98 (let ((fx (get-effects label)))
100 ((not (causes-effect? fx &write))
101 ;; Fast-path if this expression clobbers nothing.
104 ;; Kill clobbered expressions. There is no need to check on
105 ;; any label before than the last dominating label that
106 ;; clobbered everything.
107 (let ((first (let lp ((dom label))
108 (let* ((dom (vector-ref idoms (label->idx dom))))
109 (and (< min-label dom)
110 (let ((fx (vector-ref effects (label->idx dom))))
111 (if (causes-all-effects? fx)
114 (let lp ((i first) (in in))
118 (if (effect-clobbers? fx (vector-ref effects (label->idx i)))
119 (lp (1+ i) (intset-remove in i))
123 (synthesize-definition-effects! effects dfg min-label label-count)
125 (vector-set! avail 0 empty-intset)
130 (let* ((label (idx->label n))
131 ;; It's possible for "in" to be #f if it has no
132 ;; predecessors, as is the case for the ktail of a
133 ;; function with an iloop.
134 (in (or (vector-ref avail n) empty-intset))
135 (out (intset-add (clobber label in) label)))
136 (lookup-predecessors label dfg)
137 (let visit-succs ((succs (cont-successors (lookup-cont label dfg))))
141 (propagate! label succ out)
142 (visit-succs succs))))))
144 (let ((n (label->idx revisit-label)))
145 (set! revisit-label #f)
148 (values avail effects))))))
150 (define (compute-truthy-expressions dfg min-label label-count)
151 "Compute a \"truth map\", indicating which expressions can be shown to
152 be true and/or false at each of LABEL-COUNT expressions in DFG, starting
153 from MIN-LABEL. Returns a vector of intsets, each intset twice as long
154 as LABEL-COUNT. The even elements of the intset indicate labels that
155 may be true, and the odd ones indicate those that may be false. It
156 could be that both true and false proofs are available."
157 (let ((boolv (make-vector label-count #f))
159 (define (label->idx label) (- label min-label))
160 (define (idx->label idx) (+ idx min-label))
161 (define (true-idx idx) (ash idx 1))
162 (define (false-idx idx) (1+ (ash idx 1)))
164 (define (propagate! pred succ out)
165 (let* ((succ-idx (label->idx succ))
166 (in (match (lookup-predecessors succ dfg)
167 ;; Fast path: normal control flow.
169 ;; Slow path: control-flow join.
171 ((vector-ref boolv succ-idx)
173 (intset-intersect in out)))
175 (when (and (<= succ pred)
176 (or (not revisit-label) (< succ revisit-label))
177 (not (eq? in (vector-ref boolv succ-idx))))
178 (set! revisit-label succ))
179 (vector-set! boolv succ-idx in)))
181 (vector-set! boolv 0 empty-intset)
186 (let* ((label (idx->label n))
187 ;; It's possible for "in" to be #f if it has no
188 ;; predecessors, as is the case for the ktail of a
189 ;; function with an iloop.
190 (in (or (vector-ref boolv n) empty-intset)))
191 (define (default-propagate)
192 (let visit-succs ((succs (cont-successors (lookup-cont label dfg))))
196 (propagate! label succ in)
197 (visit-succs succs)))))
198 (match (lookup-cont label dfg)
199 (($ $kargs names syms body)
200 (match (find-call body)
201 (($ $continue k src ($ $branch kt))
202 (propagate! label k (intset-add in (false-idx n)))
203 (propagate! label kt (intset-add in (true-idx n)))
205 (_ (default-propagate))))
206 (_ (default-propagate)))))
208 (let ((n (label->idx revisit-label)))
209 (set! revisit-label #f)
213 ;; Returns a map of label-idx -> (var-idx ...) indicating the variables
214 ;; defined by a given labelled expression.
215 (define (compute-defs dfg min-label label-count)
216 (define (cont-defs k)
217 (match (lookup-cont k dfg)
218 (($ $kargs names vars) vars)
220 (define (idx->label idx) (+ idx min-label))
221 (let ((defs (make-vector label-count '())))
223 (when (< n label-count)
227 (match (lookup-cont (idx->label n) dfg)
229 (match (find-call body)
230 (($ $continue k) (cont-defs k))))
231 (($ $kreceive arity kargs)
233 (($ $kclause arity ($ $cont kargs ($ $kargs names syms)))
235 (($ $kfun src meta self) (list self))
240 (define (compute-label-and-var-ranges fun)
242 (($ $cont kfun ($ $kfun src meta self))
243 ((make-local-cont-folder min-label label-count min-var var-count)
244 (lambda (k cont min-label label-count min-var var-count)
245 (let ((min-label (min k min-label))
246 (label-count (1+ label-count)))
248 (($ $kargs names vars body)
250 (min-var (fold min min-var vars))
251 (var-count (+ var-count (length vars))))
253 (($ $letrec names vars funs body)
255 (fold min min-var vars)
256 (+ var-count (length vars))))
257 (($ $letk conts body) (lp body min-var var-count))
258 (_ (values min-label label-count min-var var-count)))))
259 (($ $kfun src meta self)
260 (values min-label label-count (min self min-var) (1+ var-count)))
262 (values min-label label-count min-var var-count)))))
263 fun kfun 0 self 0))))
265 ;; Compute a vector containing, for each node, a list of the nodes that
266 ;; it immediately dominates. These are the "D" edges in the DJ tree.
268 (define (compute-equivalent-subexpressions fun dfg)
269 (define (compute min-label label-count min-var var-count idoms avail effects)
270 (let ((defs (compute-defs dfg min-label label-count))
271 (var-substs (make-vector var-count #f))
272 (equiv-labels (make-vector label-count #f))
273 (equiv-set (make-hash-table)))
274 (define (idx->label idx) (+ idx min-label))
275 (define (label->idx label) (- label min-label))
276 (define (idx->var idx) (+ idx min-var))
277 (define (var->idx var) (- var min-var))
279 (define (for-each/2 f l1 l2)
280 (unless (= (length l1) (length l2))
281 (error "bad lengths" l1 l2))
282 (let lp ((l1 l1) (l2 l2))
284 (f (car l1) (car l2))
285 (lp (cdr l1) (cdr l2)))))
287 (define (subst-var var)
288 ;; It could be that the var is free in this function; if so, its
289 ;; name will be less than min-var.
290 (let ((idx (var->idx var)))
292 (vector-ref var-substs idx)
295 (define (compute-exp-key exp)
298 (($ $const val) (cons 'const val))
299 (($ $prim name) (cons 'prim name))
300 (($ $fun free body) #f)
301 (($ $call proc args) #f)
302 (($ $callk k proc args) #f)
303 (($ $primcall name args)
304 (cons* 'primcall name (map subst-var args)))
305 (($ $branch _ ($ $primcall name args))
306 (cons* 'primcall name (map subst-var args)))
308 (($ $values args) #f)
309 (($ $prompt escape? tag handler) #f)))
311 (define (add-auxiliary-definitions! label exp-key)
312 (let ((defs (vector-ref defs (label->idx label))))
313 (define (add-def! aux-key var)
314 (let ((equiv (hash-ref equiv-set aux-key '())))
315 (hash-set! equiv-set aux-key
316 (acons label (list var) equiv))))
318 (('primcall 'box val)
321 (add-def! `(primcall box-ref ,(subst-var box)) val))))
322 (('primcall 'box-set! box val)
323 (add-def! `(primcall box-ref ,box) val))
324 (('primcall 'cons car cdr)
327 (add-def! `(primcall car ,(subst-var pair)) car)
328 (add-def! `(primcall cdr ,(subst-var pair)) cdr))))
329 (('primcall 'set-car! pair car)
330 (add-def! `(primcall car ,pair) car))
331 (('primcall 'set-cdr! pair cdr)
332 (add-def! `(primcall cdr ,pair) cdr))
333 (('primcall (or 'make-vector 'make-vector/immediate) len fill)
336 (add-def! `(primcall vector-length ,(subst-var vec)) len))))
337 (('primcall 'vector-set! vec idx val)
338 (add-def! `(primcall vector-ref ,vec ,idx) val))
339 (('primcall 'vector-set!/immediate vec idx val)
340 (add-def! `(primcall vector-ref/immediate ,vec ,idx) val))
341 (('primcall (or 'allocate-struct 'allocate-struct/immediate)
345 (add-def! `(primcall struct-vtable ,(subst-var struct))
347 (('primcall 'struct-set! struct n val)
348 (add-def! `(primcall struct-ref ,struct ,n) val))
349 (('primcall 'struct-set!/immediate struct n val)
350 (add-def! `(primcall struct-ref/immediate ,struct ,n) val))
353 ;; The initial substs vector is the identity map.
354 (let lp ((var min-var))
355 (when (< (var->idx var) var-count)
356 (vector-set! var-substs (var->idx var) var)
359 ;; Traverse the labels in fun in forward order, which will visit
361 (let lp ((label min-label))
362 (when (< (label->idx label) label-count)
363 (match (lookup-cont label dfg)
364 (($ $kargs names vars body)
365 (match (find-call body)
366 (($ $continue k src exp)
367 (let* ((exp-key (compute-exp-key exp))
368 (equiv (hash-ref equiv-set exp-key '()))
369 (lidx (label->idx label))
370 (fx (vector-ref effects lidx))
371 (avail (vector-ref avail lidx)))
372 (let lp ((candidates equiv))
375 ;; No matching expressions. Add our expression
376 ;; to the equivalence set, if appropriate. Note
377 ;; that expressions that allocate a fresh object
378 ;; or change the current fluid environment can't
379 ;; be eliminated by CSE (though DCE might do it
380 ;; if the value proves to be unused, in the
383 (not (causes-effect? fx &allocation))
384 (not (effect-clobbers?
386 (&read-object &fluid))))
387 (hash-set! equiv-set exp-key
388 (acons label (vector-ref defs lidx)
390 (((and head (candidate . vars)) . candidates)
392 ((not (intset-ref avail candidate))
393 ;; This expression isn't available here; try
397 ;; Yay, a match. Mark expression as equivalent.
398 (vector-set! equiv-labels lidx head)
399 ;; If we dominate the successor, mark vars
401 (when (= label (vector-ref idoms (label->idx k)))
403 (lambda (var subst-var)
404 (vector-set! var-substs (var->idx var) subst-var))
405 (vector-ref defs lidx)
407 ;; If this expression defines auxiliary definitions,
408 ;; as `cons' does for the results of `car' and `cdr',
409 ;; define those. Do so after finding equivalent
410 ;; expressions, so that we can take advantage of
411 ;; subst'd output vars.
412 (add-auxiliary-definitions! label exp-key)))))
415 (values (compute-dom-edges idoms min-label)
416 equiv-labels min-label var-substs min-var)))
418 (call-with-values (lambda () (compute-label-and-var-ranges fun))
419 (lambda (min-label label-count min-var var-count)
420 (let ((idoms (compute-idoms dfg min-label label-count)))
423 (compute-available-expressions dfg min-label label-count idoms))
424 (lambda (avail effects)
425 (compute min-label label-count min-var var-count
426 idoms avail effects)))))))
428 (define (apply-cse fun dfg
429 doms equiv-labels min-label var-substs min-var boolv)
430 (define (idx->label idx) (+ idx min-label))
431 (define (label->idx label) (- label min-label))
432 (define (idx->var idx) (+ idx min-var))
433 (define (var->idx var) (- var min-var))
434 (define (true-idx idx) (ash idx 1))
435 (define (false-idx idx) (1+ (ash idx 1)))
437 (define (subst-var var)
438 ;; It could be that the var is free in this function; if so,
439 ;; its name will be less than min-var.
440 (let ((idx (var->idx var)))
442 (vector-ref var-substs idx)
445 (define (visit-fun-cont cont)
446 (rewrite-cps-cont cont
447 (($ $cont label ($ $kargs names vars body))
448 (label ($kargs names vars ,(visit-term body label))))
449 (($ $cont label ($ $kfun src meta self tail clause))
450 (label ($kfun src meta self ,tail
451 ,(and clause (visit-fun-cont clause)))))
452 (($ $cont label ($ $kclause arity ($ $cont kbody body) alternate))
453 (label ($kclause ,arity ,(visit-cont kbody body)
454 ,(and alternate (visit-fun-cont alternate)))))))
456 (define (visit-cont label cont)
457 (rewrite-cps-cont cont
458 (($ $kargs names vars body)
459 (label ($kargs names vars ,(visit-term body label))))
462 (define (visit-term term label)
463 (define (visit-exp exp)
464 ;; We shouldn't see $fun here.
466 ((or ($ $void) ($ $const) ($ $prim)) ,exp)
468 ($call (subst-var proc) ,(map subst-var args)))
469 (($ $callk k proc args)
470 ($callk k (subst-var proc) ,(map subst-var args)))
471 (($ $primcall name args)
472 ($primcall name ,(map subst-var args)))
474 ($branch k ,(visit-exp exp)))
476 ($values ,(map subst-var args)))
477 (($ $prompt escape? tag handler)
478 ($prompt escape? (subst-var tag) handler))))
480 (define (visit-exp* k src exp)
485 ($fun (map subst-var free) ,(cse body dfg)))))
488 ((vector-ref equiv-labels (label->idx label))
491 (let* ((eidx (label->idx equiv)))
494 (let* ((bool (vector-ref boolv (label->idx label)))
495 (t (intset-ref bool (true-idx eidx)))
496 (f (intset-ref bool (false-idx eidx))))
500 ($branch kt ,(visit-exp exp))))
502 ($continue (if t kt k) src ($values ()))))))
504 ;; FIXME: can we always continue with $values? why
506 (rewrite-cps-term (lookup-cont k dfg)
508 ($continue k src ($values vars)))
510 ($continue k src ,(visit-exp exp))))))))))
513 ($continue k src ,(visit-exp exp))))))))
515 (define (visit-dom-conts label)
516 (let ((cont (lookup-cont label dfg)))
519 (($ $kargs) (list (visit-cont label cont)))
521 (cons (visit-cont label cont)
522 (append-map visit-dom-conts
523 (vector-ref doms (label->idx label))))))))
525 (rewrite-cps-term term
526 (($ $letk conts body)
527 ,(visit-term body label))
528 (($ $letrec names syms funs body)
533 ($fun (map subst-var free) ,(cse body dfg)))))
535 ,(visit-term body label)))
536 (($ $continue k src exp)
537 ,(let ((conts (append-map visit-dom-conts
538 (vector-ref doms (label->idx label)))))
540 (visit-exp* k src exp)
542 ($letk ,conts ,(visit-exp* k src exp))))))))
544 (visit-fun-cont fun))
546 (define (cse fun dfg)
547 (call-with-values (lambda () (compute-equivalent-subexpressions fun dfg))
548 (lambda (doms equiv-labels min-label var-substs min-var)
549 (apply-cse fun dfg doms equiv-labels min-label var-substs min-var
550 (compute-truthy-expressions dfg
551 min-label (vector-length doms))))))
553 (define (eliminate-common-subexpressions fun)
554 (call-with-values (lambda () (renumber fun))
555 (lambda (fun nlabels nvars)
556 (cse fun (compute-dfg fun)))))