X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FOccurAnal.lhs;h=06133d6bdb15a7bfd49ebc035ebf1c001727595f;hp=d33a68ed5792c4159b13d7376e50b87390f4e56d;hb=d9a655dad8e013e41c74dca98fb86c4ed6f29879;hpb=65277a1c9ff86c28c656849d6f6cbb392f1eb3e7 diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index d33a68e..06133d6 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -19,25 +19,27 @@ module OccurAnal ( import CoreSyn import CoreFVs -import Type ( tyVarsOfType ) -import CoreUtils ( exprIsTrivial, isDefaultAlt, mkCoerceI, isExpandableApp ) -import Coercion ( CoercionI(..), mkSymCoI ) +import CoreUtils ( exprIsTrivial, isDefaultAlt, isExpandableApp, mkCoerce ) import Id -import Name ( localiseName ) +import NameEnv +import NameSet +import Name ( Name, localiseName ) import BasicTypes +import Coercion import VarSet import VarEnv +import Var import Maybes ( orElse ) import Digraph ( SCC(..), stronglyConnCompFromEdgedVerticesR ) import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey ) -import Unique ( Unique ) -import UniqFM ( keysUFM, intersectUFM_C, foldUFM_Directly ) +import Unique +import UniqFM import Util ( mapAndUnzip, filterOut ) import Bag import Outputable - +import FastString import Data.List \end{code} @@ -51,16 +53,18 @@ import Data.List Here's the externally-callable interface: \begin{code} -occurAnalysePgm :: [CoreBind] -> [CoreRule] -> [CoreBind] -occurAnalysePgm binds rules - = snd (go initOccEnv binds) +occurAnalysePgm :: Maybe (Activation -> Bool) -> [CoreRule] -> [CoreVect] + -> [CoreBind] -> [CoreBind] +occurAnalysePgm active_rule imp_rules vects binds + = snd (go (initOccEnv active_rule imp_rules) binds) where - initial_details = addIdOccs emptyDetails (rulesFreeVars rules) - -- The RULES keep things alive! + initial_uds = addIdOccs emptyDetails + (rulesFreeVars imp_rules `unionVarSet` vectsFreeVars vects) + -- The RULES and VECTORISE declarations keep things alive! go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind]) go _ [] - = (initial_details, []) + = (initial_uds, []) go env (bind:binds) = (final_usage, bind' ++ binds') where @@ -69,7 +73,11 @@ occurAnalysePgm binds rules occurAnalyseExpr :: CoreExpr -> CoreExpr -- Do occurrence analysis, and discard occurence info returned -occurAnalyseExpr expr = snd (occAnal initOccEnv expr) +occurAnalyseExpr expr + = snd (occAnal (initOccEnv all_active_rules []) expr) + where + -- To be conservative, we say that all inlines and rules are active + all_active_rules = Just (\_ -> True) \end{code} @@ -91,18 +99,20 @@ occAnalBind :: OccEnv -- The incoming OccEnv [CoreBind]) occAnalBind env _ (NonRec binder rhs) body_usage - | isTyVar binder -- A type let; we don't gather usage info + | isTyVar binder -- A type let; we don't gather usage info = (body_usage, [NonRec binder rhs]) | not (binder `usedIn` body_usage) -- It's not mentioned = (body_usage, []) | otherwise -- It's mentioned in the body - = (body_usage' +++ addRuleUsage rhs_usage binder, -- Note [Rules are extra RHSs] - [NonRec tagged_binder rhs']) + = (body_usage' +++ rhs_usage3, [NonRec tagged_binder rhs']) where (body_usage', tagged_binder) = tagBinder body_usage binder - (rhs_usage, rhs') = occAnalRhs env tagged_binder rhs + (rhs_usage1, rhs') = occAnalRhs env (Just tagged_binder) rhs + rhs_usage2 = addIdOccs rhs_usage1 (idUnfoldingVars binder) + rhs_usage3 = addIdOccs rhs_usage2 (idRuleVars binder) + -- See Note [Rules are extra RHSs] and Note [Rule dependency info] \end{code} Note [Dead code] @@ -154,13 +164,17 @@ However things are made quite a bit more complicated by RULES. Remember To that end, we build a Rec group for each cyclic strongly connected component, *treating f's rules as extra RHSs for 'f'*. - - When we make the Rec groups we include variables free in *either* - LHS *or* RHS of the rule. The former might seems silly, but see - Note [Rule dependency info]. - - So in Example [eftInt], eftInt and eftIntFB will be put in the - same Rec, even though their 'main' RHSs are both non-recursive. + More concretely, the SCC analysis runs on a graph with an edge + from f -> g iff g is mentioned in + (a) f's rhs + (b) f's RULES + These are rec_edges. + + Under (b) we include variables free in *either* LHS *or* RHS of + the rule. The former might seems silly, but see Note [Rule + dependency info]. So in Example [eftInt], eftInt and eftIntFB + will be put in the same Rec, even though their 'main' RHSs are + both non-recursive. * Note [Rules are visible in their own rec group] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -184,7 +198,7 @@ However things are made quite a bit more complicated by RULES. Remember [Rules for recursive functions] in Simplify.lhs Hence, if - f's RHS mentions g, and + f's RHS (or its INLINE template if it has one) mentions g, and g has a RULE that mentions h, and h has a RULE that mentions f @@ -193,11 +207,20 @@ However things are made quite a bit more complicated by RULES. Remember reachable by RULES from those starting points. That is the whole reason for computing rule_fv_env in occAnalBind. (Of course we only consider free vars that are also binders in this Rec group.) + See also Note [Finding rule RHS free vars] Note that when we compute this rule_fv_env, we only consider variables free in the *RHS* of the rule, in contrast to the way we build the Rec group in the first place (Note [Rule dependency info]) + Note that if 'g' has RHS that mentions 'w', we should add w to + g's loop-breaker edges. More concretely there is an edge from f -> g + iff + (a) g is mentioned in f's RHS + (b) h is mentioned in f's RHS, and + g appears in the RHS of a RULE of h + or a transitive sequence of rules starting with h + Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is chosen as a loop breaker, because their RHSs don't mention each other. And indeed both can be inlined safely. @@ -208,7 +231,23 @@ However things are made quite a bit more complicated by RULES. Remember rec_edges for the Rec block analysis loop_breaker_edges for the loop breaker analysis - + * Note [Finding rule RHS free vars] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Consider this real example from Data Parallel Haskell + tagZero :: Array Int -> Array Tag + {-# INLINE [1] tagZeroes #-} + tagZero xs = pmap (\x -> fromBool (x==0)) xs + + {-# RULES "tagZero" [~1] forall xs n. + pmap fromBool = tagZero xs #-} + So tagZero's RHS mentions pmap, and pmap's RULE mentions tagZero. + However, tagZero can only be inlined in phase 1 and later, while + the RULE is only active *before* phase 1. So there's no problem. + + To make this work, we look for the RHS free vars only for + *active* rules. That's the reason for the is_active argument + to idRhsRuleVars, and the occ_rule_act field of the OccEnv. + * Note [Weak loop breakers] ~~~~~~~~~~~~~~~~~~~~~~~~~ There is a last nasty wrinkle. Suppose we have @@ -221,7 +260,7 @@ However things are made quite a bit more complicated by RULES. Remember ...more... } - Remmber that we simplify the RULES before any RHS (see Note + Remember that we simplify the RULES before any RHS (see Note [Rules are visible in their own rec group] above). So we must *not* postInlineUnconditionally 'g', even though @@ -246,7 +285,7 @@ However things are made quite a bit more complicated by RULES. Remember ~~~~~~~~~~~~~~~~~~~~~~~~~~~ The VarSet in a SpecInfo is used for dependency analysis in the occurrence analyser. We must track free vars in *both* lhs and rhs. - Hence use of idRuleVars, rather than idRuleRhsVars in addRuleUsage. + Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind. Why both? Consider x = y RULE f x = 4 @@ -261,6 +300,35 @@ However things are made quite a bit more complicated by RULES. Remember at the same time as the regular RHS of the function, so it should be treated *exactly* like an extra RHS. + There is a danger that we'll be sub-optimal if we see this + f = ...f... + [INLINE f = ..no f...] + where f is recursive, but the INLINE is not. This can just about + happen with a sufficiently odd set of rules; eg + + foo :: Int -> Int + {-# INLINE [1] foo #-} + foo x = x+1 + + bar :: Int -> Int + {-# INLINE [1] bar #-} + bar x = foo x + 1 + + {-# RULES "foo" [~1] forall x. foo x = bar x #-} + + Here the RULE makes bar recursive; but it's INLINE pragma remains + non-recursive. It's tempting to then say that 'bar' should not be + a loop breaker, but an attempt to do so goes wrong in two ways: + a) We may get + $df = ...$cfoo... + $cfoo = ...$df.... + [INLINE $cfoo = ...no-$df...] + But we want $cfoo to depend on $df explicitly so that we + put the bindings in the right order to inline $df in $cfoo + and perhaps break the loop altogether. (Maybe this + b) + + Example [eftInt] ~~~~~~~~~~~~~~~ @@ -298,7 +366,7 @@ This showed up when compiling Control.Concurrent.Chan.getChanContents. \begin{code} occAnalBind _ env (Rec pairs) body_usage - = foldr occAnalRec (body_usage, []) sccs + = foldr (occAnalRec env) (body_usage, []) sccs -- For a recursive group, we -- * occ-analyse all the RHSs -- * compute strongly-connected components @@ -314,12 +382,21 @@ occAnalBind _ env (Rec pairs) body_usage rec_edges = {-# SCC "occAnalBind.assoc" #-} map make_node pairs make_node (bndr, rhs) - = (ND bndr rhs' all_rhs_usage rhs_fvs, idUnique bndr, out_edges) - where - (rhs_usage, rhs') = occAnalRhs env bndr rhs - all_rhs_usage = addRuleUsage rhs_usage bndr -- Note [Rules are extra RHSs] - rhs_fvs = intersectUFM_C (\b _ -> b) bndr_set rhs_usage - out_edges = keysUFM (rhs_fvs `unionVarSet` idRuleVars bndr) + = (details, varUnique bndr, keysUFM out_edges) + where + details = ND { nd_bndr = bndr, nd_rhs = rhs' + , nd_uds = rhs_usage3, nd_inl = inl_fvs} + + (rhs_usage1, rhs') = occAnalRhs env Nothing rhs + rhs_usage2 = addIdOccs rhs_usage1 rule_fvs -- Note [Rules are extra RHSs] + rhs_usage3 = addIdOccs rhs_usage2 unf_fvs + unf = realIdUnfolding bndr -- Ignore any current loop-breaker flag + unf_fvs = stableUnfoldingVars unf + rule_fvs = idRuleVars bndr -- See Note [Rule dependency info] + + inl_fvs = rhs_fvs `unionVarSet` unf_fvs + rhs_fvs = intersectUFM_C (\b _ -> b) bndr_set rhs_usage1 + out_edges = intersectUFM_C (\b _ -> b) bndr_set rhs_usage3 -- (a -> b) means a mentions b -- Given the usage details (a UFM that gives occ info for each free var of -- the RHS) we can get the list of free vars -- or rather their Int keys -- @@ -331,11 +408,13 @@ occAnalBind _ env (Rec pairs) body_usage -- consumed 10% of total runtime! ----------------------------- -occAnalRec :: SCC (Node Details) -> (UsageDetails, [CoreBind]) - -> (UsageDetails, [CoreBind]) +occAnalRec :: OccEnv -> SCC (Node Details) + -> (UsageDetails, [CoreBind]) + -> (UsageDetails, [CoreBind]) -- The NonRec case is just like a Let (NonRec ...) above -occAnalRec (AcyclicSCC (ND bndr rhs rhs_usage _, _, _)) (body_usage, binds) +occAnalRec _ (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs, nd_uds = rhs_usage}, _, _)) + (body_usage, binds) | not (bndr `usedIn` body_usage) = (body_usage, binds) @@ -348,7 +427,7 @@ occAnalRec (AcyclicSCC (ND bndr rhs rhs_usage _, _, _)) (body_usage, binds) -- The Rec case is the interesting one -- See Note [Loop breaking] -occAnalRec (CyclicSCC nodes) (body_usage, binds) +occAnalRec env (CyclicSCC nodes) (body_usage, binds) | not (any (`usedIn` body_usage) bndrs) -- NB: look at body_usage, not total_usage = (body_usage, binds) -- Dead code @@ -356,13 +435,15 @@ occAnalRec (CyclicSCC nodes) (body_usage, binds) = (final_usage, Rec pairs : binds) where - bndrs = [b | (ND b _ _ _, _, _) <- nodes] + bndrs = [b | (ND { nd_bndr = b }, _, _) <- nodes] bndr_set = mkVarSet bndrs + non_boring bndr = isId bndr && + (isStableUnfolding (realIdUnfolding bndr) || idHasRules bndr) ---------------------------- -- Tag the binders with their occurrence info total_usage = foldl add_usage body_usage nodes - add_usage usage_so_far (ND _ _ rhs_usage _, _, _) = usage_so_far +++ rhs_usage + add_usage usage_so_far (ND { nd_uds = rhs_usage }, _, _) = usage_so_far +++ rhs_usage (final_usage, tagged_nodes) = mapAccumL tag_node total_usage nodes tag_node :: UsageDetails -> Node Details -> (UsageDetails, Node Details) @@ -371,8 +452,8 @@ occAnalRec (CyclicSCC nodes) (body_usage, binds) -- saying "no preInlineUnconditionally" if it is used -- in any rule (lhs or rhs) of the recursive group -- See Note [Weak loop breakers] - tag_node usage (ND bndr rhs rhs_usage rhs_fvs, k, ks) - = (usage `delVarEnv` bndr, (ND bndr2 rhs rhs_usage rhs_fvs, k, ks)) + tag_node usage (details@ND { nd_bndr = bndr }, k, ks) + = (usage `delVarEnv` bndr, (details { nd_bndr = bndr2 }, k, ks)) where bndr2 | bndr `elemVarSet` all_rule_fvs = makeLoopBreaker True bndr1 | otherwise = bndr1 @@ -382,49 +463,32 @@ occAnalRec (CyclicSCC nodes) (body_usage, binds) ---------------------------- -- Now reconstruct the cycle - pairs | no_rules = reOrderCycle 0 tagged_nodes [] - | otherwise = foldr (reOrderRec 0) [] $ - stronglyConnCompFromEdgedVerticesR loop_breaker_edges + pairs | any non_boring bndrs + = foldr (reOrderRec 0) [] $ + stronglyConnCompFromEdgedVerticesR loop_breaker_edges + | otherwise + = reOrderCycle 0 tagged_nodes [] -- See Note [Choosing loop breakers] for loop_breaker_edges loop_breaker_edges = map mk_node tagged_nodes - mk_node (details@(ND _ _ _ rhs_fvs), k, _) = (details, k, new_ks) + mk_node (details@(ND { nd_inl = inl_fvs }), k, _) = (details, k, new_ks) where - new_ks = keysUFM (extendFvs rule_fv_env rhs_fvs rhs_fvs) + new_ks = keysUFM (fst (extendFvs rule_fv_env inl_fvs)) ------------------------------------ rule_fv_env :: IdEnv IdSet -- Variables from this group mentioned in RHS of rules -- Domain is *subset* of bound vars (others have no rule fvs) - rule_fv_env = rule_loop init_rule_fvs - - no_rules = null init_rule_fvs - init_rule_fvs = [(b, rule_fvs) - | b <- bndrs - , let rule_fvs = idRuleRhsVars b `intersectVarSet` bndr_set - , not (isEmptyVarSet rule_fvs)] - - rule_loop :: [(Id,IdSet)] -> IdEnv IdSet -- Finds fixpoint - rule_loop fv_list - | no_change = env - | otherwise = rule_loop new_fv_list - where - env = mkVarEnv init_rule_fvs - (no_change, new_fv_list) = mapAccumL bump True fv_list - bump no_change (b,fvs) - | new_fvs `subVarSet` fvs = (no_change, (b,fvs)) - | otherwise = (False, (b,new_fvs `unionVarSet` fvs)) - where - new_fvs = extendFvs env emptyVarSet fvs - -extendFvs :: IdEnv IdSet -> IdSet -> IdSet -> IdSet --- (extendFVs env fvs s) returns (fvs `union` env(s)) -extendFvs env fvs id_set - = foldUFM_Directly add fvs id_set - where - add uniq _ fvs - = case lookupVarEnv_Directly env uniq of - Just fvs' -> fvs' `unionVarSet` fvs - Nothing -> fvs + rule_fv_env = transClosureFV init_rule_fvs + init_rule_fvs + | Just is_active <- occ_rule_act env -- See Note [Finding rule RHS free vars] + = [ (b, rule_fvs) + | b <- bndrs + , isId b + , let rule_fvs = idRuleRhsVars is_active b + `intersectVarSet` bndr_set + , not (isEmptyVarSet rule_fvs)] + | otherwise + = [] \end{code} @reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic @@ -464,39 +528,41 @@ Perhaps something cleverer would suffice. \begin{code} type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique, -- which is gotten from the Id. -data Details = ND Id -- Binder - CoreExpr -- RHS +data Details + = ND { nd_bndr :: Id -- Binder + , nd_rhs :: CoreExpr -- RHS - UsageDetails -- Full usage from RHS, - -- including *both* RULES *and* InlineRule unfolding + , nd_uds :: UsageDetails -- Usage from RHS, + -- including RULES and InlineRule unfolding - IdSet -- Other binders *from this Rec group* mentioned in - -- * the RHS - -- * any InlineRule unfolding - -- but *excluding* any RULES + , nd_inl :: IdSet -- Other binders *from this Rec group* mentioned in + } -- its InlineRule unfolding (if present) + -- AND the RHS + -- but *excluding* any RULES + -- This is the IdSet that may be used if the Id is inlined 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 _ _, _, _)) pairs = (bndr, rhs) : pairs -reOrderRec depth (CyclicSCC cycle) pairs = reOrderCycle depth cycle pairs +reOrderRec _ (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs }, _, _)) + pairs = (bndr, rhs) : pairs +reOrderRec depth (CyclicSCC cycle) pairs = reOrderCycle depth cycle pairs reOrderCycle :: Int -> [Node Details] -> [(Id,CoreExpr)] -> [(Id,CoreExpr)] reOrderCycle _ [] _ = panic "reOrderCycle" -reOrderCycle _ [bind] pairs -- Common case of simple self-recursion - = (makeLoopBreaker False bndr, rhs) : pairs - where - (ND bndr rhs _ _, _, _) = bind +reOrderCycle _ [(ND { nd_bndr = bndr, nd_rhs = rhs }, _, _)] pairs + = -- Common case of simple self-recursion + (makeLoopBreaker False bndr, rhs) : pairs reOrderCycle depth (bind : binds) pairs = -- Choose a loop breaker, mark it no-inline, -- do SCC analysis on the rest, and recursively sort them out --- pprTrace "reOrderCycle" (ppr [b | (ND b _ _ _, _, _) <- bind:binds]) $ +-- pprTrace "reOrderCycle" (ppr [b | (ND { nd_bndr = b }, _, _) <- bind:binds]) $ foldr (reOrderRec new_depth) ([ (makeLoopBreaker False bndr, rhs) - | (ND bndr rhs _ _, _, _) <- chosen_binds] ++ pairs) + | (ND { nd_bndr = bndr, nd_rhs = rhs }, _, _) <- chosen_binds] ++ pairs) (stronglyConnCompFromEdgedVerticesR unchosen) where (chosen_binds, unchosen) = choose_loop_breaker [bind] (score bind) [] binds @@ -528,11 +594,13 @@ reOrderCycle depth (bind : binds) pairs sc = score bind score :: Node Details -> Int -- Higher score => less likely to be picked as loop breaker - score (ND bndr rhs _ _, _, _) + score (ND { nd_bndr = bndr, nd_rhs = rhs }, _, _) + | not (isId bndr) = 100 -- A type or cercion variable is never a loop breaker + | isDFunId bndr = 9 -- Never choose a DFun as a loop breaker -- Note [DFuns should not be loop breakers] - | Just (inl_source, _) <- isInlineRule_maybe (idUnfolding bndr) + | Just inl_source <- isStableCoreUnfolding_maybe (idUnfolding bndr) = case inl_source of InlineWrapper {} -> 10 -- Note [INLINE pragmas] _other -> 3 -- Data structures are more important than this @@ -582,7 +650,8 @@ reOrderCycle depth (bind : binds) pairs makeLoopBreaker :: Bool -> Id -> Id -- Set the loop-breaker flag: see Note [Weak loop breakers] -makeLoopBreaker weak bndr = setIdOccInfo bndr (IAmALoopBreaker weak) +makeLoopBreaker weak bndr + = ASSERT2( isId bndr, ppr bndr ) setIdOccInfo bndr (IAmALoopBreaker weak) \end{code} Note [Complexity of loop breaking] @@ -723,46 +792,27 @@ ToDo: try using the occurrence info for the inline'd binder. \begin{code} occAnalRhs :: OccEnv - -> Id -> CoreExpr -- Binder and rhs - -- For non-recs the binder is alrady tagged - -- with occurrence info + -> Maybe Id -> CoreExpr -- Binder and rhs + -- Just b => non-rec, and alrady tagged with occurrence info + -- Nothing => Rec, no occ info -> (UsageDetails, CoreExpr) - -- Returned usage details includes any INLINE rhs - -occAnalRhs env id rhs - = (addIdOccs rhs_usage (idUnfoldingVars id), rhs') - -- Include occurrences for the "extra RHS" from a CoreUnfolding + -- Returned usage details covers only the RHS, + -- and *not* the RULE or INLINE template for the Id +occAnalRhs env mb_bndr rhs + = occAnal ctxt rhs where - (rhs_usage, rhs') = occAnal ctxt rhs - ctxt | certainly_inline id = env - | otherwise = rhsCtxt env - -- Note that we generally use an rhsCtxt. This tells the occ anal n - -- that it's looking at an RHS, which has an effect in occAnalApp - -- - -- But there's a problem. Consider - -- x1 = a0 : [] - -- x2 = a1 : x1 - -- x3 = a2 : x2 - -- g = f x3 - -- First time round, it looks as if x1 and x2 occur as an arg of a - -- let-bound constructor ==> give them a many-occurrence. - -- But then x3 is inlined (unconditionally as it happens) and - -- next time round, x2 will be, and the next time round x1 will be - -- Result: multiple simplifier iterations. Sigh. - -- Crude solution: use rhsCtxt for things that occur just once... - - certainly_inline id = case idOccInfo id of - OneOcc in_lam one_br _ -> not in_lam && one_br - _ -> False -\end{code} - - - -\begin{code} -addRuleUsage :: UsageDetails -> Id -> UsageDetails --- Add the usage from RULES in Id to the usage -addRuleUsage usage id = addIdOccs usage (idRuleVars id) - -- idRuleVars here: see Note [Rule dependency info] + -- See Note [Cascading inlines] + ctxt = case mb_bndr of + Just b | certainly_inline b -> env + _other -> rhsCtxt env + + certainly_inline bndr -- See Note [Cascading inlines] + = case idOccInfo bndr of + OneOcc in_lam one_br _ -> not in_lam && one_br && active && not_stable + _ -> False + where + active = isAlwaysActive (idInlineActivation bndr) + not_stable = not (isStableUnfolding (idUnfolding bndr)) addIdOccs :: UsageDetails -> VarSet -> UsageDetails addIdOccs usage id_set = foldVarSet add usage id_set @@ -776,6 +826,46 @@ addIdOccs usage id_set = foldVarSet add usage id_set -- (Same goes for INLINE.) \end{code} +Note [Cascading inlines] +~~~~~~~~~~~~~~~~~~~~~~~~ +By default we use an rhsCtxt for the RHS of a binding. This tells the +occ anal n that it's looking at an RHS, which has an effect in +occAnalApp. In particular, for constructor applications, it makes +the arguments appear to have NoOccInfo, so that we don't inline into +them. Thus x = f y + k = Just x +we do not want to inline x. + +But there's a problem. Consider + x1 = a0 : [] + x2 = a1 : x1 + x3 = a2 : x2 + g = f x3 +First time round, it looks as if x1 and x2 occur as an arg of a +let-bound constructor ==> give them a many-occurrence. +But then x3 is inlined (unconditionally as it happens) and +next time round, x2 will be, and the next time round x1 will be +Result: multiple simplifier iterations. Sigh. + +So, when analysing the RHS of x3 we notice that x3 will itself +definitely inline the next time round, and so we analyse x3's rhs in +an ordinary context, not rhsCtxt. Hence the "certainly_inline" stuff. + +Annoyingly, we have to approximiate SimplUtils.preInlineUnconditionally. +If we say "yes" when preInlineUnconditionally says "no" the simplifier iterates +indefinitely: + x = f y + k = Just x +inline ==> + k = Just (f y) +float ==> + x1 = f y + k = Just x1 + +This is worse than the slow cascade, so we only want to say "certainly_inline" +if it really is certain. Look at the note with preInlineUnconditionally +for the various clauses. + Expressions ~~~~~~~~~~~ \begin{code} @@ -784,33 +874,27 @@ occAnal :: OccEnv -> (UsageDetails, -- Gives info only about the "interesting" Ids CoreExpr) -occAnal _ (Type t) = (emptyDetails, Type t) -occAnal env (Var v) = (mkOneOcc env v False, Var v) +occAnal _ expr@(Type _) = (emptyDetails, expr) +occAnal _ expr@(Lit _) = (emptyDetails, expr) +occAnal env expr@(Var v) = (mkOneOcc env v False, expr) -- At one stage, I gathered the idRuleVars for v here too, -- which in a way is the right thing to do. -- But that went wrong right after specialisation, when -- the *occurrences* of the overloaded function didn't have any -- rules in them, so the *specialised* versions looked as if they -- weren't used at all. -\end{code} - -We regard variables that occur as constructor arguments as "dangerousToDup": - -\begin{verbatim} -module A where -f x = let y = expensive x in - let z = (True,y) in - (case z of {(p,q)->q}, case z of {(p,q)->q}) -\end{verbatim} -We feel free to duplicate the WHNF (True,y), but that means -that y may be duplicated thereby. +occAnal _ (Coercion co) + = (addIdOccs emptyDetails (coVarsOfCo co), Coercion co) + -- See Note [Gather occurrences of coercion veriables] +\end{code} -If we aren't careful we duplicate the (expensive x) call! -Constructors are rather like lambdas in this way. +Note [Gather occurrences of coercion veriables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to gather info about what coercion variables appear, so that +we can sort them into the right place when doing dependency analysis. \begin{code} -occAnal _ expr@(Lit _) = (emptyDetails, expr) \end{code} \begin{code} @@ -826,7 +910,10 @@ occAnal env (Note note body) occAnal env (Cast expr co) = case occAnal env expr of { (usage, expr') -> - (markRhsUds env True usage, Cast expr' co) + let usage1 = markManyIf (isRhsEnv env) usage + usage2 = addIdOccs usage1 (coVarsOfCo co) + -- See Note [Gather occurrences of coercion veriables] + in (usage2, Cast expr' co) -- If we see let x = y `cast` co -- then mark y as 'Many' so that we don't -- immediately inline y again. @@ -933,6 +1020,18 @@ occAnalArgs env args Applications are dealt with specially because we want the "build hack" to work. +Note [Arguments of let-bound constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = let y = expensive x in + let z = (True,y) in + (case z of {(p,q)->q}, case z of {(p,q)->q}) +We feel free to duplicate the WHNF (True,y), but that means +that y may be duplicated thereby. + +If we aren't careful we duplicate the (expensive x) call! +Constructors are rather like lambdas in this way. + \begin{code} occAnalApp :: OccEnv -> (Expr CoreBndr, [Arg CoreBndr]) @@ -940,7 +1039,15 @@ occAnalApp :: OccEnv occAnalApp env (Var fun, args) = case args_stuff of { (args_uds, args') -> let - final_args_uds = markRhsUds env is_exp args_uds + final_args_uds = markManyIf (isRhsEnv env && is_exp) args_uds + -- We mark the free vars of the argument of a constructor or PAP + -- as "many", if it is the RHS of a let(rec). + -- This means that nothing gets inlined into a constructor argument + -- position, which is what we want. Typically those constructor + -- arguments are just variables, or trivial expressions. + -- + -- This is the *whole point* of the isRhsEnv predicate + -- See Note [Arguments of let-bound constructors] in (fun_uds +++ final_args_uds, mkApps (Var fun) args') } where @@ -981,21 +1088,11 @@ occAnalApp env (fun, args) (final_uds, mkApps fun' args') }} -markRhsUds :: OccEnv -- Check if this is a RhsEnv - -> Bool -- and this is true - -> UsageDetails -- The do markMany on this +markManyIf :: Bool -- If this is true + -> UsageDetails -- Then do markMany on this -> UsageDetails --- We mark the free vars of the argument of a constructor or PAP --- as "many", if it is the RHS of a let(rec). --- This means that nothing gets inlined into a constructor argument --- position, which is what we want. Typically those constructor --- arguments are just variables, or trivial expressions. --- --- This is the *whole point* of the isRhsEnv predicate -markRhsUds env is_pap arg_uds - | isRhsEnv env && is_pap = mapVarEnv markMany arg_uds - | otherwise = arg_uds - +markManyIf True uds = mapVarEnv markMany uds +markManyIf False uds = uds appSpecial :: OccEnv -> Int -> CtxtTy -- Argument number, and context to use for it @@ -1061,7 +1158,7 @@ wrapProxy (bndr, rhs_var, co) (body_usg, body) where (body_usg', tagged_bndr) = tagBinder body_usg bndr rhs_usg = unitVarEnv rhs_var NoOccInfo -- We don't need exact info - rhs = mkCoerceI co (Var rhs_var) + rhs = mkCoerce co (Var (zapIdOccInfo rhs_var)) -- See Note [Zap case binders in proxy bindings] \end{code} @@ -1073,9 +1170,13 @@ wrapProxy (bndr, rhs_var, co) (body_usg, body) \begin{code} data OccEnv - = OccEnv { occ_encl :: !OccEncl -- Enclosing context information - , occ_ctxt :: !CtxtTy -- Tells about linearity - , occ_proxy :: ProxyEnv } + = OccEnv { occ_encl :: !OccEncl -- Enclosing context information + , occ_ctxt :: !CtxtTy -- Tells about linearity + , occ_proxy :: ProxyEnv + , occ_rule_fvs :: ImpRuleUsage + , occ_rule_act :: Maybe (Activation -> Bool) -- Nothing => Rules are inactive + -- See Note [Finding rule RHS free vars] + } ----------------------------- @@ -1093,6 +1194,10 @@ data OccEncl | OccVanilla -- Argument of function, body of lambda, scruintee of case etc. -- Do inline into constructor args here +instance Outputable OccEncl where + ppr OccRhs = ptext (sLit "occRhs") + ppr OccVanilla = ptext (sLit "occVanilla") + type CtxtTy = [Bool] -- [] No info -- @@ -1103,19 +1208,20 @@ type CtxtTy = [Bool] -- be applied many times; but when it is, -- the CtxtTy inside applies -initOccEnv :: OccEnv -initOccEnv = OccEnv { occ_encl = OccVanilla - , occ_ctxt = [] - , occ_proxy = PE emptyVarEnv emptyVarSet } +initOccEnv :: Maybe (Activation -> Bool) -> [CoreRule] + -> OccEnv +initOccEnv active_rule imp_rules + = OccEnv { occ_encl = OccVanilla + , occ_ctxt = [] + , occ_proxy = PE emptyVarEnv emptyVarSet + , occ_rule_fvs = findImpRuleUsage active_rule imp_rules + , occ_rule_act = active_rule } vanillaCtxt :: OccEnv -> OccEnv -vanillaCtxt env = OccEnv { occ_encl = OccVanilla - , occ_ctxt = [] - , occ_proxy = occ_proxy env } +vanillaCtxt env = env { occ_encl = OccVanilla, occ_ctxt = [] } rhsCtxt :: OccEnv -> OccEnv -rhsCtxt env = OccEnv { occ_encl = OccRhs, occ_ctxt = [] - , occ_proxy = occ_proxy env } +rhsCtxt env = env { occ_encl = OccRhs, occ_ctxt = [] } setCtxtTy :: OccEnv -> CtxtTy -> OccEnv setCtxtTy env ctxt = env { occ_ctxt = ctxt } @@ -1150,14 +1256,119 @@ addAppCtxt env@(OccEnv { occ_ctxt = ctxt }) args %************************************************************************ %* * + ImpRuleUsage +%* * +%************************************************************************ + +\begin{code} +type ImpRuleUsage = NameEnv UsageDetails + -- Maps an *imported* Id f to the UsageDetails for *local* Ids + -- used on the RHS for a *local* rule for f. +\end{code} + +Note [ImpRuleUsage] +~~~~~~~~~~~~~~~~ +Consider this, where A.g is an imported Id + + f x = A.g x + {-# RULE "foo" forall x. A.g x = f x #-} + +Obviously there's a loop, but the danger is that the occurrence analyser +will say that 'f' is not a loop breaker. Then the simplifier will +optimise 'f' to + f x = f x +and then gaily inline 'f'. Result infinite loop. More realistically, +these kind of rules are generated when specialising imported INLINABLE Ids. + +Solution: treat an occurrence of A.g as an occurrence of all the local Ids +that occur on the RULE's RHS. This mapping from imported Id to local Ids +is held in occ_rule_fvs. + +\begin{code} +findImpRuleUsage :: Maybe (Activation -> Bool) -> [CoreRule] -> ImpRuleUsage +-- Find the *local* Ids that can be reached transitively, +-- via local rules, from each *imported* Id. +-- Sigh: this function seems more complicated than it is really worth +findImpRuleUsage Nothing _ = emptyNameEnv +findImpRuleUsage (Just is_active) rules + = mkNameEnv [ (f, mapUFM (\_ -> NoOccInfo) ls) + | f <- rule_names + , let ls = find_lcl_deps f + , not (isEmptyVarSet ls) ] + where + rule_names = map ru_fn rules + rule_name_set = mkNameSet rule_names + + imp_deps :: NameEnv VarSet + -- (f,g) means imported Id 'g' appears in RHS of + -- rule for imported Id 'f', *or* does so transitively + imp_deps = foldr add_imp emptyNameEnv rules + add_imp rule acc + | is_active (ruleActivation rule) + = extendNameEnv_C unionVarSet acc (ru_fn rule) + (exprSomeFreeVars keep_imp (ru_rhs rule)) + | otherwise = acc + keep_imp v = isId v && (idName v `elemNameSet` rule_name_set) + full_imp_deps = transClosureFV (ufmToList imp_deps) + + lcl_deps :: NameEnv VarSet + -- (f, l) means localId 'l' appears immediately + -- in the RHS of a rule for imported Id 'f' + -- Remember, many rules might have the same ru_fn + -- so we do need to fold + lcl_deps = foldr add_lcl emptyNameEnv rules + add_lcl rule acc = extendNameEnv_C unionVarSet acc (ru_fn rule) + (exprFreeIds (ru_rhs rule)) + + find_lcl_deps :: Name -> VarSet + find_lcl_deps f + = foldVarSet (unionVarSet . lookup_lcl . idName) (lookup_lcl f) + (lookupNameEnv full_imp_deps f `orElse` emptyVarSet) + lookup_lcl :: Name -> VarSet + lookup_lcl g = lookupNameEnv lcl_deps g `orElse` emptyVarSet + +------------- +transClosureFV :: Uniquable a => [(a, VarSet)] -> UniqFM VarSet +-- If (f,g), (g,h) are in the input, then (f,h) is in the output +transClosureFV fv_list + | no_change = env + | otherwise = transClosureFV new_fv_list + where + env = listToUFM fv_list + (no_change, new_fv_list) = mapAccumL bump True fv_list + bump no_change (b,fvs) + | no_change_here = (no_change, (b,fvs)) + | otherwise = (False, (b,new_fvs)) + where + (new_fvs, no_change_here) = extendFvs env fvs + +------------- +extendFvs :: UniqFM VarSet -> VarSet -> (VarSet, Bool) +-- (extendFVs env s) returns +-- (s `union` env(s), env(s) `subset` s) +extendFvs env s + = foldVarSet add (s, True) s + where + add v (vs, no_change_so_far) + = case lookupUFM env v of + Just fvs | not (fvs `subVarSet` s) + -> (vs `unionVarSet` fvs, False) + _ -> (vs, no_change_so_far) +\end{code} + + +%************************************************************************ +%* * ProxyEnv %* * %************************************************************************ \begin{code} -data ProxyEnv - = PE (IdEnv (Id, [(Id,CoercionI)])) VarSet - -- Main env, and its free variables (of both range and domain) +data ProxyEnv -- See Note [ProxyEnv] + = PE (IdEnv -- Domain = scrutinee variables + (Id, -- The scrutinee variable again + [(Id,Coercion)])) -- The case binders that it maps to + VarSet -- Free variables of both range and domain \end{code} Note [ProxyEnv] @@ -1180,7 +1391,7 @@ Things to note: element without losing correctness. And we do so when pushing it inside a binding (see trimProxyEnv). - * Once scrutinee might map to many case binders: Eg + * One scrutinee might map to many case binders: Eg case sc of cb1 { DEFAULT -> ....case sc of cb2 { ... } .. } INVARIANTS @@ -1194,14 +1405,16 @@ INVARIANTS The Main Reason for having a ProxyEnv is so that when we encounter case e of cb { pi -> ri } we can find all the in-scope variables derivable from 'cb', -and effectively add let-bindings for them thus: +and effectively add let-bindings for them (or at least for the +ones *mentioned* in ri) thus: case e of cb { pi -> let { x = ..cb..; y = ...cb.. } in ri } +In this way we'll replace occurrences of 'x', 'y' with 'cb', +which implements the Binder-swap idea (see Note [Binder swap]) + The function getProxies finds these bindings; then we add just the necessary ones, using wrapProxy. -More info under Note [Binder swap] - Note [Binder swap] ~~~~~~~~~~~~~~~~~~ We do these two transformations right here: @@ -1298,6 +1511,17 @@ From this we want to extract the bindings Notice that later bindings may mention earlier ones, and that we need to go "both ways". +Note [Zap case binders in proxy bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +From the original + case x of cb(dead) { p -> ...x... } +we will get + case x of cb(live) { p -> let x = cb in ...x... } + +Core Lint never expects to find an *occurence* of an Id marked +as Dead, so we must zap the OccInfo on cb before making the +binding x = cb. See Trac #5028. + Historical note [no-case-of-case] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We *used* to suppress the binder-swap in case expressions when @@ -1360,7 +1584,7 @@ binder-swap unconditionally and still get occurrence analysis information right. \begin{code} -extendProxyEnv :: ProxyEnv -> Id -> CoercionI -> Id -> ProxyEnv +extendProxyEnv :: ProxyEnv -> Id -> Coercion -> Id -> ProxyEnv -- (extendPE x co y) typically arises from -- case (x |> co) of y { ... } -- It extends the proxy env with the binding @@ -1373,7 +1597,7 @@ extendProxyEnv pe scrut co case_bndr env2 = extendVarEnv_Acc add single env1 scrut1 (case_bndr,co) single cb_co = (scrut1, [cb_co]) add cb_co (x, cb_cos) = (x, cb_co:cb_cos) - fvs2 = fvs1 `unionVarSet` freeVarsCoI co + fvs2 = fvs1 `unionVarSet` tyCoVarsOfCo co `extendVarSet` case_bndr `extendVarSet` scrut1 @@ -1381,10 +1605,11 @@ extendProxyEnv pe scrut co case_bndr -- 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! + -- Also we don't want any INLINE or NOINLINE pragmas! ----------- -type ProxyBind = (Id, Id, CoercionI) +type ProxyBind = (Id, Id, Coercion) + -- (scrut variable, case-binder variable, coercion) getProxies :: OccEnv -> Id -> Bag ProxyBind -- Return a bunch of bindings [...(xi,ei)...] @@ -1394,7 +1619,7 @@ getProxies (OccEnv { occ_proxy = PE pe _ }) case_bndr = -- pprTrace "wrapProxies" (ppr case_bndr) $ go_fwd case_bndr where - fwd_pe :: IdEnv (Id, CoercionI) + fwd_pe :: IdEnv (Id, Coercion) fwd_pe = foldVarEnv add1 emptyVarEnv pe where add1 (x,ycos) env = foldr (add2 x) env ycos @@ -1408,23 +1633,23 @@ getProxies (OccEnv { occ_proxy = PE pe _ }) case_bndr go_fwd' case_bndr | Just (scrut, co) <- lookupVarEnv fwd_pe case_bndr - = unitBag (scrut, case_bndr, mkSymCoI co) + = unitBag (scrut, case_bndr, mkSymCo co) `unionBags` go_fwd scrut `unionBags` go_bwd scrut [pr | pr@(cb,_) <- lookup_bwd scrut , cb /= case_bndr] | otherwise = emptyBag - lookup_bwd :: Id -> [(Id, CoercionI)] + lookup_bwd :: Id -> [(Id, Coercion)] -- Return case_bndrs that are connected to scrut lookup_bwd scrut = case lookupVarEnv pe scrut of Nothing -> [] Just (_, cb_cos) -> cb_cos - go_bwd :: Id -> [(Id, CoercionI)] -> Bag ProxyBind + go_bwd :: Id -> [(Id, Coercion)] -> Bag ProxyBind go_bwd scrut cb_cos = foldr (unionBags . go_bwd1 scrut) emptyBag cb_cos - go_bwd1 :: Id -> (Id, CoercionI) -> Bag ProxyBind + go_bwd1 :: Id -> (Id, Coercion) -> Bag ProxyBind go_bwd1 scrut (case_bndr, co) = -- pprTrace "go_bwd1" (ppr case_bndr) $ unitBag (case_bndr, scrut, co) @@ -1439,9 +1664,9 @@ mkAltEnv env scrut cb where pe = occ_proxy env pe' = case scrut of - Var v -> extendProxyEnv pe v IdCo cb - Cast (Var v) co -> extendProxyEnv pe v (ACo co) cb - _other -> trimProxyEnv pe [cb] + Var v -> extendProxyEnv pe v (mkReflCo (idType v)) cb + Cast (Var v) co -> extendProxyEnv pe v co cb + _other -> trimProxyEnv pe [cb] ----------- trimOccEnv :: OccEnv -> [CoreBndr] -> OccEnv @@ -1462,12 +1687,7 @@ trimProxyEnv (PE pe fvs) bndrs trim (scrut, cb_cos) | scrut `elemVarSet` bndr_set = (scrut, []) | otherwise = (scrut, filterOut discard cb_cos) discard (cb,co) = bndr_set `intersectsVarSet` - extendVarSet (freeVarsCoI co) cb - ------------ -freeVarsCoI :: CoercionI -> VarSet -freeVarsCoI IdCo = emptyVarSet -freeVarsCoI (ACo co) = tyVarsOfType co + extendVarSet (tyCoVarsOfCo co) cb \end{code} @@ -1499,9 +1719,8 @@ addOneOcc usage id info emptyDetails :: UsageDetails emptyDetails = (emptyVarEnv :: UsageDetails) -localUsedIn, usedIn :: Id -> UsageDetails -> Bool -v `localUsedIn` details = v `elemVarEnv` details -v `usedIn` details = isExportedId v || v `localUsedIn` details +usedIn :: Id -> UsageDetails -> Bool +v `usedIn` details = isExportedId v || v `elemVarEnv` details type IdWithOccInfo = Id @@ -1561,6 +1780,8 @@ mkOneOcc env id int_cxt | isLocalId id = unitVarEnv id (OneOcc False True int_cxt) | PE env _ <- occ_proxy env , id `elemVarEnv` env = unitVarEnv id NoOccInfo + | Just uds <- lookupNameEnv (occ_rule_fvs env) (idName id) + = uds | otherwise = emptyDetails markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo