From 780ad383bb43d8a1dfcc4da32c48eaac00f8ec14 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 4 Apr 2014 13:42:54 +0200 Subject: [PATCH] Prepare for CSE bailout propagation * 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. --- module/language/cps/cse.scm | 42 ++++++++++++++++-------- module/language/cps/effects-analysis.scm | 38 ++++++++------------- 2 files changed, 43 insertions(+), 37 deletions(-) diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm index 2d1fb95cb..405ccbfed 100644 --- a/module/language/cps/cse.scm +++ b/module/language/cps/cse.scm @@ -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) - (() #t) - (preds - (bitvector-fill! in #t) - (for-each (lambda (pred) - (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)))) + (let lp ((preds (lookup-predecessors (idx->label n) dfg)) + (initialized? #f)) + (match preds + (() #t) + ((pred . preds) + (let ((pred (label->idx pred))) + (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))))))) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index b858edbfa..215ecfb02 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -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))))