mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-02 21:10:27 +02:00
Code Activity

Prepare for CSE bailout propagation

Browse source 
* module/language/cps/cse.scm (compute-available-expressions): Prepare
  for being able to prune joins from bailouts.  Always loop after the
  first iteration.

* module/language/cps/effects-analysis.scm: Remove &possible-bailout.
  Rename &definite-bailout to &bailout, and rename
  &all-effects-but-bailout to &unknown-effects.
This commit is contained in:
Andy Wingo 2014-04-04 13:42:54 +02:00
parent 7a08e47967
commit 780ad383bb
2 changed files with 43 additions and 37 deletions
Download patch file Download diff file Expand all files Collapse all files

38
module/language/cps/cse.scm
View file

@ -88,24 +88,40 @@ index corresponds to MIN-LABEL, and so on."
(out (vector-ref avail-out n))
(fx (vector-ref effects n)))
;; Intersect avail-out from predecessors into "in".
(match (lookup-predecessors (idx->label n) dfg)
(let lp ((preds (lookup-predecessors (idx->label n) dfg))
(initialized? #f))
(match preds
(() #t)
(preds
(bitvector-fill! in #t)
(for-each (lambda (pred)
((pred . preds)
(let ((pred (label->idx pred)))
;; Avoid intersecting back-edges and
;; cross-edges on the first iteration.
(unless (and first? (<= n pred))
(intersect! in (vector-ref avail-out pred)))))
(lookup-predecessors (idx->label n) dfg))))
(cond
((or (and first? (<= n pred))
;; Here it would be nice to avoid intersecting
;; with predecessors that bail out, which might
;; allow expressions from the other (if there's
;; only one) predecessor to propagate past the
;; join. However that would require the tree
;; to be rewritten so that the successor is
;; correctly scoped, and gets the right
;; dominator. Punt for now.
;; (bitvector-ref bailouts 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-but-bailout)
((causes-all-effects? fx &unknown-effects)
;; Fast-path if this expression clobbers the world.
(intersect! out always-avail))
((effect-free? (exclude-effects fx &type-check))
@ -129,7 +145,7 @@ index corresponds to MIN-LABEL, and so on."
(bitvector-set! out n #t))
(lp (1+ n) first? (or changed? (not (= prev-count new-count)))))))
(else
(if changed?
(if (or first? changed?)
(lp 0 #f #f)
avail-in)))))))

38
module/language/cps/effects-analysis.scm
View file

@ -49,8 +49,7 @@
&fluid
&fluid-environment
&prompt
&definite-bailout
&possible-bailout
&bailout
&allocation
&car
&cdr
@ -64,7 +63,7 @@
&no-effects
&all-effects
&all-effects-but-bailout
&unknown-effects
effects-commute?
exclude-effects
@ -121,10 +120,7 @@
;; Indicates that an expression definitely causes a non-local,
;; non-resumable exit -- a bailout. Only used in the "changes" sense.
&definite-bailout
;; Indicates that an expression may cause a bailout.
&possible-bailout
&bailout
;; Indicates that an expression may return a fresh object -- a
;; "causes" effect.
@ -186,8 +182,7 @@
(define-effects &all-effects
&fluid
&prompt
&definite-bailout
&possible-bailout
&bailout
&allocation
&car
&cdr
@ -209,16 +204,12 @@
(define-syntax &no-effects (identifier-syntax 0))
;; Definite bailout is an oddball effect. Since it indicates that an
;; expression definitely causes bailout, it's not in the set of effects
;; of a call to an unknown procedure. At the same time, it's also
;; special in that a definite bailout in a subexpression doesn't always
;; cause an outer expression to include &definite-bailout in its
;; effects. For that reason we have to treat it specially.
;; An expression with unknown effects can cause any effect, except
;; &bailout (which indicates certain bailout).
;;
(define-syntax &all-effects-but-bailout
(define-syntax &unknown-effects
(identifier-syntax
(logand &all-effects (lognot &definite-bailout))))
(logand &all-effects (lognot &bailout))))
(define-inlinable (cause effect)
(ash effect 1))
@ -257,8 +248,7 @@
(begin
(hashq-set! *primitive-effects* 'name
(case-lambda* ((dfg . args) effects)
(_ (logior (cause &possible-bailout)
(cause &definite-bailout)))))
(_ (cause &bailout))))
...))
(define-syntax-rule (define-primitive-effects ((name . args) effects) ...)
@ -304,9 +294,9 @@
;; Bailout.
(define-primitive-effects
((error . _) (logior (cause &definite-bailout) (cause &possible-bailout)))
((scm-error . _) (logior (cause &definite-bailout) (cause &possible-bailout)))
((throw . _) (logior (cause &definite-bailout) (cause &possible-bailout))))
((error . _) (logior (cause &bailout)))
((scm-error . _) (logior (cause &bailout)))
((throw . _) (logior (cause &bailout))))
;; Pairs.
(define-primitive-effects
@ -457,7 +447,7 @@
(let ((proc (hashq-ref *primitive-effects* name)))
(if proc
(apply proc dfg args)
(logior &all-effects-but-bailout (cause &all-effects-but-bailout)))))
(logior &unknown-effects (cause &unknown-effects)))))
(define (expression-effects exp dfg)
(match exp
@ -468,7 +458,7 @@
(($ $prompt)
(cause &prompt))
((or ($ $call) ($ $callk))
(logior &all-effects-but-bailout (cause &all-effects-but-bailout)))
(logior &unknown-effects (cause &unknown-effects)))
(($ $primcall name args)
(primitive-effects dfg name args))))