diff options
author | Sebastian Graf <sebastian.graf@kit.edu> | 2020-12-09 18:01:51 +0100 |
---|---|---|
committer | Sebastian Graf <sebastian.graf@kit.edu> | 2020-12-20 13:42:06 +0100 |
commit | 8f52b3fcc1901d1da5820ef7c6094861894d7902 (patch) | |
tree | 88c662075eb3ac850af9c63960a47b71a2706fa7 | |
parent | 06c836bace0a0ee5fb4bdbf284361d8cc0896408 (diff) | |
download | haskell-8f52b3fcc1901d1da5820ef7c6094861894d7902.tar.gz |
Implement as separate analysis instead; feed on that in Simplifier
-rw-r--r-- | compiler/GHC/Core/Opt/OccurAnal.hs | 116 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/Pipeline.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/Simplify.hs | 26 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/StaticArgs.hs | 168 | ||||
-rw-r--r-- | compiler/GHC/Core/Ppr.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Core/Unfold.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Types/Basic.hs | 70 | ||||
-rw-r--r-- | compiler/GHC/Types/Id.hs | 13 | ||||
-rw-r--r-- | compiler/GHC/Types/Id/Info.hs | 9 | ||||
-rw-r--r-- | compiler/GHC/Types/Unique/FM.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Types/Var/Env.hs | 4 |
11 files changed, 284 insertions, 142 deletions
diff --git a/compiler/GHC/Core/Opt/OccurAnal.hs b/compiler/GHC/Core/Opt/OccurAnal.hs index 4e53da0711..a746e4feb8 100644 --- a/compiler/GHC/Core/Opt/OccurAnal.hs +++ b/compiler/GHC/Core/Opt/OccurAnal.hs @@ -808,7 +808,7 @@ occAnalRecBind env lvl imp_rule_edges pairs body_usage bndrs = map fst pairs bndr_set = mkVarSet bndrs - rhs_env = env `addInScope` bndrs `addInterestingStaticArgs` pairs + rhs_env = env `addInScope` bndrs ----------------------------- @@ -1082,10 +1082,8 @@ mk_loop_breaker :: Id -> Id mk_loop_breaker bndr = bndr `setIdOccInfo` occ' where - occ' = strongLoopBreaker { occ_tail = tail_info - , occ_static_args = static_args } - tail_info = tailCallInfo (idOccInfo bndr) - static_args = staticArgsInfo (idOccInfo bndr) + occ' = strongLoopBreaker { occ_tail = tail_info } + tail_info = tailCallInfo (idOccInfo bndr) mk_non_loop_breaker :: VarSet -> Id -> Id -- See Note [Weak loop breakers] @@ -1977,7 +1975,6 @@ occAnal env (Let bind body) body_usage of { (final_usage, new_binds) -> (final_usage, mkLets new_binds body') }} - occAnalArgs :: OccEnv -> [CoreExpr] -> [OneShots] -> (UsageDetails, [CoreExpr]) occAnalArgs _ [] _ = (emptyDetails, []) @@ -2035,7 +2032,7 @@ occAnalApp env (Var fun, args, ticks) `orElse` (Var fun, fun) -- See Note [The binder-swap substitution] - fun_uds = mkOneOcc env fun_id' int_cxt args + fun_uds = mkOneOcc fun_id' int_cxt n_args all_uds = fun_uds `andUDs` final_args_uds !(args_uds, args') = occAnalArgs env args one_shots @@ -2053,6 +2050,7 @@ occAnalApp env (Var fun, args, ticks) -- See Note [Arguments of let-bound constructors] n_val_args = valArgCount args + n_args = length args int_cxt = case occ_encl env of OccScrut -> IsInteresting _other | n_val_args > 0 -> IsInteresting @@ -2219,15 +2217,12 @@ data OccEnv , occ_unf_act :: Id -> Bool -- Which Id unfoldings are active , occ_rule_act :: Activation -> Bool -- Which rules are active -- See Note [Finding rule RHS free vars] - -- lkj , occ_sat_args :: ![Staticness Var] -- It's not worth the bother - , occ_sat_env :: VarEnv [Var] -- TODO shadowing of lambda binders -- See Note [The binder-swap substitution] , occ_bs_env :: VarEnv (OutExpr, OutId) , occ_bs_rng :: VarSet -- Vars free in the range of occ_bs_env -- Domain is Global and Local Ids -- Range is just Local Ids - -- FIXME: Why is this not an InScopeSet?!! } @@ -2270,8 +2265,6 @@ initOccEnv , occ_unf_act = \_ -> True , occ_rule_act = \_ -> True - , occ_sat_env = emptyVarEnv - , occ_bs_env = emptyVarEnv , occ_bs_rng = emptyVarSet } @@ -2280,11 +2273,9 @@ noBinderSwaps (OccEnv { occ_bs_env = bs_env }) = isEmptyVarEnv bs_env scrutCtxt :: OccEnv -> [CoreAlt] -> OccEnv scrutCtxt env alts - = env { occ_encl = encl, occ_one_shots = [] } + | interesting_alts = env { occ_encl = OccScrut, occ_one_shots = [] } + | otherwise = env { occ_encl = OccVanilla, occ_one_shots = [] } where - encl - | interesting_alts = OccScrut - | otherwise = OccVanilla interesting_alts = case alts of [] -> False [alt] -> not (isDefaultAlt alt) @@ -2310,19 +2301,9 @@ isRhsEnv (OccEnv { occ_encl = cxt }) = case cxt of addInScope :: OccEnv -> [Var] -> OccEnv -- See Note [The binder-swap substitution] addInScope env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) bndrs - | any (`elemVarSet` rng_vars) bndrs = env { occ_bs_env = emptyVarEnv, occ_sat_env = emptyVarEnv, occ_bs_rng = emptyVarSet } + | any (`elemVarSet` rng_vars) bndrs = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet } | otherwise = env { occ_bs_env = swap_env `delVarEnvList` bndrs } --- | Extends 'occ_sat_env' with the expected static argument binders for the --- interesting cases (singleton recursive groups). -addInterestingStaticArgs :: OccEnv -> [(Id, CoreExpr)] -> OccEnv -addInterestingStaticArgs env [(fn, rhs)] - = env { occ_sat_env = extendVarEnv (occ_sat_env env) fn bndrs } - where - (bndrs, _body) = collectBinders rhs -addInterestingStaticArgs env _ - = env - oneShotGroup :: OccEnv -> [CoreBndr] -> ( OccEnv , [CoreBndr] ) @@ -2374,8 +2355,8 @@ markJoinOneShots mb_join_arity bndrs | otherwise = b addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv -addAppCtxt env@(OccEnv { occ_one_shots = oss }) args - = env { occ_one_shots = replicate (valArgCount args) OneShotLam ++ oss } +addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args + = env { occ_one_shots = replicate (valArgCount args) OneShotLam ++ ctxt } -------------------- transClosureFV :: VarEnv VarSet -> VarEnv VarSet @@ -2703,24 +2684,17 @@ andUDs, orUDs andUDs = combineUsageDetailsWith addOccInfo orUDs = combineUsageDetailsWith orOccInfo -mkOneOcc :: OccEnv -> Id -> InterestingCxt -> [CoreArg] -> UsageDetails -mkOneOcc env id int_cxt args +mkOneOcc ::Id -> InterestingCxt -> JoinArity -> UsageDetails +mkOneOcc id int_cxt arity | isLocalId id = emptyDetails { ud_env = unitVarEnv id occ_info } | otherwise = emptyDetails where - n_args = length args - static_args - | Just decl_vars <- lookupVarEnv (occ_sat_env env) id - = mkStaticArgs $ zipWith asStaticArg decl_vars args - | otherwise -- not interesting for SAT - = noStaticArgs - occ_info = OneOcc { occ_in_lam = NotInsideLam - , occ_n_br = oneBranch - , occ_int_cxt = int_cxt - , occ_tail = AlwaysTailCalled n_args - , occ_static_args = static_args } + occ_info = OneOcc { occ_in_lam = NotInsideLam + , occ_n_br = oneBranch + , occ_int_cxt = int_cxt + , occ_tail = AlwaysTailCalled arity } addManyOccId :: UsageDetails -> Id -> UsageDetails -- Add the non-committal (id :-> noOccInfo) to the usage details @@ -2974,22 +2948,16 @@ tagRecBinders lvl body_uds triples = ASSERT(not will_be_joins) -- Should be AlwaysTailCalled if Nothing -- we are making join points! - rhs_uds' = foldr1 andUDs rhs_udss' - -- 3. Compute final usage details from adjusted RHS details - adj_uds = body_uds `andUDs` rhs_uds' + adj_uds = foldr andUDs body_uds rhs_udss' -- 4. Tag each binder with its adjusted details - bndrs' = [ setBinderOcc (adj_occ{occ_static_args = rhs_static_args}) bndr - | bndr <- bndrs - , let adj_occ = lookupDetails adj_uds bndr - , let rhs_static_args = staticArgsInfo (lookupDetails rhs_uds' bndr) - ] + bndrs' = [ setBinderOcc (lookupDetails adj_uds bndr) bndr + | bndr <- bndrs ] -- 5. Drop the binders from the adjusted details and return usage' = adj_uds `delDetailsList` bndrs in - pprTrace "tagRecBinders" (ppr bndrs' $$ ppr body_uds $$ ppr rhs_udss' $$ ppr adj_uds $$ ppr (map idOccInfo bndrs')) $ (usage', bndrs') setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr @@ -3100,16 +3068,8 @@ unravels; so ignoring INLINE pragmas on recursive things isn't good either. See Invariant 2a of Note [Invariants on join points] in GHC.Core --} -asStaticArg :: Var -> CoreArg -> Staticness Var -asStaticArg v arg - | isId v, Var id <- arg, v == id = Static v - | isTyVar v, Type t <- arg, mkTyVarTy v `eqType` t = Static v - | isCoVar v, Coercion co <- arg, mkCoVarCo v `eqCoercion` co = Static v - | otherwise = NotStatic -{- ************************************************************************ * * \subsection{Operations over OccInfo} @@ -3120,8 +3080,7 @@ asStaticArg v arg markMany, markInsideLam, markNonTail :: OccInfo -> OccInfo markMany IAmDead = IAmDead -markMany occ = ManyOccs { occ_tail = occ_tail occ - , occ_static_args = occ_static_args occ } +markMany occ = ManyOccs { occ_tail = occ_tail occ } markInsideLam occ@(OneOcc {}) = occ { occ_in_lam = IsInsideLam } markInsideLam occ = occ @@ -3133,36 +3092,29 @@ addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo addOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) ) ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo` - tailCallInfo a2 - , occ_static_args = staticArgsInfo a1 `andStaticArgs` - staticArgsInfo a2} + tailCallInfo a2 } -- Both branches are at least One -- (Argument is never IAmDead) -- (orOccInfo orig new) is used -- when combining occurrence info from branches of a case -orOccInfo (OneOcc { occ_in_lam = in_lam1 - , occ_n_br = nbr1 - , occ_int_cxt = int_cxt1 - , occ_tail = tail1 - , occ_static_args = static_args1 }) - (OneOcc { occ_in_lam = in_lam2 - , occ_n_br = nbr2 - , occ_int_cxt = int_cxt2 - , occ_tail = tail2 - , occ_static_args = static_args2 }) - = OneOcc { occ_n_br = nbr1 + nbr2 - , occ_in_lam = in_lam1 `mappend` in_lam2 - , occ_int_cxt = int_cxt1 `mappend` int_cxt2 - , occ_tail = tail1 `andTailCallInfo` tail2 - , occ_static_args = static_args1 `andStaticArgs` static_args2 } +orOccInfo (OneOcc { occ_in_lam = in_lam1 + , occ_n_br = nbr1 + , occ_int_cxt = int_cxt1 + , occ_tail = tail1 }) + (OneOcc { occ_in_lam = in_lam2 + , occ_n_br = nbr2 + , occ_int_cxt = int_cxt2 + , occ_tail = tail2 }) + = OneOcc { occ_n_br = nbr1 + nbr2 + , occ_in_lam = in_lam1 `mappend` in_lam2 + , occ_int_cxt = int_cxt1 `mappend` int_cxt2 + , occ_tail = tail1 `andTailCallInfo` tail2 } orOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) ) ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo` - tailCallInfo a2 - , occ_static_args = staticArgsInfo a1 `andStaticArgs` - staticArgsInfo a2 } + tailCallInfo a2 } andTailCallInfo :: TailCallInfo -> TailCallInfo -> TailCallInfo andTailCallInfo info@(AlwaysTailCalled arity1) (AlwaysTailCalled arity2) diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs index e6c970af9f..bfc4d4fbe2 100644 --- a/compiler/GHC/Core/Opt/Pipeline.hs +++ b/compiler/GHC/Core/Opt/Pipeline.hs @@ -37,7 +37,7 @@ import GHC.Core.Opt.Monad import GHC.Core.Opt.FloatIn ( floatInwards ) import GHC.Core.Opt.FloatOut ( floatOutwards ) import GHC.Core.Opt.LiberateCase ( liberateCase ) -import GHC.Core.Opt.StaticArgs ( doStaticArgs ) +import GHC.Core.Opt.StaticArgs ( doStaticArgs, satAnalProgram ) import GHC.Core.Opt.Specialise ( specProgram) import GHC.Core.Opt.SpecConstr ( specConstrProgram) import GHC.Core.Opt.DmdAnal @@ -754,9 +754,11 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) , () <- sz `seq` () -- Force it = do { -- Occurrence analysis - let { tagged_binds = {-# SCC "OccAnal" #-} + let { tagged_binds0 = {-# SCC "OccAnal" #-} occurAnalysePgm this_mod active_unf active_rule rules binds + ; tagged_binds = {-# SCC "SAT" #-} + satAnalProgram tagged_binds0 } ; Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" FormatCore diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index 22d0bb47c0..34c80c8839 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -21,6 +21,7 @@ import GHC.Core.Opt.Simplify.Monad import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst ) import GHC.Core.Opt.Simplify.Env import GHC.Core.Opt.Simplify.Utils +import GHC.Core.Opt.StaticArgs ( saTransform ) import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) import GHC.Types.Literal ( litIsLifted ) --, mkLitInt ) -- temporalily commented out. See #8326 import GHC.Types.SourceText @@ -3786,9 +3787,23 @@ simplLetUnfolding env top_lvl cont_mb id new_rhs rhs_ty arity unf = simplStableUnfolding env top_lvl cont_mb id rhs_ty arity unf | isExitJoinId id = return noUnfolding -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify + | Just static_args <- isStrongLoopBreakerWithStaticArgs id + , (lam_bndrs, lam_body) <- collectBinders new_rhs + = do { unf_rhs <- saTransform id static_args lam_bndrs lam_body + ; pprTraceM "simplLetUnfolding" (ppr id $$ ppr static_args $$ ppr unf_rhs) + ; mkLetUnfolding (seUnfoldingOpts env) top_lvl InlineRhs id unf_rhs } | otherwise = mkLetUnfolding (seUnfoldingOpts env) top_lvl InlineRhs id new_rhs +isStrongLoopBreakerWithStaticArgs :: Id -> Maybe [Staticness ()] +isStrongLoopBreakerWithStaticArgs id + | isStrongLoopBreaker $ idOccInfo id + , static_args <- getStaticArgs $ idStaticArgs id + , notNull static_args + = Just static_args + | otherwise + = Nothing + ------------------- mkLetUnfolding :: UnfoldingOpts -> TopLevelFlag -> UnfoldingSource -> InId -> OutExpr -> SimplM Unfolding @@ -3797,10 +3812,13 @@ mkLetUnfolding uf_opts top_lvl src id new_rhs return (mkUnfolding uf_opts src is_top_lvl is_bottoming new_rhs) -- We make an unfolding *even for loop-breakers*. -- Reason: (a) It might be useful to know that they are WHNF - -- (b) In GHC.Iface.Tidy we currently assume that, if we want to - -- expose the unfolding then indeed we *have* an unfolding - -- to expose. (We could instead use the RHS, but currently - -- we don't.) The simple thing is always to have one. + -- (b) They might have static arguments, in which case we + -- provide a non-rec unfolding that specialises for those + -- (c) And even without static arguments, in GHC.Iface.Tidy we + -- currently assume that, if we want to expose the unfolding + -- then indeed we *have* an unfolding to expose. (We could + -- instead use the RHS, but currently we don't.) The simple + -- thing is always to have one. where is_top_lvl = isTopLevel top_lvl is_bottoming = isDeadEndId id diff --git a/compiler/GHC/Core/Opt/StaticArgs.hs b/compiler/GHC/Core/Opt/StaticArgs.hs index 270e519389..f6d4b02988 100644 --- a/compiler/GHC/Core/Opt/StaticArgs.hs +++ b/compiler/GHC/Core/Opt/StaticArgs.hs @@ -50,10 +50,11 @@ The previous patch, to fix polymorphic floatout demand signatures, is essential to make this work well! -} -module GHC.Core.Opt.StaticArgs ( doStaticArgs ) where +module GHC.Core.Opt.StaticArgs ( satAnalProgram, doStaticArgs, saTransform ) where import GHC.Prelude +import GHC.Builtin.Names ( unboundKey ) import GHC.Types.Var import GHC.Core import GHC.Core.Utils @@ -64,19 +65,161 @@ import GHC.Types.Name import GHC.Types.Var.Env import GHC.Types.Unique.Supply import GHC.Utils.Misc -import GHC.Types.Basic (Staticness(..)) +import GHC.Types.Basic ( Staticness(..), StaticArgs, mkStaticArgs, noStaticArgs, andStaticArgs ) import GHC.Types.Unique.FM import GHC.Types.Var.Set -import GHC.Types.Unique import GHC.Types.Unique.Set import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Data.FastString +import GHC.Data.Maybe import Data.List (mapAccumL) -import GHC.Data.FastString +import Data.Bifunctor (second) #include "HsVersions.h" +satAnalProgram :: CoreProgram -> CoreProgram +satAnalProgram bs = map (snd . satAnalBind initSatEnv) bs + +-- | Lambda binders ('TyVar's, 'CoVar's and 'Id's) of a let-bound RHS, thus +-- parameters to a function. +type Params = [Var] + +data SatEnv + = SE + { se_params_env :: !(IdEnv Params) + -- ^ Lambda binders of interesting Id's. If a param is static, then all + -- occurrences must have the 'Var' listed here in its position! + , se_in_scope :: !InScopeSet + -- ^ Needed for handling shadowing properly. See 'addInScopeVars'. + } + +initSatEnv :: SatEnv +initSatEnv = SE emptyVarEnv emptyInScopeSet + +addInterestingId :: SatEnv -> Id -> Params -> SatEnv +addInterestingId env id params = + env { se_params_env = extendVarEnv (se_params_env env) id params } + +lookupInterestingId :: SatEnv -> Id -> Maybe Params +lookupInterestingId env id = lookupVarEnv (se_params_env env) id + +addInScopeVar :: SatEnv -> Var -> SatEnv +addInScopeVar env v = addInScopeVars env [v] + +addInScopeVars :: SatEnv -> [Var] -> SatEnv +addInScopeVars se vars = se { se_in_scope = in_scope', se_params_env = env' } + where + in_scope = se_in_scope se + in_scope' = extendInScopeSetList in_scope vars + env = se_params_env se + var_set = mkVarSet vars + env' + | any (`elemInScopeSet` in_scope) vars + = mapVarEnv (hideShadowedParams var_set) $ delVarEnvList env vars + | otherwise + = env + +hideShadowedParams :: VarSet -> Params -> Params +hideShadowedParams shadowing_vars = map_if shadowed hide_param + where + map_if :: (a -> Bool) -> (a -> a) -> [a] -> [a] + map_if p f = map (\a -> if p a then f a else a) + shadowed param = param `elemVarSet` shadowing_vars + -- unboundKey is guaranteed not to occur anywhere in the program! + -- See Note [Shadowed Params] TODO + hide_param param = param `setVarUnique` unboundKey + +newtype SatOccs = SO (IdEnv StaticArgs) + +emptySatOccs :: SatOccs +emptySatOccs = SO emptyVarEnv + +addSatOccs :: SatOccs -> Id -> StaticArgs -> SatOccs +addSatOccs (SO env) fn static_args = + SO $ extendVarEnv_C andStaticArgs env fn static_args + +combineSatOccs :: SatOccs -> SatOccs -> SatOccs +combineSatOccs (SO a) (SO b) = SO $ plusVarEnv_C andStaticArgs a b + +combineSatOccsList :: [SatOccs] -> SatOccs +combineSatOccsList occs = foldl' combineSatOccs emptySatOccs occs + +peelSatOccs :: SatOccs -> Id -> (StaticArgs, SatOccs) +peelSatOccs (SO env) fn = case delLookupVarEnv env fn of + (mb_sa, env') -> (mb_sa `orElse` noStaticArgs, SO env') + +satAnalBind :: SatEnv -> CoreBind -> (SatOccs, CoreBind) +satAnalBind env (NonRec id rhs) = (occs, NonRec id rhs') + where + (occs, rhs') = satAnalExpr (env `addInScopeVar` id) rhs +satAnalBind env (Rec [(fn, rhs)]) + | notNull bndrs + = (occs', Rec [(fn', rhs')]) + where + (bndrs, rhs_body) = collectBinders rhs + env' = addInterestingId (env `addInScopeVars` (fn:bndrs)) fn bndrs + (occs, rhs_body') = satAnalExpr env' rhs_body + rhs' = mkLams bndrs rhs_body' + (static_args, occs') = peelSatOccs occs fn + fn' = setIdStaticArgs fn static_args +satAnalBind env (Rec pairs) = (combineSatOccsList occss, Rec pairs') + where + ids = map fst pairs + env' = env `addInScopeVars` ids + (occss, rhss') = mapAndUnzip (satAnalExpr env' . snd) pairs + pairs' = zip ids rhss' + +satAnalExpr :: SatEnv -> CoreExpr -> (SatOccs, CoreExpr) +satAnalExpr _ e@(Lit _) = (emptySatOccs, e) +satAnalExpr _ e@(Coercion _) = (emptySatOccs, e) +satAnalExpr _ e@(Type _) = (emptySatOccs, e) +satAnalExpr _ e@(Var _) = (emptySatOccs, e) -- boring! See the App case +satAnalExpr env (Tick t e) = second (Tick t) $ satAnalExpr env e +satAnalExpr env (Cast e c) = second (flip Cast c) $ satAnalExpr env e +satAnalExpr env e@App{} = uncurry (satAnalApp env) (collectArgs e) +satAnalExpr env e@Lam{} = (occs, mkLams bndrs body') + where + (bndrs, body) = collectBinders e + (occs, body') = satAnalExpr (env `addInScopeVars` bndrs) body +satAnalExpr env (Let bnd body) = (occs, Let bnd' body') + where + (occs_bind, bnd') = satAnalBind env bnd' + (occs_body, body') = satAnalExpr (env `addInScopeVars` bindersOf bnd) body + !occs = combineSatOccs occs_body occs_bind +satAnalExpr env (Case scrut bndr ty alts) = (occs, Case scrut' bndr ty alts') + where + (occs_scrut, scrut') = satAnalExpr env scrut + alt_env = env `addInScopeVar` bndr + (occs_alts, alts') = mapAndUnzip (satAnalAlt alt_env) alts + occs = combineSatOccsList (occs_scrut:occs_alts) + +satAnalAlt :: SatEnv -> CoreAlt -> (SatOccs, CoreAlt) +satAnalAlt env (dc, bndrs, rhs) = (occs, (dc, bndrs, rhs')) + where + (occs, rhs') = satAnalExpr (env `addInScopeVars` bndrs) rhs + +satAnalApp :: SatEnv -> CoreExpr -> [CoreArg] -> (SatOccs, CoreExpr) +satAnalApp env head args = (add_static_args_info occs, expr') + where + (occs_head, head') = satAnalExpr env head + (occs_args, args') = mapAndUnzip (satAnalExpr env) args + occs = combineSatOccsList (occs_head:occs_args) + expr' = mkApps head' args' + add_static_args_info occs + | Var fn <- head, Just params <- lookupInterestingId env fn + = addSatOccs occs fn (mkStaticArgs $ zipWith asStaticArg params args) + | otherwise + = occs + +asStaticArg :: Var -> CoreArg -> Staticness () +asStaticArg v arg + | isId v, Var id <- arg, v == id = Static () + | isTyVar v, Type t <- arg, mkTyVarTy v `eqType` t = Static () + | isCoVar v, Coercion co <- arg, mkCoVarCo v `eqCoercion` co = Static () + | otherwise = NotStatic + doStaticArgs :: UniqSupply -> CoreProgram -> CoreProgram doStaticArgs us binds = snd $ mapAccumL sat_bind_threaded_us us binds where @@ -261,9 +404,6 @@ type SatM result = UniqSM result runSAT :: UniqSupply -> SatM a -> a runSAT = initUs_ -newUnique :: SatM Unique -newUnique = getUniqueM - {- ************************************************************************ @@ -371,7 +511,8 @@ saTransformMaybe :: Id -> Maybe SATInfo -> [Id] -> CoreExpr -> SatM CoreBind saTransformMaybe binder maybe_arg_staticness rhs_binders rhs_body | Just arg_staticness <- maybe_arg_staticness , should_transform arg_staticness - = saTransform binder arg_staticness rhs_binders rhs_body + = do { new_rhs <- saTransform binder arg_staticness rhs_binders rhs_body + ; return (NonRec binder new_rhs) } | otherwise = return (Rec [(binder, mkLams rhs_binders rhs_body)]) where @@ -379,11 +520,12 @@ saTransformMaybe binder maybe_arg_staticness rhs_binders rhs_body where n_static_args = count isStaticValue staticness -saTransform :: Id -> SATInfo -> [Id] -> CoreExpr -> SatM CoreBind +saTransform :: MonadUnique m => Id -> [Staticness a] -> [Id] -> CoreExpr -> m CoreExpr saTransform binder arg_staticness rhs_binders rhs_body - = do { shadow_lam_bndrs <- mapM clone binders_w_staticness - ; uniq <- newUnique - ; return (NonRec binder (mk_new_rhs uniq shadow_lam_bndrs)) } + = do { MASSERT( arg_staticness `leLength` rhs_binders ) + ; shadow_lam_bndrs <- mapM clone binders_w_staticness + ; uniq <- getUniqueM + ; return (mk_new_rhs uniq shadow_lam_bndrs) } where -- Running example: foldr -- foldr \alpha \beta c n xs = e, for some e @@ -400,7 +542,7 @@ saTransform binder arg_staticness rhs_binders rhs_body non_static_args = [v | (v, NotStatic) <- binders_w_staticness] clone (bndr, NotStatic) = return bndr - clone (bndr, _ ) = do { uniq <- newUnique + clone (bndr, _ ) = do { uniq <- getUniqueM ; return (setVarUnique bndr uniq) } -- new_rhs = \alpha beta c n xs -> diff --git a/compiler/GHC/Core/Ppr.hs b/compiler/GHC/Core/Ppr.hs index 37e5afc963..2a02f59641 100644 --- a/compiler/GHC/Core/Ppr.hs +++ b/compiler/GHC/Core/Ppr.hs @@ -464,6 +464,7 @@ instance Outputable IdInfo where ppr info = showAttributes [ (has_prag, text "InlPrag=" <> pprInlineDebug prag_info) , (has_occ, text "Occ=" <> ppr occ_info) + , (has_static_args, text "SA=" <> ppr static_args) , (has_dmd, text "Dmd=" <> ppr dmd_info) , (has_lbv , text "OS=" <> ppr lbv_info) , (has_arity, text "Arity=" <> int arity) @@ -480,6 +481,9 @@ instance Outputable IdInfo where occ_info = occInfo info has_occ = not (isManyOccs occ_info) + static_args = staticArgsInfo info + has_static_args = static_args /= noStaticArgs + dmd_info = demandInfo info has_dmd = not $ isTopDmd dmd_info diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs index ac063b4af4..c5e6ff37c6 100644 --- a/compiler/GHC/Core/Unfold.hs +++ b/compiler/GHC/Core/Unfold.hs @@ -51,7 +51,7 @@ import GHC.Core.DataCon import GHC.Types.Literal import GHC.Builtin.PrimOps import GHC.Types.Id.Info -import GHC.Types.Basic ( Arity, InlineSpec(..), inlinePragmaSpec, staticArgsInfo, noStaticArgs ) +import GHC.Types.Basic ( Arity, InlineSpec(..), inlinePragmaSpec, noStaticArgs ) import GHC.Core.Type import GHC.Builtin.Names import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) @@ -1096,7 +1096,7 @@ callSiteInline dflags id active_unfolding lone_variable arg_infos cont_info DFunUnfolding {} -> Nothing -- Never unfold a DFun where b ==> t = not b || t - has_static_args id = staticArgsInfo (idOccInfo id) /= noStaticArgs + has_static_args id = idStaticArgs id /= noStaticArgs -- | Report the inlining of an identifier's RHS to the user, if requested. traceInline :: DynFlags -> Id -> String -> SDoc -> a -> a diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs index 4398ec1567..19ae589c2f 100644 --- a/compiler/GHC/Types/Basic.hs +++ b/compiler/GHC/Types/Basic.hs @@ -69,8 +69,7 @@ module GHC.Types.Basic ( isAlwaysTailCalled, Staticness(..), - StaticArgs, staticArgsInfo, - mkStaticArgs, noStaticArgs, getStaticArgs, andStaticArgs, + StaticArgs, mkStaticArgs, noStaticArgs, getStaticArgs, andStaticArgs, EP(..), @@ -116,6 +115,7 @@ import GHC.Utils.Misc import GHC.Types.SourceText import Data.Data import Data.Bits +import Data.List ( dropWhileEnd ) import qualified Data.Semigroup as Semi {- @@ -919,8 +919,7 @@ OccInfo here, safely at the bottom -- | identifier Occurrence Information data OccInfo - = ManyOccs { occ_tail :: !TailCallInfo - , occ_static_args :: {-# UNPACK #-} !StaticArgs } + = ManyOccs { occ_tail :: !TailCallInfo } -- ^ There are many occurrences, or unknown occurrences | IAmDead -- ^ Marks unused variables. Sometimes useful for @@ -929,15 +928,13 @@ data OccInfo | OneOcc { occ_in_lam :: !InsideLam , occ_n_br :: {-# UNPACK #-} !BranchCount , occ_int_cxt :: !InterestingCxt - , occ_tail :: !TailCallInfo - , occ_static_args :: {-# UNPACK #-} !StaticArgs } + , occ_tail :: !TailCallInfo } -- ^ Occurs exactly once (per branch), not inside a rule -- | This identifier breaks a loop of mutually recursive functions. The field -- marks whether it is only a loop breaker due to a reference in a rule | IAmALoopBreaker { occ_rules_only :: !RulesOnly - , occ_tail :: !TailCallInfo - , occ_static_args :: {-# UNPACK #-} !StaticArgs } + , occ_tail :: !TailCallInfo } -- Note [LoopBreaker OccInfo] deriving (Eq) @@ -962,14 +959,6 @@ newtype StaticArgs = StaticArgs { unwrapStaticArgs :: Word } noStaticArgs :: StaticArgs noStaticArgs = StaticArgs zeroBits --- | All one bit vector; all arguments are static -allStaticArgs :: StaticArgs -allStaticArgs = StaticArgs (complement zeroBits) - -staticArgsInfo :: OccInfo -> StaticArgs -staticArgsInfo IAmDead = allStaticArgs -- should be a neutral element to @andStaticArgs@ -staticArgsInfo occ = occ_static_args occ - -- | The maximum number of static arguments we can express mAX_STATIC_ARGS :: Int mAX_STATIC_ARGS = 32 `min` finiteBitSize (unwrapStaticArgs noStaticArgs) @@ -980,7 +969,12 @@ mkStaticArgs = StaticArgs . take mAX_STATIC_ARGS getStaticArgs :: StaticArgs -> [Staticness ()] -getStaticArgs (StaticArgs n) = map (to_static . testBit n) [0..finiteBitSize n - 1] +getStaticArgs sa@(StaticArgs n) + | sa == noStaticArgs + = [] + | otherwise + = dropWhileEnd (== NotStatic) -- trim trailing @NotStatic@s + $ map (to_static . testBit n) [0..finiteBitSize n - 1] where to_static True = Static () to_static False = NotStatic @@ -988,6 +982,19 @@ getStaticArgs (StaticArgs n) = map (to_static . testBit n) [0..finiteBitSize n - andStaticArgs :: StaticArgs -> StaticArgs -> StaticArgs andStaticArgs (StaticArgs sa1) (StaticArgs sa2) = StaticArgs $ sa1 .&. sa2 +instance Outputable StaticArgs where + ppr = hcat . map pp_bit . getStaticArgs + where + pp_bit NotStatic = char '.' + pp_bit Static{} = char 'S' + +_pprShortStaticArgs :: StaticArgs -> SDoc +_pprShortStaticArgs static_args + | static_args == noStaticArgs = empty + | otherwise = char 'S' <> brackets (int n_static_args) + where + n_static_args = count isStatic (getStaticArgs static_args) + {- Note [LoopBreaker OccInfo] ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1001,12 +1008,10 @@ See OccurAnal Note [Weak loop breakers] -} noOccInfo :: OccInfo -noOccInfo = ManyOccs { occ_tail = NoTailCallInfo, occ_static_args = noStaticArgs } +noOccInfo = ManyOccs { occ_tail = NoTailCallInfo } isNoOccInfo :: OccInfo -> Bool -isNoOccInfo ManyOccs { occ_tail = NoTailCallInfo - , occ_static_args = static_args } - = static_args == noStaticArgs +isNoOccInfo ManyOccs { occ_tail = NoTailCallInfo } = True isNoOccInfo _ = False isManyOccs :: OccInfo -> Bool @@ -1079,8 +1084,8 @@ instance Outputable TailCallInfo where ----------------- strongLoopBreaker, weakLoopBreaker :: OccInfo -strongLoopBreaker = IAmALoopBreaker False NoTailCallInfo noStaticArgs -weakLoopBreaker = IAmALoopBreaker True NoTailCallInfo noStaticArgs +strongLoopBreaker = IAmALoopBreaker False NoTailCallInfo +weakLoopBreaker = IAmALoopBreaker True NoTailCallInfo isWeakLoopBreaker :: OccInfo -> Bool isWeakLoopBreaker (IAmALoopBreaker{}) = True @@ -1106,36 +1111,27 @@ zapFragileOcc occ = zapOccTailCallInfo occ instance Outputable OccInfo where -- only used for debugging; never parsed. KSW 1999-07 - ppr (ManyOccs tails static_args) = pprShortTailCallInfo tails <> pprShortStaticArgs static_args + ppr (ManyOccs tails) = pprShortTailCallInfo tails ppr IAmDead = text "Dead" - ppr (IAmALoopBreaker rule_only tails static_args) - = text "LoopBreaker" <> pp_ro <> pp_tail <> pp_sas + ppr (IAmALoopBreaker rule_only tails) + = text "LoopBreaker" <> pp_ro <> pp_tail where pp_ro | rule_only = char '!' | otherwise = empty pp_tail = pprShortTailCallInfo tails - pp_sas = pprShortStaticArgs static_args - ppr (OneOcc inside_lam one_branch int_cxt tail_info static_args) - = text "Once" <> pp_lam inside_lam <> ppr one_branch <> pp_args int_cxt <> pp_tail <> pp_sas + ppr (OneOcc inside_lam one_branch int_cxt tail_info) + = text "Once" <> pp_lam inside_lam <> ppr one_branch <> pp_args int_cxt <> pp_tail where pp_lam IsInsideLam = char 'L' pp_lam NotInsideLam = empty pp_args IsInteresting = char '!' pp_args NotInteresting = empty pp_tail = pprShortTailCallInfo tail_info - pp_sas = pprShortStaticArgs static_args pprShortTailCallInfo :: TailCallInfo -> SDoc pprShortTailCallInfo (AlwaysTailCalled ar) = char 'T' <> brackets (int ar) pprShortTailCallInfo NoTailCallInfo = empty -pprShortStaticArgs :: StaticArgs -> SDoc -pprShortStaticArgs static_args - | static_args == noStaticArgs = empty - | otherwise = char 'S' <> brackets (int n_static_args) - where - n_static_args = count isStatic (getStaticArgs static_args) - data Staticness a = Static a | NotStatic diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs index b0c83ce8b2..fe9ff8ea67 100644 --- a/compiler/GHC/Types/Id.hs +++ b/compiler/GHC/Types/Id.hs @@ -55,7 +55,7 @@ module GHC.Types.Id ( globaliseId, localiseId, setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo, - zapIdUsedOnceInfo, zapIdTailCallInfo, + zapIdUsedOnceInfo, zapIdTailCallInfo, zapIdStaticArgs, zapFragileIdInfo, zapIdStrictness, zapStableUnfolding, transferPolyIdInfo, scaleIdBy, scaleVarBy, @@ -98,6 +98,7 @@ module GHC.Types.Id ( idCafInfo, idLFInfo_maybe, idOneShotInfo, idStateHackOneShotInfo, idOccInfo, + idStaticArgs, isNeverLevPolyId, -- ** Writing 'IdInfo' fields @@ -108,6 +109,7 @@ module GHC.Types.Id ( setIdSpecialisation, setIdCafInfo, setIdOccInfo, zapIdOccInfo, + setIdStaticArgs, setIdLFInfo, setIdDemandInfo, @@ -784,6 +786,15 @@ setIdOccInfo id occ_info = modifyIdInfo (`setOccInfo` occ_info) id zapIdOccInfo :: Id -> Id zapIdOccInfo b = b `setIdOccInfo` noOccInfo +idStaticArgs :: Id -> StaticArgs +idStaticArgs id = staticArgsInfo (idInfo id) + +setIdStaticArgs :: Id -> StaticArgs -> Id +setIdStaticArgs id static_args = modifyIdInfo (`setStaticArgsInfo` static_args) id + +zapIdStaticArgs :: Id -> Id +zapIdStaticArgs b = b `setIdStaticArgs` noStaticArgs + {- --------------------------------- -- INLINING diff --git a/compiler/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs index 0ece12cefa..fece9c551d 100644 --- a/compiler/GHC/Types/Id/Info.hs +++ b/compiler/GHC/Types/Id/Info.hs @@ -75,6 +75,9 @@ module GHC.Types.Id.Info ( ppCafInfo, mayHaveCafRefs, cafInfo, setCafInfo, + -- ** Static arguments + StaticArgs, staticArgsInfo, setStaticArgsInfo, + -- ** The LambdaFormInfo type LambdaFormInfo(..), lfInfo, setLFInfo, @@ -128,6 +131,7 @@ infixl 1 `setRuleInfo`, `setStrictnessInfo`, `setCprInfo`, `setDemandInfo`, + `setStaticArgsInfo`, `setNeverLevPoly`, `setLevityInfoWithType` @@ -278,6 +282,7 @@ data IdInfo -- 4% in some programs. See #17497 and associated MR. -- -- See documentation of the getters for what these packed fields mean. + staticArgsInfo :: {-# UNPACK #-} !StaticArgs, lfInfo :: !(Maybe LambdaFormInfo) } @@ -415,6 +420,9 @@ setStrictnessInfo info dd = dd `seq` info { strictnessInfo = dd } setCprInfo :: IdInfo -> CprSig -> IdInfo setCprInfo info cpr = cpr `seq` info { cprInfo = cpr } +setStaticArgsInfo :: IdInfo -> StaticArgs -> IdInfo +setStaticArgsInfo info sa = info { staticArgsInfo = sa } + -- | Basic 'IdInfo' that carries no useful information whatsoever vanillaIdInfo :: IdInfo vanillaIdInfo @@ -432,6 +440,7 @@ vanillaIdInfo bitfieldSetOneShotInfo NoOneShotInfo $ bitfieldSetLevityInfo NoLevityInfo $ emptyBitField, + staticArgsInfo = noStaticArgs, lfInfo = Nothing } diff --git a/compiler/GHC/Types/Unique/FM.hs b/compiler/GHC/Types/Unique/FM.hs index 6d13436169..0c2fc6e115 100644 --- a/compiler/GHC/Types/Unique/FM.hs +++ b/compiler/GHC/Types/Unique/FM.hs @@ -70,6 +70,7 @@ module GHC.Types.Unique.FM ( isNullUFM, lookupUFM, lookupUFM_Directly, lookupWithDefaultUFM, lookupWithDefaultUFM_Directly, + delLookupUFM, nonDetEltsUFM, eltsUFM, nonDetKeysUFM, ufmToSet_Directly, nonDetUFMToList, ufmToIntMap, unsafeIntMapToUFM, @@ -338,6 +339,11 @@ lookupWithDefaultUFM (UFM m) v k = M.findWithDefault v (getKey $ getUnique k) m lookupWithDefaultUFM_Directly :: UniqFM key elt -> elt -> Unique -> elt lookupWithDefaultUFM_Directly (UFM m) v u = M.findWithDefault v (getKey u) m +delLookupUFM :: Uniquable key => UniqFM key elt -> key -> (Maybe elt, UniqFM key elt) +delLookupUFM (UFM m) k = (mb_v, UFM m') + where + (mb_v, m') = M.updateLookupWithKey (\_key _elt -> Nothing) (getKey $ getUnique k) m + eltsUFM :: UniqFM key elt -> [elt] eltsUFM (UFM m) = M.elems m diff --git a/compiler/GHC/Types/Var/Env.hs b/compiler/GHC/Types/Var/Env.hs index ed58c413f4..110b4fde60 100644 --- a/compiler/GHC/Types/Var/Env.hs +++ b/compiler/GHC/Types/Var/Env.hs @@ -16,7 +16,7 @@ module GHC.Types.Var.Env ( plusVarEnvList, alterVarEnv, delVarEnvList, delVarEnv, minusVarEnv, - lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv, + lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv, delLookupVarEnv, mapVarEnv, zipVarEnv, modifyVarEnv, modifyVarEnv_Directly, isEmptyVarEnv, @@ -488,6 +488,7 @@ lookupVarEnv :: VarEnv a -> Var -> Maybe a filterVarEnv :: (a -> Bool) -> VarEnv a -> VarEnv a lookupVarEnv_NF :: VarEnv a -> Var -> a lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a +delLookupVarEnv :: VarEnv a -> Var -> (Maybe a, VarEnv a) elemVarEnv :: Var -> VarEnv a -> Bool elemVarEnvByKey :: Unique -> VarEnv a -> Bool disjointVarEnv :: VarEnv a -> VarEnv a -> Bool @@ -509,6 +510,7 @@ minusVarEnv = minusUFM plusVarEnv = plusUFM plusVarEnvList = plusUFMList lookupVarEnv = lookupUFM +delLookupVarEnv = delLookupUFM filterVarEnv = filterUFM lookupWithDefaultVarEnv = lookupWithDefaultUFM mapVarEnv = mapUFM |