[Git][ghc/ghc][wip/T22404] More wibbles
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Sat Jul 15 22:27:37 UTC 2023
Simon Peyton Jones pushed to branch wip/T22404 at Glasgow Haskell Compiler / GHC
Commits:
0c0d689b by Simon Peyton Jones at 2023-07-15T23:27:12+01:00
More wibbles
- - - - -
3 changed files:
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Rules.hs
- compiler/GHC/Types/Var.hs
Changes:
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -954,26 +954,6 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine
= let !(WUD body_uds res) = addInScope env [bndr] thing_inside
in WUD body_uds (combine [NonRec bndr rhs] res)
- -- Fast path for top level, non-recursive bindings, with no unfoldings or rules
- | TopLevel <- lvl
- , not (idHasRules bndr)
- , not (bndr `elemVarEnv` ire)
- = let !(WUD body_uds (tagged_bndr, body)) = occAnalNonRecBody env lvl bndr thing_inside
- in if isDeadBinder tagged_bndr -- Drop dead code; see Note [Dead code]
- then WUD body_uds body
- else let
- unf = idUnfolding bndr
- rhs_env = addOneShotsFromDmd bndr $
- setNonTailCtxt (mkNonRecRhsCtxt tagged_bndr unf) env
- !rhs_wuds@(WTUD _ rhs') = occAnalLamTail rhs_env rhs
- !(WTUD (TUD _ unf_uds) _) = occAnalUnfolding rhs_env unf
- rhs_uds = adjustTailUsage Nothing rhs_wuds
- full_rhs_uds | isStableUnfolding unf = rhs_uds `andUDs` markAllNonTail unf_uds
- | otherwise = rhs_uds
-
- in WUD (full_rhs_uds `andUDs` body_uds) -- Note `andUDs`
- (combine [NonRec tagged_bndr rhs'] body)
-
-- /Existing/ non-recursive join points
-- Analyse the RHS and /then/ the body
| NotTopLevel <- lvl
@@ -993,11 +973,35 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine
else WUD (rhs_uds `orUDs` body_uds) -- Note `orUDs`
(combine [NonRec tagged_bndr rhs'] body)
+ -- Fast path for top level, non-recursive bindings, with no rules
+ -- This is a very common case. Semantically though, you can delete this
+ -- entire equation and fall through to the general case
+ -- Fast path:
+ -- * Top level so cannot be a join point
+ -- * Top level so no binder swap, so no need to update unfolding
+ -- * No rules so no faffing with them
+ | TopLevel <- lvl
+ , not (idHasRules bndr || (bndr `elemVarEnv` ire))
+ = let !(WUD body_uds (tagged_bndr, body)) = occAnalNonRecBody env lvl bndr thing_inside
+ in if isDeadBinder tagged_bndr -- Drop dead code; see Note [Dead code]
+ then WUD body_uds body
+ else let
+ unf = idUnfolding bndr
+ rhs_env = addOneShotsFromDmd bndr $
+ setNonTailCtxt (mkNonRecRhsCtxt tagged_bndr unf) env
+ !rhs_wuds@(WTUD _ rhs') = occAnalLamTail rhs_env rhs
+ !(WTUD (TUD _ unf_uds) _) = occAnalUnfolding rhs_env unf
+ rhs_uds = adjustTailUsage Nothing rhs_wuds
+ full_rhs_uds | isStableUnfolding unf = rhs_uds `andUDs` markAllNonTail unf_uds
+ | otherwise = rhs_uds
+
+ in WUD (full_rhs_uds `andUDs` body_uds) -- Note `andUDs`
+ (combine [NonRec tagged_bndr rhs'] body)
+
-- The normal case, including newly-discovered join points
-- Analyse the body and /then/ the RHS
| otherwise
- = let
- !(WUD body_uds (tagged_bndr, body)) = occAnalNonRecBody env lvl bndr thing_inside
+ = let !(WUD body_uds (tagged_bndr, body)) = occAnalNonRecBody env lvl bndr thing_inside
in if isDeadBinder tagged_bndr -- Drop dead code; see Note [Dead code]
then WUD body_uds body
else let
@@ -2169,8 +2173,10 @@ occ_anal_lam_tail env (Lam bndr expr)
env1 = env { occ_encl = OccVanilla, occ_one_shots = env_one_shots' }
!(WUD usage expr') = occ_anal_lam_tail env1 expr
- bndr2 = tagLamBinder usage bndr1
- in WUD usage (Lam bndr2 expr')
+ bndr2 = tagLamBinder usage bndr1
+ usage1 = usage `addManyOccs` coVarsOfType (idType bndr)
+ -- usage1: see Note [Gather occurrences of coercion variables]
+ in WUD usage1 (Lam bndr2 expr')
-- For casts, keep going in the same lambda-group
-- See Note [Occurrence analysis for lambda binders]
@@ -2459,7 +2465,7 @@ We gather CoVar occurrences from:
* The (Type ty) and (Coercion co) cases of occAnal
* The type 'ty' of a lambda-binder (\(x:ty). blah)
- See addLamCoVarOccs
+ See addCoVarOccs
But it is not necessary to gather CoVars from the types of other binders.
@@ -2938,10 +2944,7 @@ addInScope env@(OccEnv { occ_in_scope = in_scope, occ_join_points = join_points
fix_up_uds :: WithUsageDetails a -> WithUsageDetails a
-- Remove usage for bndrs
-- Add usage info for CoVars used in the types of bndrs
- fix_up_uds (WUD uds res) = WUD with_co_var_occs res
- where
- trimmed_uds = uds `delDetails` bndrs
- with_co_var_occs = trimmed_uds `addManyOccs` coVarOccs bndrs
+ fix_up_uds (WUD uds res) = WUD (uds `delDetails` bndrs) res
add_bad_joins :: WithUsageDetails a -> WithUsageDetails a
-- Add usage info for occ_join_points that we cannot push inwardsa
@@ -2982,8 +2985,6 @@ addJoinPoint env bndr rhs_uds
mkZeroedForm :: UsageDetails -> OccInfoEnv
-- See Note [Occurrence analysis for join points] for "zeroed form"
---mkZeroedForm EmptyUDs
--- = emptyVarEnv
mkZeroedForm (UD { ud_env = rhs_occs })
= mapMaybeUFM do_one rhs_occs
where
@@ -3416,8 +3417,8 @@ type OccInfoEnv = IdEnv LocalOcc -- A finite map from an expression's
data LocalOcc
= OneOccL { lo_n_br :: {-# UNPACK #-} !Int
, lo_tail :: {-# UNPACK #-} !TailCallInfo
- -- Combining (AlwaysTailCalled 2) and (AlwaysTailCalled 3)
- -- gives NoTailCallInfo
+ -- Combining (AlwaysTailCalled 2) and (AlwaysTailCalled 3)
+ -- gives NoTailCallInfo
, lo_int_cxt :: !InterestingCxt }
| ManyOccL !TailCallInfo
@@ -3439,10 +3440,8 @@ data UsageDetails
, ud_z_tail :: !ZappedSet
}
-- INVARIANT: All three zapped sets are subsets of ud_env
--- | EmptyUDs
instance Outputable UsageDetails where
--- ppr EmptyUDs = text "EmptyUDs"
ppr ud@(UD { ud_env = env, ud_z_tail = z_tail })
= text "UD" <+> (braces $ fsep $ punctuate comma $
[ ppr uq <+> text ":->" <+> ppr (mkOccInfoByUnique ud uq)
@@ -3507,24 +3506,12 @@ add_many_occ v env | isId v = extendVarEnv env v (ManyOccL NoTailCallInfo)
addManyOccs :: UsageDetails -> VarSet -> UsageDetails
addManyOccs uds var_set
| isEmptyVarSet var_set = uds
- | otherwise = case uds of
--- EmptyUDs -> mkSimpleDetails (add_to emptyVarEnv)
- UD { ud_env = env } -> uds { ud_env = add_to env }
+ | otherwise = uds { ud_env = add_to (ud_env uds) }
where
add_to env = nonDetStrictFoldUniqSet add_many_occ env var_set
- -- It's OK to use nonDetStrictFoldUniqSet here because addManyOcc commutes
-
-coVarOccs :: [Var] -> VarSet
--- Add any CoVars free in the types of a telescope of lambda-binders
--- See Note [Gather occurrences of coercion variables]
-coVarOccs bndrs
- = foldr get emptyVarSet bndrs
- where
- get bndr cvs = (cvs `delVarSet` bndr) `unionVarSet`
- coVarsOfType (varType bndr)
+ -- It's OK to use nonDetStrictFoldUniqSet here because add_many_occ commutes
emptyDetails :: UsageDetails
---emptyDetails = EmptyUDs
emptyDetails = mkSimpleDetails emptyVarEnv
mkSimpleDetails :: OccInfoEnv -> UsageDetails
@@ -3534,7 +3521,6 @@ mkSimpleDetails env = UD { ud_env = env
, ud_z_tail = emptyVarEnv }
modifyUDEnv :: (OccInfoEnv -> OccInfoEnv) -> UsageDetails -> UsageDetails
--- modifyUDEnv f EmptyUDs = mkSimpleDetails (f emptyVarEnv)
modifyUDEnv f uds@(UD { ud_env = env }) = uds { ud_env = f env }
{-
@@ -3545,12 +3531,10 @@ emptyDetails = UD { ud_env = emptyVarEnv
-}
isEmptyDetails :: UsageDetails -> Bool
---isEmptyDetails EmptyUDs = True
isEmptyDetails (UD { ud_env = env }) = isEmptyVarEnv env
delDetails :: UsageDetails -> [Id] -> UsageDetails
-- Delete these binders from the UsageDetails
--- delDetails EmptyUDs _ = EmptyUDs
delDetails (UD { ud_env = env
, ud_z_many = z_many
, ud_z_in_lam = z_in_lam
@@ -3562,15 +3546,9 @@ delDetails (UD { ud_env = env
markAllMany, markAllInsideLam, markAllNonTail, markAllManyNonTail
:: UsageDetails -> UsageDetails
---markAllMany EmptyUDs = EmptyUDs
markAllMany ud@(UD { ud_env = env }) = ud { ud_z_many = env }
-
---markAllInsideLam EmptyUDs = EmptyUDs
markAllInsideLam ud@(UD { ud_env = env }) = ud { ud_z_in_lam = env }
-
---markAllNonTail EmptyUDs = EmptyUDs
markAllNonTail ud@(UD { ud_env = env }) = ud { ud_z_tail = env }
-
markAllManyNonTail = markAllMany . markAllNonTail -- effectively sets to noOccInfo
markAllInsideLamIf, markAllNonTailIf :: Bool -> UsageDetails -> UsageDetails
@@ -3582,7 +3560,6 @@ markAllNonTailIf True ud = markAllNonTail ud
markAllNonTailIf False ud = ud
lookupLocalDetails :: UsageDetails -> Id -> Maybe LocalOcc
---lookupLocalDetails EmptyUDs _ = Nothing
lookupLocalDetails (UD { ud_env = env }) id = lookupVarEnv env id
lookupTailCallInfo :: UsageDetails -> Id -> TailCallInfo
@@ -3600,13 +3577,10 @@ lookupDetails ud id = mkOccInfoByUnique ud (idUnique id)
usedIn :: Id -> UsageDetails -> Bool
v `usedIn` uds
| isExportedId v = True
- | otherwise = case uds of
--- EmptyUDs -> False
- UD { ud_env = env } -> v `elemVarEnv` env
+ | otherwise = v `elemVarEnv` ud_env uds
udFreeVars :: VarSet -> UsageDetails -> VarSet
-- Find the subset of bndrs that are mentioned in uds
--- udFreeVars _ EmptyUDs = emptyVarSet
udFreeVars bndrs (UD { ud_env = env }) = restrictFreeVars bndrs env
restrictFreeVars :: VarSet -> OccInfoEnv -> VarSet
@@ -3618,8 +3592,6 @@ restrictFreeVars bndrs fvs = restrictUniqSetToUFM bndrs fvs
combineUsageDetailsWith :: (LocalOcc -> LocalOcc -> LocalOcc)
-> UsageDetails -> UsageDetails -> UsageDetails
{-# INLINE combineUsageDetailsWith #-}
---combineUsageDetailsWith _ EmptyUDs ud2 = ud2
--- combineUsageDetailsWith _ ud1 EmptyUDs = ud1
combineUsageDetailsWith plus_occ_info
uds1@(UD { ud_env = env1, ud_z_many = z_many1, ud_z_in_lam = z_in_lam1, ud_z_tail = z_tail1 })
uds2@(UD { ud_env = env2, ud_z_many = z_many2, ud_z_in_lam = z_in_lam2, ud_z_tail = z_tail2 })
@@ -3632,8 +3604,6 @@ combineUsageDetailsWith plus_occ_info
, ud_z_tail = plusVarEnv z_tail1 z_tail2 }
mkOccInfoByUnique :: UsageDetails -> Unique -> OccInfo
---mkOccInfoByUnique EmptyUDs _
--- = IAmDead
mkOccInfoByUnique (UD { ud_env = env
, ud_z_many = z_many
, ud_z_in_lam = z_in_lam
@@ -3815,16 +3785,19 @@ tagRecBinders lvl body_uds details_s
setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr
setBinderOcc occ_info bndr
- | isTyVar bndr = bndr
- | isExportedId bndr = if isManyOccs (idOccInfo bndr)
- then bndr
- else setIdOccInfo bndr noOccInfo
- -- Don't use local usage info for visible-elsewhere things
- -- BUT *do* erase any IAmALoopBreaker annotation, because we're
- -- about to re-generate it and it shouldn't be "sticky"
-
+ | isTyVar bndr = bndr
+ | isNoOccInfo occ_info = zap_it
+ | isExportedId bndr = zap_it
+ -- Don't use occ_info (locally-generated) for visible-elsewhere things
+ -- BUT *do* erase any IAmALoopBreaker annotation, because we're
+ -- about to re-generate it and it shouldn't be "sticky"
| otherwise = setIdOccInfo bndr occ_info
+ where
+ bndr_info = idOccInfo bndr
+ zap_it | isNoOccInfo bndr_info = bndr
+ | otherwise = setIdOccInfo bndr noOccInfo
+
-- | Decide whether some bindings should be made into join points or not, based
-- on its occurrences. This is
-- Returns `False` if they can't be join points. Note that it's an
=====================================
compiler/GHC/Core/Rules.hs
=====================================
@@ -450,12 +450,19 @@ getRules (RuleEnv { re_local_rules = local_rule_base
, re_eps_rules = eps_rule_base
, re_visible_orphs = orphs }) fn
- | isLocalId fn
- = idCoreRules fn
-
| Just {} <- isDataConId_maybe fn -- Short cut for data constructor workers
= [] -- and wrappers, which never have any rules
+ | Just export_flag <- isLocalId_maybe fn
+ = -- LocalIds can't have rules in the local_rule_base (used for imported fns)
+ -- nor external packages; but there can (just) be rules in another module
+ -- in the home package, if it is exported
+ case export_flag of
+ NotExported -> idCoreRules fn
+ Exported -> case get home_rule_base of
+ [] -> idCoreRules fn
+ home_rules -> drop_orphs home_rules ++ idCoreRules fn
+
| otherwise
= case (get local_rule_base, get home_rule_base, get eps_rule_base) of
([], [], []) -> idCoreRules fn
=====================================
compiler/GHC/Types/Var.hs
=====================================
@@ -61,7 +61,7 @@ module GHC.Types.Var (
-- ** Predicates
isId, isTyVar, isTcTyVar,
- isLocalVar, isLocalId, isCoVar, isNonCoVarId, isTyCoVar,
+ isLocalVar, isLocalId, isLocalId_maybe, isCoVar, isNonCoVarId, isTyCoVar,
isGlobalId, isExportedId,
mustHaveLocalBinding,
@@ -94,6 +94,9 @@ module GHC.Types.Var (
tyVarSpecToBinder, tyVarSpecToBinders, tyVarReqToBinder, tyVarReqToBinders,
mapVarBndr, mapVarBndrs,
+ -- ** ExportFlag
+ ExportFlag(..),
+
-- ** Constructing TyVar's
mkTyVar, mkTcTyVar,
@@ -1239,6 +1242,10 @@ isLocalId :: Var -> Bool
isLocalId (Id { idScope = LocalId _ }) = True
isLocalId _ = False
+isLocalId_maybe :: Var -> Maybe ExportFlag
+isLocalId_maybe (Id { idScope = LocalId ef }) = Just ef
+isLocalId_maybe _ = Nothing
+
-- | 'isLocalVar' returns @True@ for type variables as well as local 'Id's
-- These are the variables that we need to pay attention to when finding free
-- variables, or doing dependency analysis.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0c0d689bb9017f3a2d99cbb342f744e1d349c51e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0c0d689bb9017f3a2d99cbb342f744e1d349c51e
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/20230715/3bdd1d53/attachment-0001.html>
More information about the ghc-commits
mailing list