;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
#:use-module (language cps dfg)
#:use-module (language cps effects-analysis)
#:use-module (language cps renumber)
+ #:use-module (language cps intset)
+ #:use-module (rnrs bytevectors)
#:export (eliminate-common-subexpressions))
-(define (compute-always-available-expressions effects)
- "Return the set of continuations whose values are always available
-within their dominance frontier. This is the case for effects that have
-no dependencies and which cause no effects besides &type-check."
- (let ((out (make-bitvector (vector-length effects) #f)))
- (let lp ((n 0))
- (cond
- ((< n (vector-length effects))
- (when (zero? (exclude-effects (vector-ref effects n) &type-check))
- (bitvector-set! out n #t))
- (lp (1+ n)))
- (else out)))))
+(define (cont-successors cont)
+ (match cont
+ (($ $kargs names syms body)
+ (let lp ((body body))
+ (match body
+ (($ $letk conts body) (lp body))
+ (($ $letrec names vars funs body) (lp body))
+ (($ $continue k src exp)
+ (match exp
+ (($ $prompt escape? tag handler) (list k handler))
+ (($ $branch kt) (list k kt))
+ (_ (list k)))))))
+
+ (($ $kreceive arity k) (list k))
+
+ (($ $kclause arity ($ $cont kbody)) (list kbody))
+
+ (($ $kfun src meta self tail clause)
+ (let lp ((clause clause))
+ (match clause
+ (($ $cont kclause ($ $kclause _ _ alt))
+ (cons kclause (lp alt)))
+ (#f '()))))
-(define (compute-available-expressions dfg min-label label-count)
+ (($ $kfun src meta self tail #f) '())
+
+ (($ $ktail) '())))
+
+(define (compute-available-expressions dfg min-label label-count idoms)
"Compute and return the continuations that may be reached if flow
-reaches a continuation N. Returns a vector of bitvectors, whose first
+reaches a continuation N. Returns a vector of intsets, whose first
index corresponds to MIN-LABEL, and so on."
(let* ((effects (compute-effects dfg min-label label-count))
- (always-avail (compute-always-available-expressions effects))
- ;; Vector of bitvectors, indicating that at a continuation N,
- ;; the values from continuations M... are available.
- (avail-in (make-vector label-count #f))
- (avail-out (make-vector label-count #f)))
+ ;; Vector of intsets, indicating that at a continuation N, the
+ ;; values from continuations M... are available.
+ (avail (make-vector label-count #f))
+ (revisit-label #f))
(define (label->idx label) (- label min-label))
(define (idx->label idx) (+ idx min-label))
+ (define (get-effects label) (vector-ref effects (label->idx label)))
+
+ (define (propagate! pred succ out)
+ (let* ((succ-idx (label->idx succ))
+ (in (match (lookup-predecessors succ dfg)
+ ;; Fast path: normal control flow.
+ ((_) out)
+ ;; Slow path: control-flow join.
+ (_ (cond
+ ((vector-ref avail succ-idx)
+ => (lambda (in)
+ (intset-intersect in out)))
+ (else out))))))
+ (when (and (<= succ pred)
+ (or (not revisit-label) (< succ revisit-label))
+ (not (eq? in (vector-ref avail succ-idx))))
+ ;; Arrange to revisit if this is not a forward edge and the
+ ;; available set changed.
+ (set! revisit-label succ))
+ (vector-set! avail succ-idx in)))
+
+ (define (clobber label in)
+ (let ((fx (get-effects label)))
+ (cond
+ ((not (causes-effect? fx &write))
+ ;; Fast-path if this expression clobbers nothing.
+ in)
+ (else
+ ;; Kill clobbered expressions. There is no need to check on
+ ;; any label before than the last dominating label that
+ ;; clobbered everything.
+ (let ((first (let lp ((dom label))
+ (let* ((dom (vector-ref idoms (label->idx dom))))
+ (and (< min-label dom)
+ (let ((fx (vector-ref effects (label->idx dom))))
+ (if (causes-all-effects? fx)
+ dom
+ (lp dom))))))))
+ (let lp ((i first) (in in))
+ (cond
+ ((intset-next in i)
+ => (lambda (i)
+ (if (effect-clobbers? fx (vector-ref effects (label->idx i)))
+ (lp (1+ i) (intset-remove in i))
+ (lp (1+ i) in))))
+ (else in))))))))
(synthesize-definition-effects! effects dfg min-label label-count)
+ (vector-set! avail 0 empty-intset)
+
(let lp ((n 0))
- (when (< n label-count)
- (let ((in (make-bitvector label-count #f))
- (out (make-bitvector label-count #f)))
- (vector-set! avail-in n in)
- (vector-set! avail-out n out)
- (lp (1+ n)))))
-
- (let ((tmp (make-bitvector label-count #f)))
- (define (bitvector-copy! dst src)
- (bitvector-fill! dst #f)
- (bit-set*! dst src #t))
- (define (intersect! dst src)
- (bitvector-copy! tmp src)
- (bit-invert! tmp)
- (bit-set*! dst tmp #f))
- (let lp ((n 0) (first? #t) (changed? #f))
- (cond
- ((< n label-count)
- (let* ((in (vector-ref avail-in n))
- (prev-count (bit-count #t in))
- (out (vector-ref avail-out n))
- (fx (vector-ref effects n)))
- ;; Intersect avail-out from predecessors into "in".
- (let lp ((preds (lookup-predecessors (idx->label n) dfg))
- (initialized? #f))
- (match preds
- (() #t)
- ((pred . preds)
- (let ((pred (label->idx pred)))
- (cond
- ((and first? (<= n pred))
- ;; Avoid intersecting back-edges and cross-edges on
- ;; the first iteration.
- (lp preds initialized?))
- (else
- (if initialized?
- (intersect! in (vector-ref avail-out pred))
- (bitvector-copy! in (vector-ref avail-out pred)))
- (lp preds #t)))))))
- (let ((new-count (bit-count #t in)))
- (unless (= prev-count new-count)
- ;; Copy "in" to "out".
- (bitvector-copy! out in)
- ;; Kill expressions that don't commute.
- (cond
- ((causes-all-effects? fx &all-effects)
- ;; Fast-path if this expression clobbers the world.
- (intersect! out always-avail))
- ((effect-free? (exclude-effects fx &type-check))
- ;; Fast-path if this expression clobbers nothing.
- #t)
- (else
- ;; Loop of sadness.
- (bitvector-copy! tmp out)
- (bit-set*! tmp always-avail #f)
- (let lp ((i 0))
- (let ((i (bit-position #t tmp i)))
- (when i
- (unless (effects-commute? (vector-ref effects i) fx)
- (bitvector-set! out i #f))
- (lp (1+ i))))))))
- (bitvector-set! out n #t)
- (lp (1+ n) first? (or changed? (not (= prev-count new-count)))))))
- (else
- (if (or first? changed?)
- (lp 0 #f #f)
- (values avail-in effects))))))))
+ (cond
+ ((< n label-count)
+ (let* ((label (idx->label n))
+ ;; It's possible for "in" to be #f if it has no
+ ;; predecessors, as is the case for the ktail of a
+ ;; function with an iloop.
+ (in (or (vector-ref avail n) empty-intset))
+ (out (intset-add (clobber label in) label)))
+ (lookup-predecessors label dfg)
+ (let visit-succs ((succs (cont-successors (lookup-cont label dfg))))
+ (match succs
+ (() (lp (1+ n)))
+ ((succ . succs)
+ (propagate! label succ out)
+ (visit-succs succs))))))
+ (revisit-label
+ (let ((n (label->idx revisit-label)))
+ (set! revisit-label #f)
+ (lp n)))
+ (else
+ (values avail effects))))))
(define (compute-truthy-expressions dfg min-label label-count)
"Compute a \"truth map\", indicating which expressions can be shown to
be true and/or false at each of LABEL-COUNT expressions in DFG, starting
-from MIN-LABEL. Returns a vector of bitvectors, each bitvector twice as
-long as LABEL-COUNT. The first half of the bitvector indicates labels
-that may be true, and the second half those that may be false. It could
-be that both true and false proofs are available."
- (let ((boolv (make-vector label-count #f)))
+from MIN-LABEL. Returns a vector of intsets, each intset twice as long
+as LABEL-COUNT. The even elements of the intset indicate labels that
+may be true, and the odd ones indicate those that may be false. It
+could be that both true and false proofs are available."
+ (let ((boolv (make-vector label-count #f))
+ (revisit-label #f))
(define (label->idx label) (- label min-label))
(define (idx->label idx) (+ idx min-label))
- (define (true-idx idx) idx)
- (define (false-idx idx) (+ idx label-count))
+ (define (true-idx idx) (ash idx 1))
+ (define (false-idx idx) (1+ (ash idx 1)))
+
+ (define (propagate! pred succ out)
+ (let* ((succ-idx (label->idx succ))
+ (in (match (lookup-predecessors succ dfg)
+ ;; Fast path: normal control flow.
+ ((_) out)
+ ;; Slow path: control-flow join.
+ (_ (cond
+ ((vector-ref boolv succ-idx)
+ => (lambda (in)
+ (intset-intersect in out)))
+ (else out))))))
+ (when (and (<= succ pred)
+ (or (not revisit-label) (< succ revisit-label))
+ (not (eq? in (vector-ref boolv succ-idx))))
+ (set! revisit-label succ))
+ (vector-set! boolv succ-idx in)))
+
+ (vector-set! boolv 0 empty-intset)
(let lp ((n 0))
- (when (< n label-count)
- (let ((bool (make-bitvector (* label-count 2) #f)))
- (vector-set! boolv n bool)
- (lp (1+ n)))))
-
- (let ((tmp (make-bitvector (* label-count 2) #f)))
- (define (bitvector-copy! dst src)
- (bitvector-fill! dst #f)
- (bit-set*! dst src #t))
- (define (intersect! dst src)
- (bitvector-copy! tmp src)
- (bit-invert! tmp)
- (bit-set*! dst tmp #f))
- (let lp ((n 0) (first? #t) (changed? #f))
- (cond
- ((< n label-count)
- (let* ((label (idx->label n))
- (bool (vector-ref boolv n))
- (prev-count (bit-count #t bool)))
- ;; Intersect truthiness from all predecessors.
- (let lp ((preds (lookup-predecessors label dfg))
- (initialized? #f))
- (match preds
- (() #t)
- ((pred . preds)
- (let ((pidx (label->idx pred)))
- (cond
- ((and first? (<= n pidx))
- ;; Avoid intersecting back-edges and cross-edges on
- ;; the first iteration.
- (lp preds initialized?))
- (else
- (if initialized?
- (intersect! bool (vector-ref boolv pidx))
- (bitvector-copy! bool (vector-ref boolv pidx)))
- (match (lookup-predecessors pred dfg)
- ((test)
- (let ((tidx (label->idx test)))
- (match (lookup-cont pred dfg)
- (($ $kif kt kf)
- (when (eqv? kt label)
- (bitvector-set! bool (true-idx tidx) #t))
- (when (eqv? kf label)
- (bitvector-set! bool (false-idx tidx) #t)))
- (_ #t))))
- (_ #t))
- (lp preds #t)))))))
- (lp (1+ n) first?
- (or changed?
- (not (= prev-count (bit-count #t bool)))))))
- (else
- (if (or first? changed?)
- (lp 0 #f #f)
- boolv)))))))
+ (cond
+ ((< n label-count)
+ (let* ((label (idx->label n))
+ ;; It's possible for "in" to be #f if it has no
+ ;; predecessors, as is the case for the ktail of a
+ ;; function with an iloop.
+ (in (or (vector-ref boolv n) empty-intset)))
+ (define (default-propagate)
+ (let visit-succs ((succs (cont-successors (lookup-cont label dfg))))
+ (match succs
+ (() (lp (1+ n)))
+ ((succ . succs)
+ (propagate! label succ in)
+ (visit-succs succs)))))
+ (match (lookup-cont label dfg)
+ (($ $kargs names syms body)
+ (match (find-call body)
+ (($ $continue k src ($ $branch kt))
+ (propagate! label k (intset-add in (false-idx n)))
+ (propagate! label kt (intset-add in (true-idx n)))
+ (lp (1+ n)))
+ (_ (default-propagate))))
+ (_ (default-propagate)))))
+ (revisit-label
+ (let ((n (label->idx revisit-label)))
+ (set! revisit-label #f)
+ (lp n)))
+ (else boolv)))))
;; Returns a map of label-idx -> (var-idx ...) indicating the variables
;; defined by a given labelled expression.
(cont-defs kargs))
(($ $kclause arity ($ $cont kargs ($ $kargs names syms)))
syms)
- (($ $kif) '())
(($ $kfun src meta self) (list self))
(($ $ktail) '())))
(lp (1+ n))))
(values min-label label-count min-var var-count)))))
fun kfun 0 self 0))))
-(define (compute-idoms dfg min-label label-count)
- (define (label->idx label) (- label min-label))
- (define (idx->label idx) (+ idx min-label))
- (let ((idoms (make-vector label-count #f)))
- (define (common-idom d0 d1)
- ;; We exploit the fact that a reverse post-order is a topological
- ;; sort, and so the idom of a node is always numerically less than
- ;; the node itself.
- (cond
- ((= d0 d1) d0)
- ((< d0 d1) (common-idom d0 (vector-ref idoms (label->idx d1))))
- (else (common-idom (vector-ref idoms (label->idx d0)) d1))))
- (define (compute-idom preds)
- (define (has-idom? pred)
- (vector-ref idoms (label->idx pred)))
- (match preds
- (() min-label)
- ((pred . preds)
- (if (has-idom? pred)
- (let lp ((idom pred) (preds preds))
- (match preds
- (() idom)
- ((pred . preds)
- (lp (if (has-idom? pred)
- (common-idom idom pred)
- idom)
- preds))))
- (compute-idom preds)))))
- ;; This is the iterative O(n^2) fixpoint algorithm, originally from
- ;; Allen and Cocke ("Graph-theoretic constructs for program flow
- ;; analysis", 1972). See the discussion in Cooper, Harvey, and
- ;; Kennedy's "A Simple, Fast Dominance Algorithm", 2001.
- (let iterate ((n 0) (changed? #f))
- (cond
- ((< n label-count)
- (let ((idom (vector-ref idoms n))
- (idom* (compute-idom (lookup-predecessors (idx->label n) dfg))))
- (cond
- ((eqv? idom idom*)
- (iterate (1+ n) changed?))
- (else
- (vector-set! idoms n idom*)
- (iterate (1+ n) #t)))))
- (changed?
- (iterate 0 #f))
- (else idoms)))))
-
;; Compute a vector containing, for each node, a list of the nodes that
;; it immediately dominates. These are the "D" edges in the DJ tree.
-(define (compute-dom-edges idoms min-label)
- (define (label->idx label) (- label min-label))
- (define (idx->label idx) (+ idx min-label))
- (define (vector-push! vec idx val)
- (let ((v vec) (i idx))
- (vector-set! v i (cons val (vector-ref v i)))))
- (let ((doms (make-vector (vector-length idoms) '())))
- (let lp ((n 0))
- (when (< n (vector-length idoms))
- (let ((idom (vector-ref idoms n)))
- (vector-push! doms (label->idx idom) (idx->label n)))
- (lp (1+ n))))
- doms))
(define (compute-equivalent-subexpressions fun dfg)
- (define (compute min-label label-count min-var var-count avail effects)
- (let ((idoms (compute-idoms dfg min-label label-count))
- (defs (compute-defs dfg min-label label-count))
+ (define (compute min-label label-count min-var var-count idoms avail effects)
+ (let ((defs (compute-defs dfg min-label label-count))
(var-substs (make-vector var-count #f))
(equiv-labels (make-vector label-count #f))
(equiv-set (make-hash-table)))
(define (compute-exp-key exp)
(match exp
- (($ $void) 'void)
(($ $const val) (cons 'const val))
(($ $prim name) (cons 'prim name))
(($ $fun free body) #f)
(($ $callk k proc args) #f)
(($ $primcall name args)
(cons* 'primcall name (map subst-var args)))
+ (($ $branch _ ($ $primcall name args))
+ (cons* 'primcall name (map subst-var args)))
+ (($ $branch) #f)
(($ $values args) #f)
(($ $prompt escape? tag handler) #f)))
(hash-set! equiv-set aux-key
(acons label (list var) equiv))))
(match exp-key
+ (('primcall 'box val)
+ (match defs
+ ((box)
+ (add-def! `(primcall box-ref ,(subst-var box)) val))))
+ (('primcall 'box-set! box val)
+ (add-def! `(primcall box-ref ,box) val))
(('primcall 'cons car cdr)
(match defs
((pair)
- (add-def! `(primcall car ,pair) car)
- (add-def! `(primcall cdr ,pair) cdr))))
+ (add-def! `(primcall car ,(subst-var pair)) car)
+ (add-def! `(primcall cdr ,(subst-var pair)) cdr))))
(('primcall 'set-car! pair car)
(add-def! `(primcall car ,pair) car))
(('primcall 'set-cdr! pair cdr)
(('primcall (or 'make-vector 'make-vector/immediate) len fill)
(match defs
((vec)
- (add-def! `(primcall vector-length ,vec) len))))
+ (add-def! `(primcall vector-length ,(subst-var vec)) len))))
(('primcall 'vector-set! vec idx val)
(add-def! `(primcall vector-ref ,vec ,idx) val))
(('primcall 'vector-set!/immediate vec idx val)
(('primcall (or 'allocate-struct 'allocate-struct/immediate)
vtable size)
(match defs
+ (() #f) ;; allocate-struct in tail or kreceive position.
((struct)
- (add-def! `(primcall struct-vtable ,struct) vtable))))
+ (add-def! `(primcall struct-vtable ,(subst-var struct))
+ vtable))))
(('primcall 'struct-set! struct n val)
(add-def! `(primcall struct-ref ,struct ,n) val))
(('primcall 'struct-set!/immediate struct n val)
(let* ((exp-key (compute-exp-key exp))
(equiv (hash-ref equiv-set exp-key '()))
(lidx (label->idx label))
+ (fx (vector-ref effects lidx))
(avail (vector-ref avail lidx)))
- ;; If this expression defines auxiliary definitions,
- ;; as `cons' does for the results of `car' and `cdr',
- ;; define those.
- (add-auxiliary-definitions! label exp-key)
(let lp ((candidates equiv))
(match candidates
(()
;; if the value proves to be unused, in the
;; allocation case).
(when (and exp-key
- (not (causes-effects?
- (vector-ref effects lidx)
- (logior &fluid-environment
- &allocation))))
+ (not (causes-effect? fx &allocation))
+ (not (effect-clobbers?
+ fx
+ (&read-object &fluid))))
(hash-set! equiv-set exp-key
(acons label (vector-ref defs lidx)
equiv))))
(((and head (candidate . vars)) . candidates)
(cond
- ((not (bitvector-ref avail (label->idx candidate)))
+ ((not (intset-ref avail candidate))
;; This expression isn't available here; try
;; the next one.
(lp candidates))
(lambda (var subst-var)
(vector-set! var-substs (var->idx var) subst-var))
(vector-ref defs lidx)
- vars)))))))))))
+ vars)))))))
+ ;; If this expression defines auxiliary definitions,
+ ;; as `cons' does for the results of `car' and `cdr',
+ ;; define those. Do so after finding equivalent
+ ;; expressions, so that we can take advantage of
+ ;; subst'd output vars.
+ (add-auxiliary-definitions! label exp-key)))))
(_ #f))
(lp (1+ label))))
(values (compute-dom-edges idoms min-label)
(call-with-values (lambda () (compute-label-and-var-ranges fun))
(lambda (min-label label-count min-var var-count)
- (call-with-values
- (lambda ()
- (compute-available-expressions dfg min-label label-count))
- (lambda (avail effects)
- (compute min-label label-count min-var var-count avail effects))))))
+ (let ((idoms (compute-idoms dfg min-label label-count)))
+ (call-with-values
+ (lambda ()
+ (compute-available-expressions dfg min-label label-count idoms))
+ (lambda (avail effects)
+ (compute min-label label-count min-var var-count
+ idoms avail effects)))))))
(define (apply-cse fun dfg
doms equiv-labels min-label var-substs min-var boolv)
(define (label->idx label) (- label min-label))
(define (idx->var idx) (+ idx min-var))
(define (var->idx var) (- var min-var))
- (define (true-idx idx) idx)
- (define (false-idx idx) (+ idx (vector-length equiv-labels)))
+ (define (true-idx idx) (ash idx 1))
+ (define (false-idx idx) (1+ (ash idx 1)))
(define (subst-var var)
;; It could be that the var is free in this function; if so,
(define (visit-fun-cont cont)
(rewrite-cps-cont cont
- (($ $cont label ($ $kargs names vars body))
- (label ($kargs names vars ,(visit-term body label))))
(($ $cont label ($ $kfun src meta self tail clause))
(label ($kfun src meta self ,tail
,(and clause (visit-fun-cont clause)))))
(define (visit-exp exp)
;; We shouldn't see $fun here.
(rewrite-cps-exp exp
- ((or ($ $void) ($ $const) ($ $prim)) ,exp)
+ ((or ($ $const) ($ $prim)) ,exp)
(($ $call proc args)
($call (subst-var proc) ,(map subst-var args)))
(($ $callk k proc args)
($callk k (subst-var proc) ,(map subst-var args)))
(($ $primcall name args)
($primcall name ,(map subst-var args)))
+ (($ $branch k exp)
+ ($branch k ,(visit-exp exp)))
(($ $values args)
($values ,(map subst-var args)))
(($ $prompt escape? tag handler)
=> (match-lambda
((equiv . vars)
(let* ((eidx (label->idx equiv)))
- (rewrite-cps-term (lookup-cont k dfg)
- (($ $kif kt kf)
- ,(let* ((bool (vector-ref boolv (label->idx label)))
- (t (bitvector-ref bool (true-idx eidx)))
- (f (bitvector-ref bool (false-idx eidx))))
- (if (eqv? t f)
- (build-cps-term
- ($continue k src ,(visit-exp exp)))
- (build-cps-term
- ($continue (if t kt kf) src ($values ()))))))
- (($ $kargs)
- ($continue k src ($values vars)))
- ;; There is no point in adding a case for $ktail, as
- ;; only $values, $call, or $callk can continue to
- ;; $ktail.
+ (match exp
+ (($ $branch kt exp)
+ (let* ((bool (vector-ref boolv (label->idx label)))
+ (t (intset-ref bool (true-idx eidx)))
+ (f (intset-ref bool (false-idx eidx))))
+ (if (eqv? t f)
+ (build-cps-term
+ ($continue k src
+ ($branch kt ,(visit-exp exp))))
+ (build-cps-term
+ ($continue (if t kt k) src ($values ()))))))
(_
- ($continue k src ,(visit-exp exp))))))))
+ ;; FIXME: can we always continue with $values? why
+ ;; or why not?
+ (rewrite-cps-term (lookup-cont k dfg)
+ (($ $kargs)
+ ($continue k src ($values vars)))
+ (_
+ ($continue k src ,(visit-exp exp))))))))))
(else
(build-cps-term
($continue k src ,(visit-exp exp))))))))
HCoop / bpt / guile.git / blobdiff