mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-28 07:50:20 +02:00
CSE does scalar replacement of aggregates
* module/language/cps/effects-analysis.scm (effects-clobber): New helper. (length): Only depend on &cdr. (synthesize-definition-effects!): New interface. * module/language/cps/cse.scm (compute-available-expressions): Don't count out constructors here -- we'll do that below. (compute-defs): Add a comment. (compute-equivalent-subexpressions): Synthesize getter calls at constructor/setter sites, so that (set-car! x y) can cause a future (car x) to just reference y. The equiv-labels set now stores the defined vars, so there is no need for the defs vector. (cse, apply-cse): Adapt to compute-equivalent-subexpressions change.
This commit is contained in:
Andy Wingo
parent
cfb42b4c8a
commit
6119a90595
2 changed files with 124 additions and 29 deletions
|
|
@ -58,6 +58,8 @@ index corresponds to MIN-LABEL, and so on."
|
|||
(define (label->idx label) (- label min-label))
|
||||
(define (idx->label idx) (+ idx min-label))
|
||||
|
||||
(synthesize-definition-effects! effects dfg min-label label-count)
|
||||
|
||||
(let lp ((n 0))
|
||||
(when (< n label-count)
|
||||
(let ((in (make-bitvector label-count #f))
|
||||
|
|
@ -120,17 +122,12 @@ index corresponds to MIN-LABEL, and so on."
|
|||
(unless (effects-commute? (vector-ref effects i) fx)
|
||||
(bitvector-set! out i #f))
|
||||
(lp (1+ i))))))))
|
||||
;; Unless this expression allocates a fresh object or
|
||||
;; changes the current fluid environment, mark expressions
|
||||
;; that match it as available for elimination.
|
||||
(unless (causes-effects? fx (logior &fluid-environment
|
||||
&allocation))
|
||||
(bitvector-set! out n #t))
|
||||
(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)
|
||||
avail-in)))))))
|
||||
(values avail-in effects))))))))
|
||||
|
||||
(define (compute-truthy-expressions dfg min-label label-count)
|
||||
"Compute a \"truth map\", indicating which expressions can be shown to
|
||||
|
|
@ -201,6 +198,8 @@ be that both true and false proofs are available."
|
|||
(lp 0 #f #f)
|
||||
boolv)))))))
|
||||
|
||||
;; Returns a map of label-idx -> (var-idx ...) indicating the variables
|
||||
;; defined by a given labelled expression.
|
||||
(define (compute-defs dfg min-label label-count)
|
||||
(define (cont-defs k)
|
||||
(match (lookup-cont k dfg)
|
||||
|
|
@ -316,9 +315,8 @@ be that both true and false proofs are available."
|
|||
doms))
|
||||
|
||||
(define (compute-equivalent-subexpressions fun dfg)
|
||||
(define (compute min-label label-count min-var var-count)
|
||||
(let ((avail (compute-available-expressions dfg min-label label-count))
|
||||
(idoms (compute-idoms dfg min-label label-count))
|
||||
(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))
|
||||
(var-substs (make-vector var-count #f))
|
||||
(equiv-labels (make-vector label-count #f))
|
||||
|
|
@ -357,6 +355,41 @@ be that both true and false proofs are available."
|
|||
(($ $values args) #f)
|
||||
(($ $prompt escape? tag handler) #f)))
|
||||
|
||||
(define (add-auxiliary-definitions! label exp-key)
|
||||
(let ((defs (vector-ref defs (label->idx label))))
|
||||
(define (add-def! aux-key var)
|
||||
(let ((equiv (hash-ref equiv-set aux-key '())))
|
||||
(hash-set! equiv-set aux-key
|
||||
(acons label (list var) equiv))))
|
||||
(match exp-key
|
||||
(('primcall 'cons car cdr)
|
||||
(match defs
|
||||
((pair)
|
||||
(add-def! `(primcall car ,pair) car)
|
||||
(add-def! `(primcall cdr ,pair) cdr))))
|
||||
(('primcall 'set-car! pair car)
|
||||
(add-def! `(primcall car ,pair) car))
|
||||
(('primcall 'set-cdr! pair cdr)
|
||||
(add-def! `(primcall cdr ,pair) cdr))
|
||||
(('primcall (or 'make-vector 'make-vector/immediate) len fill)
|
||||
(match defs
|
||||
((vec)
|
||||
(add-def! `(primcall vector-length ,vec) len))))
|
||||
(('primcall 'vector-set! vec idx val)
|
||||
(add-def! `(primcall vector-ref ,vec ,idx) val))
|
||||
(('primcall 'vector-set!/immediate vec idx val)
|
||||
(add-def! `(primcall vector-ref/immediate ,vec ,idx) val))
|
||||
(('primcall (or 'allocate-struct 'allocate-struct/immediate)
|
||||
vtable size)
|
||||
(match defs
|
||||
((struct)
|
||||
(add-def! `(primcall struct-vtable ,struct) vtable))))
|
||||
(('primcall 'struct-set! struct n val)
|
||||
(add-def! `(primcall struct-ref ,struct ,n) val))
|
||||
(('primcall 'struct-set!/immediate struct n val)
|
||||
(add-def! `(primcall struct-ref/immediate ,struct ,n) val))
|
||||
(_ #t))))
|
||||
|
||||
;; The initial substs vector is the identity map.
|
||||
(let lp ((var min-var))
|
||||
(when (< (var->idx var) var-count)
|
||||
|
|
@ -373,15 +406,31 @@ be that both true and false proofs are available."
|
|||
(($ $continue k src exp)
|
||||
(let* ((exp-key (compute-exp-key exp))
|
||||
(equiv (hash-ref equiv-set exp-key '()))
|
||||
(avail (vector-ref avail (label->idx label))))
|
||||
(lidx (label->idx label))
|
||||
(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
|
||||
(()
|
||||
;; No matching expressions. Add our expression
|
||||
;; to the equivalence set, if appropriate.
|
||||
(when exp-key
|
||||
(hash-set! equiv-set exp-key (cons label equiv))))
|
||||
((candidate . candidates)
|
||||
;; to the equivalence set, if appropriate. Note
|
||||
;; that expressions that allocate a fresh object
|
||||
;; or change the current fluid environment can't
|
||||
;; be eliminated by CSE (though DCE might do it
|
||||
;; 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))))
|
||||
(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)))
|
||||
;; This expression isn't available here; try
|
||||
|
|
@ -389,25 +438,30 @@ be that both true and false proofs are available."
|
|||
(lp candidates))
|
||||
(else
|
||||
;; Yay, a match. Mark expression as equivalent.
|
||||
(vector-set! equiv-labels (label->idx label)
|
||||
candidate)
|
||||
(vector-set! equiv-labels lidx head)
|
||||
;; If we dominate the successor, mark vars
|
||||
;; for substitution.
|
||||
(when (= label (vector-ref idoms (label->idx k)))
|
||||
(for-each/2
|
||||
(lambda (var subst-var)
|
||||
(vector-set! var-substs (var->idx var) subst-var))
|
||||
(vector-ref defs (label->idx label))
|
||||
(vector-ref defs (label->idx candidate)))))))))))))
|
||||
(vector-ref defs lidx)
|
||||
vars)))))))))))
|
||||
(_ #f))
|
||||
(lp (1+ label))))
|
||||
(values (compute-dom-edges idoms min-label)
|
||||
equiv-labels defs min-label var-substs min-var)))
|
||||
equiv-labels min-label var-substs min-var)))
|
||||
|
||||
(call-with-values (lambda () (compute-label-and-var-ranges fun)) compute))
|
||||
(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))))))
|
||||
|
||||
(define (apply-cse fun dfg
|
||||
doms equiv-labels defs min-label var-substs min-var boolv)
|
||||
doms equiv-labels min-label var-substs min-var boolv)
|
||||
(define (idx->label idx) (+ idx min-label))
|
||||
(define (label->idx label) (- label min-label))
|
||||
(define (idx->var idx) (+ idx min-var))
|
||||
|
|
@ -465,9 +519,9 @@ be that both true and false proofs are available."
|
|||
(_
|
||||
(cond
|
||||
((vector-ref equiv-labels (label->idx label))
|
||||
=> (lambda (equiv)
|
||||
(let* ((eidx (label->idx equiv))
|
||||
(vars (vector-ref defs eidx)))
|
||||
=> (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)))
|
||||
|
|
@ -484,7 +538,7 @@ be that both true and false proofs are available."
|
|||
;; only $values, $call, or $callk can continue to
|
||||
;; $ktail.
|
||||
(_
|
||||
($continue k src ,(visit-exp exp)))))))
|
||||
($continue k src ,(visit-exp exp))))))))
|
||||
(else
|
||||
(build-cps-term
|
||||
($continue k src ,(visit-exp exp))))))))
|
||||
|
|
@ -522,8 +576,8 @@ be that both true and false proofs are available."
|
|||
|
||||
(define (cse fun dfg)
|
||||
(call-with-values (lambda () (compute-equivalent-subexpressions fun dfg))
|
||||
(lambda (doms equiv-labels defs min-label var-substs min-var)
|
||||
(apply-cse fun dfg doms equiv-labels defs min-label var-substs min-var
|
||||
(lambda (doms equiv-labels min-label var-substs min-var)
|
||||
(apply-cse fun dfg doms equiv-labels min-label var-substs min-var
|
||||
(compute-truthy-expressions dfg
|
||||
min-label (vector-length doms))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -45,6 +45,7 @@
|
|||
#:use-module (ice-9 match)
|
||||
#:export (expression-effects
|
||||
compute-effects
|
||||
synthesize-definition-effects!
|
||||
|
||||
&fluid
|
||||
&fluid-environment
|
||||
|
|
@ -211,6 +212,8 @@
|
|||
(zero? (&causes effects)))
|
||||
(define-inlinable (constant? effects)
|
||||
(zero? effects))
|
||||
(define-inlinable (effects-clobber effects)
|
||||
(ash (&causes effects) -1))
|
||||
|
||||
(define-inlinable (depends-on-effects? x effects)
|
||||
(not (zero? (logand (&depends-on x) effects))))
|
||||
|
|
@ -289,7 +292,7 @@
|
|||
((memq x y) (logior (cause &type-check) &car &cdr))
|
||||
((memv x y) (logior (cause &type-check) &car &cdr))
|
||||
((list? arg) &cdr)
|
||||
((length l) (logior (cause &type-check) &car &cdr)))
|
||||
((length l) (logior (cause &type-check) &cdr)))
|
||||
|
||||
;; Vectors.
|
||||
(define-primitive-effects
|
||||
|
|
@ -494,3 +497,41 @@
|
|||
(($ $ktail) &no-effects)))
|
||||
(lp (1+ n))))
|
||||
effects))
|
||||
|
||||
;; There is a way to abuse effects analysis in CSE to also do scalar
|
||||
;; replacement, effectively adding `car' and `cdr' expressions to `cons'
|
||||
;; expressions, and likewise with other constructors and setters. This
|
||||
;; routine adds appropriate effects to `cons' and `set-car!' and the
|
||||
;; like.
|
||||
;;
|
||||
;; This doesn't affect CSE's ability to eliminate expressions, given
|
||||
;; that allocations aren't eliminated anyway, and the new effects will
|
||||
;; just cause the allocations not to commute with e.g. set-car! which
|
||||
;; is what we want anyway.
|
||||
(define* (synthesize-definition-effects! effects dfg min-label #:optional
|
||||
(label-count (vector-length effects)))
|
||||
(define (label->idx label) (- label min-label))
|
||||
(let lp ((label min-label))
|
||||
(when (< label (+ min-label label-count))
|
||||
(let* ((lidx (label->idx label))
|
||||
(fx (vector-ref effects lidx)))
|
||||
(define (add-deps! deps)
|
||||
(vector-set! effects lidx (logior fx deps)))
|
||||
(match (lookup-cont label dfg)
|
||||
(($ $kargs _ _ term)
|
||||
(match (find-expression term)
|
||||
(($ $primcall 'cons)
|
||||
(add-deps! (logior &car &cdr)))
|
||||
(($ $primcall (or 'make-vector 'make-vector/immediate))
|
||||
(add-deps! &vector))
|
||||
(($ $primcall (or 'allocate-struct 'allocate-struct/immediate
|
||||
'make-struct/no-tail 'make-struct))
|
||||
(add-deps! &struct))
|
||||
(($ $primcall 'box)
|
||||
(add-deps! &box))
|
||||
(_
|
||||
(add-deps! (effects-clobber
|
||||
(logior fx &car &cdr &vector &struct &box)))
|
||||
#t)))
|
||||
(_ #t))
|
||||
(lp (1+ label))))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue