X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FOccurAnal.lhs;h=06133d6bdb15a7bfd49ebc035ebf1c001727595f;hp=ba8b5cbbe3ace26ee5ebb7ddcb210e31a3ed3789;hb=d9a655dad8e013e41c74dca98fb86c4ed6f29879;hpb=5e218036aabd1666ff2b509436e4e88491596c37 diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index ba8b5cb..06133d6 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -19,17 +19,18 @@ 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 NameEnv import NameSet import Name ( Name, localiseName ) import BasicTypes +import Coercion + import VarSet import VarEnv -import Var ( varUnique ) +import Var + import Maybes ( orElse ) import Digraph ( SCC(..), stronglyConnCompFromEdgedVerticesR ) import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey ) @@ -52,13 +53,14 @@ import Data.List Here's the externally-callable interface: \begin{code} -occurAnalysePgm :: Maybe (Activation -> Bool) -> [CoreRule] +occurAnalysePgm :: Maybe (Activation -> Bool) -> [CoreRule] -> [CoreVect] -> [CoreBind] -> [CoreBind] -occurAnalysePgm active_rule imp_rules binds +occurAnalysePgm active_rule imp_rules vects binds = snd (go (initOccEnv active_rule imp_rules) binds) where - initial_uds = addIdOccs emptyDetails (rulesFreeVars imp_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 _ [] @@ -97,7 +99,7 @@ occAnalBind :: OccEnv -- The incoming OccEnv [CoreBind]) occAnalBind env _ (NonRec binder rhs) body_usage - | isTyCoVar 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 @@ -107,7 +109,7 @@ occAnalBind env _ (NonRec binder rhs) body_usage = (body_usage' +++ rhs_usage3, [NonRec tagged_binder rhs']) where (body_usage', tagged_binder) = tagBinder body_usage binder - (rhs_usage1, rhs') = occAnalRhs env (idOccInfo 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] @@ -381,11 +383,11 @@ occAnalBind _ env (Rec pairs) body_usage make_node (bndr, rhs) = (details, varUnique bndr, keysUFM out_edges) - where + where details = ND { nd_bndr = bndr, nd_rhs = rhs' , nd_uds = rhs_usage3, nd_inl = inl_fvs} - (rhs_usage1, rhs') = occAnalRhs env NoOccInfo rhs + (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 @@ -790,36 +792,27 @@ ToDo: try using the occurrence info for the inline'd binder. \begin{code} occAnalRhs :: OccEnv - -> OccInfo -> 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 covers only the RHS, -- and *not* the RULE or INLINE template for the Id -occAnalRhs env occ rhs +occAnalRhs env mb_bndr rhs = occAnal ctxt rhs where - ctxt | certainly_inline = 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 = case occ of - OneOcc in_lam one_br _ -> not in_lam && one_br - _ -> False - + -- 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 @@ -833,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} @@ -841,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": +occAnal _ (Coercion co) + = (addIdOccs emptyDetails (coVarsOfCo co), Coercion co) + -- See Note [Gather occurrences of coercion veriables] +\end{code} -\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. - -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} @@ -883,7 +910,10 @@ occAnal env (Note note body) occAnal env (Cast expr co) = case occAnal env expr of { (usage, expr') -> - (markManyIf (isRhsEnv env) 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. @@ -898,7 +928,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) | isTyCoVar x +occAnal env (Lam x body) | isTyVar x = case occAnal env body of { (body_usage, body') -> (body_usage, Lam x body') } @@ -990,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]) @@ -1005,6 +1047,7 @@ occAnalApp env (Var fun, args) -- 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 @@ -1115,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} @@ -1321,9 +1364,11 @@ extendFvs env s %************************************************************************ \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] @@ -1466,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 @@ -1528,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 @@ -1541,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 @@ -1549,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)...] @@ -1562,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 @@ -1576,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) @@ -1607,9 +1664,9 @@ mkAltEnv env scrut cb where pe = occ_proxy env pe' = case scrut of - Var v -> extendProxyEnv pe v (IdCo (idType v)) 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 @@ -1630,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 t) = tyVarsOfType t -freeVarsCoI (ACo co) = tyVarsOfType co + extendVarSet (tyCoVarsOfCo co) cb \end{code} @@ -1702,7 +1754,7 @@ tagBinder usage binder setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr setBinderOcc usage bndr - | isTyCoVar bndr = bndr + | isTyVar bndr = bndr | isExportedId bndr = case idOccInfo bndr of NoOccInfo -> bndr _ -> setIdOccInfo bndr NoOccInfo