[Git][ghc/ghc][wip/T18962-simpl] Implement as separate analysis instead; feed on that in Simplifier
Sebastian Graf
gitlab at gitlab.haskell.org
Wed Dec 9 17:02:04 UTC 2020
Sebastian Graf pushed to branch wip/T18962-simpl at Glasgow Haskell Compiler / GHC
Commits:
e8be408f by Sebastian Graf at 2020-12-09T18:01:51+01:00
Implement as separate analysis instead; feed on that in Simplifier
- - - - -
11 changed files:
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/Pipeline.hs
- compiler/GHC/Core/Opt/Simplify.hs
- compiler/GHC/Core/Opt/StaticArgs.hs
- compiler/GHC/Core/Ppr.hs
- compiler/GHC/Core/Unfold.hs
- compiler/GHC/Types/Basic.hs
- compiler/GHC/Types/Id.hs
- compiler/GHC/Types/Id/Info.hs
- compiler/GHC/Types/Unique/FM.hs
- compiler/GHC/Types/Var/Env.hs
Changes:
=====================================
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)
=====================================
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
@@ -749,9 +749,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
=====================================
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
=====================================
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 at App{} = uncurry (satAnalApp env) (collectArgs e)
+satAnalExpr env e at 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 ->
=====================================
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
=====================================
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
=====================================
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 at 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
=====================================
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
=====================================
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
}
=====================================
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
=====================================
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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e8be408f19106e1f4887f94b20c8841794d62075
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e8be408f19106e1f4887f94b20c8841794d62075
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20201209/0ada1641/attachment-0001.html>
More information about the ghc-commits
mailing list