X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FOccurAnal.lhs;h=d97368a2f6e3f8fd2ce74e55ce994cb1041d4510;hb=5289f5d85610f71625a439747a09384876655eb5;hp=7ac45ccda0e6562252120cd0ec9720f713329a47;hpb=45b8d3bca471a8e7987f506fd1aff79b1d530c1f;p=ghc-hetmet.git diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index 7ac45cc..d97368a 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -23,21 +23,22 @@ import Type ( tyVarsOfType ) import CoreUtils ( exprIsTrivial, isDefaultAlt, mkCoerceI, isExpandableApp ) import Coercion ( CoercionI(..), mkSymCoI ) import Id -import Name ( localiseName ) +import NameEnv +import NameSet +import Name ( Name, localiseName ) import BasicTypes - import VarSet import VarEnv - +import Var ( Var, varUnique ) 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} @@ -53,14 +54,14 @@ Here's the externally-callable interface: \begin{code} occurAnalysePgm :: [CoreBind] -> [CoreRule] -> [CoreBind] occurAnalysePgm binds rules - = snd (go initOccEnv binds) + = snd (go (initOccEnv rules) binds) where - initial_details = addIdOccs emptyDetails (rulesFreeVars rules) + initial_uds = addIdOccs emptyDetails (rulesFreeVars rules) -- The RULES keep things alive! go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind]) go _ [] - = (initial_details, []) + = (initial_uds, []) go env (bind:binds) = (final_usage, bind' ++ binds') where @@ -69,7 +70,7 @@ 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 []) expr) \end{code} @@ -91,7 +92,7 @@ occAnalBind :: OccEnv -- The incoming OccEnv [CoreBind]) occAnalBind env _ (NonRec binder rhs) body_usage - | isTyVar binder -- A type let; we don't gather usage info + | isTyCoVar binder -- A type let; we don't gather usage info = (body_usage, [NonRec binder rhs]) | not (binder `usedIn` body_usage) -- It's not mentioned @@ -154,13 +155,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -198,6 +203,14 @@ However things are made quite a bit more complicated by RULES. Remember 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. @@ -314,12 +327,13 @@ 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) + = (ND bndr rhs' all_rhs_usage rhs_fvs, varUnique 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) + all_rhs_usage = addIdOccs rhs_usage rule_vars -- Note [Rules are extra RHSs] + rhs_fvs = intersectUFM_C (\b _ -> b) bndr_set rhs_usage + out_edges = keysUFM (rhs_fvs `unionVarSet` rule_vars) + rule_vars = idRuleVars bndr -- See Note [Rule dependency info] -- (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 -- @@ -390,41 +404,18 @@ occAnalRec (CyclicSCC nodes) (body_usage, binds) loop_breaker_edges = map mk_node tagged_nodes mk_node (details@(ND _ _ _ rhs_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 rhs_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 - + rule_fv_env = transClosureFV init_rule_fvs no_rules = null init_rule_fvs init_rule_fvs = [(b, rule_fvs) | b <- bndrs + , isId b , 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 \end{code} @reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic @@ -529,10 +520,12 @@ reOrderCycle depth (bind : binds) pairs score :: Node Details -> Int -- Higher score => less likely to be picked as loop breaker score (ND bndr rhs _ _, _, _) + | not (isId bndr) = 100 -- A type or cercion varialbe 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, _) <- isStableUnfolding_maybe (idUnfolding bndr) = case inl_source of InlineWrapper {} -> 10 -- Note [INLINE pragmas] _other -> 3 -- Data structures are more important than this @@ -582,7 +575,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] @@ -730,7 +724,8 @@ occAnalRhs :: OccEnv -- Returned usage details includes any INLINE rhs occAnalRhs env id rhs - = (addIdOccs rhs_usage (idUnfoldingVars id), rhs') + | isId id = (addIdOccs rhs_usage (idUnfoldingVars id), rhs') + | otherwise = (rhs_usage, rhs') -- Include occurrences for the "extra RHS" from a CoreUnfolding where (rhs_usage, rhs') = occAnal ctxt rhs @@ -759,9 +754,11 @@ occAnalRhs env id rhs \begin{code} -addRuleUsage :: UsageDetails -> Id -> UsageDetails +addRuleUsage :: UsageDetails -> Var -> UsageDetails -- Add the usage from RULES in Id to the usage -addRuleUsage usage id = addIdOccs usage (idRuleVars id) +addRuleUsage usage var + | isId var = addIdOccs usage (idRuleVars var) + | otherwise = usage -- idRuleVars here: see Note [Rule dependency info] addIdOccs :: UsageDetails -> VarSet -> UsageDetails @@ -841,7 +838,7 @@ occAnal env app@(App _ _) -- (a) occurrences inside type lambdas only not marked as InsideLam -- (b) type variables not in environment -occAnal env (Lam x body) | isTyVar x +occAnal env (Lam x body) | isTyCoVar x = case occAnal env body of { (body_usage, body') -> (body_usage, Lam x body') } @@ -1070,9 +1067,10 @@ 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 } ----------------------------- @@ -1090,6 +1088,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 -- @@ -1100,19 +1102,17 @@ 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 :: [CoreRule] -> OccEnv +initOccEnv rules = OccEnv { occ_encl = OccVanilla + , occ_ctxt = [] + , occ_proxy = PE emptyVarEnv emptyVarSet + , occ_rule_fvs = findImpRuleUsage rules } 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 } @@ -1147,6 +1147,105 @@ 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 :: [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 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 = extendNameEnv_C unionVarSet acc (ru_fn rule) + (exprSomeFreeVars keep_imp (ru_rhs rule)) + 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 %* * %************************************************************************ @@ -1177,7 +1276,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 @@ -1191,14 +1290,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: @@ -1436,8 +1537,8 @@ 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 + Var v -> extendProxyEnv pe v (IdCo (idType v)) cb + Cast (Var v) co -> extendProxyEnv pe v (ACo co) cb _other -> trimProxyEnv pe [cb] ----------- @@ -1463,7 +1564,7 @@ trimProxyEnv (PE pe fvs) bndrs ----------- freeVarsCoI :: CoercionI -> VarSet -freeVarsCoI IdCo = emptyVarSet +freeVarsCoI (IdCo t) = tyVarsOfType t freeVarsCoI (ACo co) = tyVarsOfType co \end{code} @@ -1496,9 +1597,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 @@ -1532,7 +1632,7 @@ tagBinder usage binder setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr setBinderOcc usage bndr - | isTyVar bndr = bndr + | isTyCoVar bndr = bndr | isExportedId bndr = case idOccInfo bndr of NoOccInfo -> bndr _ -> setIdOccInfo bndr NoOccInfo @@ -1558,6 +1658,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