X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FOccurAnal.lhs;h=ae5c291ef6edb894270342dfd04b748ca7fb2027;hb=893a3c0ad6c39caf71ac28af900733513e1f153e;hp=26d511209dafc0dba0e247d0dbbbd6dbd6f3c18f;hpb=d95ce839533391e7118257537044f01cbb1d6694;p=ghc-hetmet.git diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index 26d5112..ae5c291 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -22,6 +22,8 @@ import CoreFVs import CoreUtils ( exprIsTrivial, isDefaultAlt ) import Coercion ( mkSymCoercion ) import Id +import Name ( localiseName ) +import IdInfo import BasicTypes import VarSet @@ -365,8 +367,9 @@ occAnalRec (CyclicSCC nodes) (body_usage, binds) ---------------------------- -- Now reconstruct the cycle - pairs | no_rules = reOrderCycle tagged_nodes - | otherwise = concatMap reOrderRec (stronglyConnCompFromEdgedVerticesR loop_breaker_edges) + pairs | no_rules = reOrderCycle 0 tagged_nodes [] + | otherwise = foldr (reOrderRec 0) [] $ + stronglyConnCompFromEdgedVerticesR loop_breaker_edges -- See Note [Choosing loop breakers] for looop_breaker_edges loop_breaker_edges = map mk_node tagged_nodes @@ -398,6 +401,11 @@ occAnalRec (CyclicSCC nodes) (body_usage, binds) where new_fvs = extendFvs env emptyVarSet fvs +idRuleRhsVars :: Id -> VarSet +-- Just the variables free on the *rhs* of a rule +-- See Note [Choosing loop breakers] +idRuleRhsVars id = foldr (unionVarSet . ruleRhsFreeVars) emptyVarSet (idCoreRules id) + extendFvs :: IdEnv IdSet -> IdSet -> IdSet -> IdSet -- (extendFVs env fvs s) returns (fvs `union` env(s)) extendFvs env fvs id_set @@ -452,49 +460,62 @@ data Details = ND Id -- Binder IdSet -- Other binders from this Rec group mentioned on RHS -- (derivable from UsageDetails but cached here) -reOrderRec :: SCC (Node Details) - -> [(Id,CoreExpr)] +reOrderRec :: Int -> SCC (Node Details) + -> [(Id,CoreExpr)] -> [(Id,CoreExpr)] -- Sorted into a plausible order. Enough of the Ids have -- IAmALoopBreaker pragmas that there are no loops left. -reOrderRec (AcyclicSCC (ND bndr rhs _ _, _, _)) = [(bndr, rhs)] -reOrderRec (CyclicSCC cycle) = reOrderCycle cycle +reOrderRec _ (AcyclicSCC (ND bndr rhs _ _, _, _)) pairs = (bndr, rhs) : pairs +reOrderRec depth (CyclicSCC cycle) pairs = reOrderCycle depth cycle pairs -reOrderCycle :: [Node Details] -> [(Id,CoreExpr)] -reOrderCycle [] +reOrderCycle :: Int -> [Node Details] -> [(Id,CoreExpr)] -> [(Id,CoreExpr)] +reOrderCycle _ [] _ = panic "reOrderCycle" -reOrderCycle [bind] -- Common case of simple self-recursion - = [(makeLoopBreaker False bndr, rhs)] +reOrderCycle _ [bind] pairs -- Common case of simple self-recursion + = (makeLoopBreaker False bndr, rhs) : pairs where (ND bndr rhs _ _, _, _) = bind -reOrderCycle (bind : binds) +reOrderCycle depth (bind : binds) pairs = -- Choose a loop breaker, mark it no-inline, -- do SCC analysis on the rest, and recursively sort them out - concatMap reOrderRec (stronglyConnCompFromEdgedVerticesR unchosen) ++ - [(makeLoopBreaker False bndr, rhs)] - +-- pprTrace "reOrderCycle" (ppr [b | (ND b _ _ _, _, _) <- bind:binds]) $ + foldr (reOrderRec new_depth) + ([ (makeLoopBreaker False bndr, rhs) + | (ND bndr rhs _ _, _, _) <- chosen_binds] ++ pairs) + (stronglyConnCompFromEdgedVerticesR unchosen) where - (chosen_bind, unchosen) = choose_loop_breaker bind (score bind) [] binds - ND bndr rhs _ _ = chosen_bind + (chosen_binds, unchosen) = choose_loop_breaker [bind] (score bind) [] binds + + approximate_loop_breaker = depth >= 2 + new_depth | approximate_loop_breaker = 0 + | otherwise = depth+1 + -- After two iterations (d=0, d=1) give up + -- and approximate, returning to d=0 -- This loop looks for the bind with the lowest score -- to pick as the loop breaker. The rest accumulate in - choose_loop_breaker (details,_,_) _loop_sc acc [] - = (details, acc) -- Done + choose_loop_breaker loop_binds _loop_sc acc [] + = (loop_binds, acc) -- Done - choose_loop_breaker loop_bind loop_sc acc (bind : binds) + -- If approximate_loop_breaker is True, we pick *all* + -- nodes with lowest score, else just one + -- See Note [Complexity of loop breaking] + choose_loop_breaker loop_binds loop_sc acc (bind : binds) | sc < loop_sc -- Lower score so pick this new one - = choose_loop_breaker bind sc (loop_bind : acc) binds + = choose_loop_breaker [bind] sc (loop_binds ++ acc) binds - | otherwise -- No lower so don't pick it - = choose_loop_breaker loop_bind loop_sc (bind : acc) binds + | approximate_loop_breaker && sc == loop_sc + = choose_loop_breaker (bind : loop_binds) loop_sc acc binds + + | otherwise -- Higher score so don't pick it + = choose_loop_breaker loop_binds loop_sc (bind : acc) binds where sc = score bind score :: Node Details -> Int -- Higher score => less likely to be picked as loop breaker score (ND bndr rhs _ _, _, _) - | isInlineRule (idUnfolding bndr) = 10 - -- Note [INLINE pragmas] + | workerExists (idWorkerInfo bndr) = 10 + -- Note [Worker inline loop] | exprIsTrivial rhs = 5 -- Practically certain to be inlined -- Used to have also: && not (isExportedId bndr) @@ -512,14 +533,34 @@ reOrderCycle (bind : binds) -- so it probably isn't worth the time to test on every binder -- | isNeverActive (idInlinePragma bndr) = -10 - | isOneOcc (idOccInfo bndr) = 1 -- Likely to be inlined + | inlineCandidate bndr rhs = 2 -- Likely to be inlined + -- Note [Inline candidates] - | canUnfold (idUnfolding bndr) = 1 + | not (neverUnfold (idUnfolding bndr)) = 1 -- the Id has some kind of unfolding | otherwise = 0 - -- Checking for a constructor application + inlineCandidate :: Id -> CoreExpr -> Bool + inlineCandidate _ (Note InlineMe _) = True + inlineCandidate id _ = isOneOcc (idOccInfo id) + + -- Note [conapp] + -- + -- It's really really important to inline dictionaries. Real + -- example (the Enum Ordering instance from GHC.Base): + -- + -- rec f = \ x -> case d of (p,q,r) -> p x + -- g = \ x -> case d of (p,q,r) -> q x + -- d = (v, f, g) + -- + -- Here, f and g occur just once; but we can't inline them into d. + -- On the other hand we *could* simplify those case expressions if + -- we didn't stupidly choose d as the loop breaker. + -- But we won't because constructor args are marked "Many". + -- Inlining dictionaries is really essential to unravelling + -- the loops in static numeric dictionaries, see GHC.Float. + -- Cheap and cheerful; the simplifer moves casts out of the way -- The lambda case is important to spot x = /\a. C (f a) -- which comes up when C is a dictionary constructor and @@ -539,6 +580,41 @@ makeLoopBreaker :: Bool -> Id -> Id makeLoopBreaker weak bndr = setIdOccInfo bndr (IAmALoopBreaker weak) \end{code} +Note [Complexity of loop breaking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The loop-breaking algorithm knocks out one binder at a time, and +performs a new SCC analysis on the remaining binders. That can +behave very badly in tightly-coupled groups of bindings; in the +worst case it can be (N**2)*log N, because it does a full SCC +on N, then N-1, then N-2 and so on. + +To avoid this, we switch plans after 2 (or whatever) attempts: + Plan A: pick one binder with the lowest score, make it + a loop breaker, and try again + Plan B: pick *all* binders with the lowest score, make them + all loop breakers, and try again +Since there are only a small finite number of scores, this will +terminate in a constant number of iterations, rather than O(N) +iterations. + +You might thing that it's very unlikely, but RULES make it much +more likely. Here's a real example from Trac #1969: + Rec { $dm = \d.\x. op d + {-# RULES forall d. $dm Int d = $s$dm1 + forall d. $dm Bool d = $s$dm2 #-} + + dInt = MkD .... opInt ... + dInt = MkD .... opBool ... + opInt = $dm dInt + opBool = $dm dBool + + $s$dm1 = \x. op dInt + $s$dm2 = \x. op dBool } +The RULES stuff means that we can't choose $dm as a loop breaker +(Note [Choosing loop breakers]), so we must choose at least (say) +opInt *and* opBool, and so on. The number of loop breakders is +linear in the number of instance declarations. + Note [INLINE pragmas] ~~~~~~~~~~~~~~~~~~~~~ Never choose a function with an INLINE pramga as the loop breaker! @@ -698,6 +774,11 @@ occAnal _ expr@(Lit _) = (emptyDetails, expr) \end{code} \begin{code} +occAnal env (Note InlineMe body) + = case occAnal env body of { (usage, body') -> + (mapVarEnv markMany usage, Note InlineMe body') + } + occAnal env (Note note@(SCC _) body) = case occAnal env body of { (usage, body') -> (mapVarEnv markInsideSCC usage, Note note body') @@ -833,7 +914,7 @@ occAnalApp env (Var fun, args) where fun_uniq = idUnique fun fun_uds = mkOneOcc env fun (valArgCount args > 0) - is_pap = isDataConWorkId fun || valArgCount args < idArity fun + is_pap = isConLikeId fun || valArgCount args < idArity fun -- Hack for build, fold, runST args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args @@ -949,6 +1030,16 @@ us to adjust the OccInfo for 'x' and 'b' as we go. The Maybe (Id,CoreExpr) passed to occAnalAlt is the extra let-binding {x=b}; it's Nothing if the binder-swap doesn't happen. +There is a danger though. Consider + let v = x +# y + in case (f v) of w -> ...v...v... +And suppose that (f v) expands to just v. Then we'd like to +use 'w' instead of 'v' in the alternative. But it may be too +late; we may have substituted the (cheap) x+#y for v in the +same simplifier pass that reduced (f v) to v. + +I think this is just too bad. CSE will recover some of it. + Note [Binder swap on GlobalId scrutinees] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When the scrutinee is a GlobalId we must take care in two ways @@ -962,6 +1053,67 @@ When the scrutinee is a GlobalId we must take care in two ways has an External Name. See, for example, SimplEnv Note [Global Ids in the substitution]. +Historical note [no-case-of-case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We *used* to suppress the binder-swap in case expressoins when +-fno-case-of-case is on. Old remarks: + "This happens in the first simplifier pass, + and enhances full laziness. Here's the bad case: + f = \ y -> ...(case x of I# v -> ...(case x of ...) ... ) + If we eliminate the inner case, we trap it inside the I# v -> arm, + which might prevent some full laziness happening. I've seen this + in action in spectral/cichelli/Prog.hs: + [(m,n) | m <- [1..max], n <- [1..max]] + Hence the check for NoCaseOfCase." +However, now the full-laziness pass itself reverses the binder-swap, so this +check is no longer necessary. + +Historical note [Suppressing the case binder-swap] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This old note describes a problem that is also fixed by doing the +binder-swap in OccAnal: + + There is another situation when it might make sense to suppress the + case-expression binde-swap. If we have + + case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 } + ...other cases .... } + + We'll perform the binder-swap for the outer case, giving + + case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 } + ...other cases .... } + + But there is no point in doing it for the inner case, because w1 can't + be inlined anyway. Furthermore, doing the case-swapping involves + zapping w2's occurrence info (see paragraphs that follow), and that + forces us to bind w2 when doing case merging. So we get + + case x of w1 { A -> let w2 = w1 in e1 + B -> let w2 = w1 in e2 + ...other cases .... } + + This is plain silly in the common case where w2 is dead. + + Even so, I can't see a good way to implement this idea. I tried + not doing the binder-swap if the scrutinee was already evaluated + but that failed big-time: + + data T = MkT !Int + + case v of w { MkT x -> + case x of x1 { I# y1 -> + case x of x2 { I# y2 -> ... + + Notice that because MkT is strict, x is marked "evaluated". But to + eliminate the last case, we must either make sure that x (as well as + x1) has unfolding MkT y1. THe straightforward thing to do is to do + the binder-swap. So this whole note is a no-op. + +It's fixed by doing the binder-swap in OccAnal because we can do the +binder-swap unconditionally and still get occurrence analysis +information right. + Note [Case of cast] ~~~~~~~~~~~~~~~~~~~ Consider case (x `cast` co) of b { I# -> @@ -1002,12 +1154,15 @@ occAnalAlt env case_bndr mb_scrut_var (con, bndrs, rhs) , not (any shadowing bndrs) -- (b) -> (addOneOcc usg_wo_scrut case_bndr NoOccInfo, -- See Note [Case binder usage] for the NoOccInfo - (con, bndrs', Let (NonRec scrut_var' scrut_rhs) rhs')) + (con, bndrs', Let (NonRec scrut_var2 scrut_rhs) rhs')) where - (usg_wo_scrut, scrut_var') = tagBinder alt_usg (localiseId scrut_var) - -- Note the localiseId; we're making a new binding - -- for it, and it might have an External Name, or + scrut_var1 = mkLocalId (localiseName (idName scrut_var)) (idType scrut_var) + -- Localise the scrut_var before shadowing it; we're making a + -- new binding for it, and it might have an External Name, or -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees] + -- Also we don't want any INLILNE or NOINLINE pragmas! + + (usg_wo_scrut, scrut_var2) = tagBinder alt_usg scrut_var1 shadowing bndr = bndr `elemVarSet` rhs_fvs rhs_fvs = exprFreeVars scrut_rhs