[Git][ghc/ghc][wip/T22404] Wibbles to efficiency
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Fri Jul 14 16:57:36 UTC 2023
Simon Peyton Jones pushed to branch wip/T22404 at Glasgow Haskell Compiler / GHC
Commits:
f15c4107 by Simon Peyton Jones at 2023-07-14T17:57:11+01:00
Wibbles to efficiency
Esp simplify occ_join_points
- - - - -
1 changed file:
- compiler/GHC/Core/Opt/OccurAnal.hs
Changes:
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -1677,7 +1677,8 @@ makeNode :: OccEnv -> ImpRuleEdges -> VarSet
-> (Var, CoreExpr) -> LetrecNode
-- See Note [Recursive bindings: the grand plan]
makeNode !env imp_rule_edges bndr_set (bndr, rhs)
- = DigraphNode { node_payload = details
+ = -- pprTrace "makeNode" (ppr bndr <+> ppr (sizeVarSet bndr_set)) $
+ DigraphNode { node_payload = details
, node_key = varUnique bndr
, node_dependencies = nonDetKeysUniqSet scope_fvs }
-- It's OK to use nonDetKeysUniqSet here as stronglyConnCompFromEdgedVerticesR
@@ -1706,7 +1707,7 @@ makeNode !env imp_rule_edges bndr_set (bndr, rhs)
inl_fvs = udFreeVars bndr_set unadj_inl_uds
-- inl_fvs: vars that would become free if the function was inlined.
- -- We conservatively approximate that by thefree vars from the RHS
+ -- We conservatively approximate that by the free vars from the RHS
-- and the unfolding together.
-- See Note [inl_fvs]
@@ -2475,7 +2476,7 @@ occAnal env (Tick tickish body)
= WUD (markAllNonTail usage) (Tick tickish body')
| Breakpoint _ _ ids _ <- tickish
- = WUD (usage_lam `andUDs` foldl' addManyOccId emptyDetails ids) (Tick tickish body')
+ = WUD (addManyOccs usage_lam (mkVarSet ids)) (Tick tickish body')
-- never substitute for any of the Ids in a Breakpoint
| otherwise
@@ -2786,7 +2787,7 @@ data OccEnv
-- Vars (TyVars and Ids) free in the range of occ_bs_env
-- Usage details of the RHS of in-scope non-recursive join points
- , occ_join_points :: !(IdEnv UsageDetails)
+ , occ_join_points :: !(IdEnv OccInfoEnv)
-- Invariant: no Id maps to emptyDetails
}
@@ -2870,7 +2871,7 @@ setNonTailCtxt ctxt !env
-- emptyDetails, which in turn causes a panic in mkOneOcc
#ifdef DEBUG
zapped_jp_env
- = mapVarEnv (\ _ -> emptyDetails) $
+ = mapVarEnv (\ _ -> emptyVarEnv) $
occ_join_points env
#else
zapped_jp_env = emptyVarEnv
@@ -2938,22 +2939,25 @@ addInScope env@(OccEnv { occ_in_scope = in_scope, occ_join_points = join_points
with_co_var_occs = trimmed_uds `addManyOccs` coVarOccs bndrs
add_bad_joins :: WithUsageDetails a -> WithUsageDetails a
- -- Add usage infor for occ_join_points that we cannot push inwards
+ -- Add usage info for occ_join_points that we cannot push inwardsa
-- because of shadowing
- add_bad_joins wuds@(WUD uds res)
- | isEmptyVarEnv bad_joins -- Fast path for common case
- = wuds
- | otherwise
- = WUD (nonDetStrictFoldUFM_Directly add_bad_join uds bad_joins) res
-
- add_bad_join :: Unique -> UsageDetails -- Bad join and its usage details
- -> UsageDetails -> UsageDetails
-- See Note [Occurrence analysis for join points] wrinkle (W2)
- add_bad_join uniq bad_join_uds uds
- | uniq `elemUFM_Directly` ud_env uds = uds `andUDs` bad_join_uds
- | otherwise = uds
+ add_bad_joins wuds@(WUD body_uds res)
+ | isEmptyVarEnv bad_joins = wuds -- Fast path for common case
+ | otherwise = WUD (modifyUDEnv extend_with_bad_joins body_uds) res
+ where
+ bad_joins :: IdEnv OccInfoEnv
+ bad_joins = join_points -- All of them, for simplicity
+
+ extend_with_bad_joins :: OccInfoEnv -> OccInfoEnv
+ extend_with_bad_joins env
+ = nonDetStrictFoldUFM_Directly add_bad_join env bad_joins
+
+ add_bad_join :: Unique -> OccInfoEnv -> OccInfoEnv -> OccInfoEnv
+ add_bad_join uniq join_env env
+ | uniq `elemVarEnvByKey` env = env `plusVarEnv` join_env
+ | otherwise = env
- bad_joins = join_points
{-
bad_joins, good_joins :: IdEnv UsageDetails
(bad_joins, good_joins) = partitionVarEnv bad_join_rhs join_points
@@ -2964,17 +2968,19 @@ addInScope env@(OccEnv { occ_in_scope = in_scope, occ_join_points = join_points
addJoinPoint :: OccEnv -> Id -> UsageDetails -> OccEnv
addJoinPoint env bndr rhs_uds
- | isEmptyDetails zeroed_form
+ | isEmptyVarEnv zeroed_form
= env
| otherwise
= env { occ_join_points = extendVarEnv (occ_join_points env) bndr zeroed_form }
where
zeroed_form = mkZeroedForm rhs_uds
-mkZeroedForm :: UsageDetails -> UsageDetails
+mkZeroedForm :: UsageDetails -> OccInfoEnv
-- See Note [Occurrence analysis for join points] for "zeroed form"
+--mkZeroedForm EmptyUDs
+-- = emptyVarEnv
mkZeroedForm (UD { ud_env = rhs_occs })
- = emptyDetails { ud_env = mapMaybeUFM do_one rhs_occs }
+ = mapMaybeUFM do_one rhs_occs
where
do_one :: LocalOcc -> Maybe LocalOcc
do_one (ManyOccL {}) = Nothing
@@ -3428,12 +3434,15 @@ data UsageDetails
, ud_z_tail :: !ZappedSet
}
-- INVARIANT: All three zapped sets are subsets of ud_env
+-- | EmptyUDs
instance Outputable UsageDetails where
- ppr ud = text "UD" <+> (braces $ fsep $ punctuate comma $
- [ ppr uq <+> text ":->" <+> ppr (mkOccInfoByUnique ud uq local_occ)
- | (uq, local_occ) <- nonDetStrictFoldVarEnv_Directly do_one [] (ud_env ud) ])
- $$ nest 2 (text "ud_z_tail" <+> ppr (ud_z_tail ud))
+-- 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)
+ | (uq, _) <- nonDetStrictFoldVarEnv_Directly do_one [] env ])
+ $$ nest 2 (text "ud_z_tail" <+> ppr z_tail)
where
do_one :: Unique -> LocalOcc -> [(Unique,LocalOcc)] -> [(Unique,LocalOcc)]
do_one uniq occ occs = (uniq, occ) : occs
@@ -3470,26 +3479,20 @@ mkOneOcc !env id int_cxt arity
| Just join_uds <- lookupVarEnv (occ_join_points env) id
= -- pprTrace "mkOneOcc" (ppr id $$ ppr uds) $
- assertPpr (not (isEmptyDetails join_uds)) (ppr id) $
- one_occ_uds `andUDs` join_uds
+ assertPpr (not (isEmptyVarEnv join_uds)) (ppr id) $
+ mkSimpleDetails (extendVarEnv join_uds id occ)
| otherwise
- = one_occ_uds
+ = mkSimpleDetails (unitVarEnv id occ)
where
occ = OneOccL { lo_n_br = 1, lo_int_cxt = int_cxt
, lo_tail = AlwaysTailCalled arity }
- one_occ_uds = emptyDetails { ud_env = unitVarEnv id occ }
-
-addManyOccId :: UsageDetails -> Id -> UsageDetails
--- Add the non-committal (id :-> noOccInfo) to the usage details
-addManyOccId ud id = ud { ud_env = extendVarEnv (ud_env ud) id
- (ManyOccL NoTailCallInfo) }
-- Add several occurrences, assumed not to be tail calls
-addManyOcc :: Var -> UsageDetails -> UsageDetails
-addManyOcc v u | isId v = addManyOccId u v
- | otherwise = u
+add_many_occ :: Var -> OccInfoEnv -> OccInfoEnv
+add_many_occ v env | isId v = extendVarEnv env v (ManyOccL NoTailCallInfo)
+ | otherwise = env
-- Give a non-committal binder info (i.e noOccInfo) because
-- a) Many copies of the specialised thing can appear
-- b) We don't want to substitute a BIG expression inside a RULE
@@ -3497,8 +3500,14 @@ addManyOcc v u | isId v = addManyOccId u v
-- (Same goes for INLINE.)
addManyOccs :: UsageDetails -> VarSet -> UsageDetails
-addManyOccs usage id_set = nonDetStrictFoldUniqSet addManyOcc usage id_set
- -- It's OK to use nonDetStrictFoldUniqSet here because addManyOcc commutes
+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 }
+ 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
@@ -3510,16 +3519,33 @@ coVarOccs bndrs
coVarsOfType (varType bndr)
emptyDetails :: UsageDetails
+--emptyDetails = EmptyUDs
+emptyDetails = mkSimpleDetails emptyVarEnv
+
+mkSimpleDetails :: OccInfoEnv -> UsageDetails
+mkSimpleDetails env = UD { ud_env = env
+ , ud_z_many = emptyVarEnv
+ , ud_z_in_lam = emptyVarEnv
+ , 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 }
+
+{-
emptyDetails = UD { ud_env = emptyVarEnv
, ud_z_many = emptyVarEnv
, ud_z_in_lam = emptyVarEnv
, ud_z_tail = emptyVarEnv }
+-}
isEmptyDetails :: UsageDetails -> Bool
-isEmptyDetails = isEmptyVarEnv . ud_env
+--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
@@ -3531,10 +3557,16 @@ 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
+
+markAllManyNonTail = markAllMany . markAllNonTail -- effectively sets to noOccInfo
markAllInsideLamIf, markAllNonTailIf :: Bool -> UsageDetails -> UsageDetails
@@ -3545,28 +3577,32 @@ markAllNonTailIf True ud = markAllNonTail ud
markAllNonTailIf False ud = ud
lookupLocalDetails :: UsageDetails -> Id -> Maybe LocalOcc
-lookupLocalDetails uds id = lookupVarEnv (ud_env uds) id
+--lookupLocalDetails EmptyUDs _ = Nothing
+lookupLocalDetails (UD { ud_env = env }) id = lookupVarEnv env id
lookupTailCallInfo :: UsageDetails -> Id -> TailCallInfo
lookupTailCallInfo uds id
- | not (id `elemVarEnv` ud_z_tail uds)
- , Just occ <- lookupLocalDetails uds id
+ | UD { ud_z_tail = z_tail, ud_env = env } <- uds
+ , not (id `elemVarEnv` z_tail)
+ , Just occ <- lookupVarEnv env id
= localTailCallInfo occ
| otherwise
= NoTailCallInfo
lookupDetails :: UsageDetails -> Id -> OccInfo
-lookupDetails ud id
- = case lookupLocalDetails ud id of
- Just occ -> mkOccInfo ud id occ
- Nothing -> IAmDead
+lookupDetails ud id = mkOccInfoByUnique ud (idUnique id)
usedIn :: Id -> UsageDetails -> Bool
-v `usedIn` ud = isExportedId v || v `elemVarEnv` ud_env ud
+v `usedIn` uds
+ | isExportedId v = True
+ | otherwise = case uds of
+-- EmptyUDs -> False
+ UD { ud_env = env } -> v `elemVarEnv` env
udFreeVars :: VarSet -> UsageDetails -> VarSet
-- Find the subset of bndrs that are mentioned in uds
-udFreeVars bndrs ud = restrictFreeVars bndrs (ud_env ud)
+-- udFreeVars _ EmptyUDs = emptyVarSet
+udFreeVars bndrs (UD { ud_env = env }) = restrictFreeVars bndrs env
restrictFreeVars :: VarSet -> OccInfoEnv -> VarSet
restrictFreeVars bndrs fvs = restrictUniqSetToUFM bndrs fvs
@@ -3576,26 +3612,32 @@ restrictFreeVars bndrs fvs = restrictUniqSetToUFM bndrs fvs
combineUsageDetailsWith :: (LocalOcc -> LocalOcc -> LocalOcc)
-> UsageDetails -> UsageDetails -> UsageDetails
-combineUsageDetailsWith plus_occ_info ud1 ud2
- | isEmptyDetails ud1 = ud2
- | isEmptyDetails ud2 = ud1
+{-# 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 })
+ | isEmptyVarEnv env1 = uds2
+ | isEmptyVarEnv env2 = uds1
| otherwise
- = UD { ud_env = plusVarEnv_C plus_occ_info (ud_env ud1) (ud_env ud2)
- , ud_z_many = plusVarEnv (ud_z_many ud1) (ud_z_many ud2)
- , ud_z_in_lam = plusVarEnv (ud_z_in_lam ud1) (ud_z_in_lam ud2)
- , ud_z_tail = plusVarEnv (ud_z_tail ud1) (ud_z_tail ud2) }
-
-mkOccInfo :: UsageDetails -> Var -> LocalOcc -> OccInfo
-mkOccInfo ud var occ = mkOccInfoByUnique ud (varUnique var) occ
-
-mkOccInfoByUnique :: UsageDetails -> Unique -> LocalOcc -> OccInfo
-mkOccInfoByUnique (UD { ud_z_many = z_many
+ = UD { ud_env = plusVarEnv_C plus_occ_info env1 env2
+ , ud_z_many = plusVarEnv z_many1 z_many2
+ , ud_z_in_lam = plusVarEnv z_in_lam1 z_in_lam2
+ , 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
, ud_z_tail = z_tail })
- uniq occ
- = case occ of
- OneOccL { lo_n_br = n_br, lo_int_cxt = int_cxt
- , lo_tail = tail_info }
+ uniq
+ = case lookupVarEnv_Directly env uniq of
+ Nothing -> IAmDead
+ Just (OneOccL { lo_n_br = n_br, lo_int_cxt = int_cxt
+ , lo_tail = tail_info })
| uniq `elemVarEnvByKey`z_many
-> ManyOccs { occ_tail = mk_tail_info tail_info }
| otherwise
@@ -3607,7 +3649,7 @@ mkOccInfoByUnique (UD { ud_z_many = z_many
in_lam | uniq `elemVarEnvByKey` z_in_lam = IsInsideLam
| otherwise = NotInsideLam
- ManyOccL tail_info -> ManyOccs { occ_tail = mk_tail_info tail_info }
+ Just (ManyOccL tail_info) -> ManyOccs { occ_tail = mk_tail_info tail_info }
where
mk_tail_info ti
| uniq `elemVarEnvByKey` z_tail = NoTailCallInfo
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f15c4107927bd578af992c35fd9a8086482dd290
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f15c4107927bd578af992c35fd9a8086482dd290
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/20230714/af816b99/attachment-0001.html>
More information about the ghc-commits
mailing list