[Git][ghc/ghc][wip/T22404] More efficient now
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Wed Jul 12 23:33:40 UTC 2023
Simon Peyton Jones pushed to branch wip/T22404 at Glasgow Haskell Compiler / GHC
Commits:
16ad0494 by Simon Peyton Jones at 2023-07-13T00:33:23+01:00
More efficient now
- - - - -
1 changed file:
- compiler/GHC/Core/Opt/OccurAnal.hs
Changes:
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -2940,15 +2940,12 @@ addJoinPoint env bndr rhs_uds
mkZeroedForm :: UsageDetails -> UsageDetails
-- See Note [Occurrence analysis for join points] for "zeroed form"
-mkZeroedForm rhs_uds@(UD { ud_env = rhs_occs })
- = emptyDetails { ud_env = mapMaybeWithKeyUFM do_one rhs_occs }
+mkZeroedForm (UD { ud_env = rhs_occs })
+ = emptyDetails { ud_env = mapMaybeUFM do_one rhs_occs }
where
- do_one :: Unique -> OccInfo -> Maybe OccInfo
- do_one key occ = case doZappingByUnique rhs_uds key occ of
- ManyOccs {} -> Nothing
- occ@(OneOcc {}) -> Just (occ { occ_n_br = 0 })
- IAmDead -> pprPanic "addJoinPoint" (ppr key)
- IAmALoopBreaker {} -> pprPanic "addJoinPoint" (ppr key)
+ do_one :: LocalOcc -> Maybe LocalOcc
+ do_one ManyOccL = Nothing
+ do_one (OneOccL _ ic) = Just (OneOccL 0 ic)
--------------------
transClosureFV :: VarEnv VarSet -> VarEnv VarSet
@@ -3369,10 +3366,11 @@ info then simply means setting the corresponding zapped set to the whole
'OccInfoEnv', a fast O(1) operation.
-}
-type OccInfoEnv = IdEnv OccInfo -- A finite map from an expression's
- -- free variables to their usage
- -- INVARIANT: never IAmDead, or IAmLoopBreaker
- -- Deadness is signalled by not being in the map at all
+type OccInfoEnv = IdEnv LocalOcc -- A finite map from an expression's
+ -- free variables to their usage
+
+data LocalOcc = OneOccL {-# UNPACK #-} !Int !InterestingCxt
+ | ManyOccL
type ZappedSet = OccInfoEnv -- Values are ignored
@@ -3380,12 +3378,17 @@ data UsageDetails
= UD { ud_env :: !OccInfoEnv
, ud_z_many :: !ZappedSet -- apply 'markMany' to these
, ud_z_in_lam :: !ZappedSet -- apply 'markInsideLam' to these
- , ud_z_no_tail :: !ZappedSet } -- apply 'markNonTail' to these
- -- INVARIANT: All three zapped sets are subsets of the OccInfoEnv
+ , ud_tail :: !(IdEnv TailCallInfo)
+ }
+ -- INVARIANT: Both zapped sets are subsets of ud_env
instance Outputable UsageDetails where
- ppr ud = ppr (ud_env (flattenUsageDetails ud))
-
+ 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) ])
+ where
+ do_one :: Unique -> LocalOcc -> [(Unique,LocalOcc)] -> [(Unique,LocalOcc)]
+ do_one uniq occ occs = (uniq, occ) : occs
---------------------
-- | TailUsageDetails captures the result of applying 'occAnalLamTail'
@@ -3409,7 +3412,7 @@ data WithTailUsageDetails a = WTUD !TailUsageDetails !a
andUDs, orUDs
:: UsageDetails -> UsageDetails -> UsageDetails
-andUDs = combineUsageDetailsWith addOccInfo
+andUDs = combineUsageDetailsWith andOccInfo
orUDs = combineUsageDetailsWith orOccInfo
mkOneOcc :: OccEnv -> Id -> InterestingCxt -> JoinArity -> UsageDetails
@@ -3426,15 +3429,13 @@ mkOneOcc !env id int_cxt arity
= one_occ_uds
where
- one_occ_uds = emptyDetails { ud_env = unitVarEnv id one_occ_info }
- one_occ_info = OneOcc { occ_in_lam = NotInsideLam
- , occ_n_br = oneBranch
- , occ_int_cxt = int_cxt
- , occ_tail = AlwaysTailCalled arity }
+ one_occ_uds = emptyDetails
+ { ud_env = unitVarEnv id (OneOccL 1 int_cxt)
+ , ud_tail = unitVarEnv id (AlwaysTailCalled arity) }
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 noOccInfo }
+addManyOccId ud id = ud { ud_env = extendVarEnv (ud_env ud) id ManyOccL }
-- Add several occurrences, assumed not to be tail calls
addManyOcc :: Var -> UsageDetails -> UsageDetails
@@ -3463,20 +3464,27 @@ emptyDetails :: UsageDetails
emptyDetails = UD { ud_env = emptyVarEnv
, ud_z_many = emptyVarEnv
, ud_z_in_lam = emptyVarEnv
- , ud_z_no_tail = emptyVarEnv }
+ , ud_tail = emptyVarEnv }
isEmptyDetails :: UsageDetails -> Bool
isEmptyDetails = isEmptyVarEnv . ud_env
delDetails :: UsageDetails -> [Id] -> UsageDetails
-- Delete these binders from the UsageDetails
-delDetails ud bndrs = ud `alterUsageDetails` (`delVarEnvList` bndrs)
+delDetails (UD { ud_env = env
+ , ud_z_many = z_many
+ , ud_z_in_lam = z_in_lam
+ , ud_tail = tail }) bndrs
+ = UD { ud_env = env `delVarEnvList` bndrs
+ , ud_z_many = z_many `delVarEnvList` bndrs
+ , ud_z_in_lam = z_in_lam `delVarEnvList` bndrs
+ , ud_tail = tail `delVarEnvList` bndrs }
markAllMany, markAllInsideLam, markAllNonTail, markAllManyNonTail
:: UsageDetails -> UsageDetails
markAllMany ud = ud { ud_z_many = ud_env ud }
markAllInsideLam ud = ud { ud_z_in_lam = ud_env ud }
-markAllNonTail ud = ud { ud_z_no_tail = ud_env ud }
+markAllNonTail ud = ud { ud_tail = emptyVarEnv }
markAllManyNonTail = markAllMany . markAllNonTail -- effectively sets to noOccInfo
markAllInsideLamIf, markAllNonTailIf :: Bool -> UsageDetails -> UsageDetails
@@ -3490,7 +3498,7 @@ markAllNonTailIf False ud = ud
lookupDetails :: UsageDetails -> Id -> OccInfo
lookupDetails ud id
= case lookupVarEnv (ud_env ud) id of
- Just occ -> doZapping ud id occ
+ Just occ -> mkOccInfo ud id occ
Nothing -> IAmDead
usedIn :: Id -> UsageDetails -> Bool
@@ -3515,7 +3523,7 @@ restrictFreeVars bndrs fvs = restrictUniqSetToUFM bndrs fvs
-------------------
-- Auxiliary functions for UsageDetails implementation
-combineUsageDetailsWith :: (OccInfo -> OccInfo -> OccInfo)
+combineUsageDetailsWith :: (LocalOcc -> LocalOcc -> LocalOcc)
-> UsageDetails -> UsageDetails -> UsageDetails
combineUsageDetailsWith plus_occ_info ud1 ud2
| isEmptyDetails ud1 = ud2
@@ -3524,35 +3532,34 @@ combineUsageDetailsWith plus_occ_info ud1 ud2
= 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_no_tail = plusVarEnv (ud_z_no_tail ud1) (ud_z_no_tail ud2) }
+ , ud_tail = plusVarEnv_C andTailCallInfo (ud_tail ud1) (ud_tail ud2) }
-doZapping :: UsageDetails -> Var -> OccInfo -> OccInfo
-doZapping ud var occ
- = doZappingByUnique ud (varUnique var) occ
+mkOccInfo :: UsageDetails -> Var -> LocalOcc -> OccInfo
+mkOccInfo ud var occ = mkOccInfoByUnique ud (varUnique var) occ
-doZappingByUnique :: UsageDetails -> Unique -> OccInfo -> OccInfo
-doZappingByUnique (UD { ud_z_many = many
- , ud_z_in_lam = in_lam
- , ud_z_no_tail = no_tail })
+mkOccInfoByUnique :: UsageDetails -> Unique -> LocalOcc -> OccInfo
+mkOccInfoByUnique (UD { ud_z_many = z_many
+ , ud_z_in_lam = z_in_lam
+ , ud_tail = tail_env })
uniq occ
- = occ2
+ = case occ of
+ OneOccL n_br int_cxt
+ | not (uniq `elemVarEnvByKey`z_many)
+ -> OneOcc { occ_in_lam = in_lam
+ , occ_n_br = n_br
+ , occ_int_cxt = int_cxt
+ , occ_tail = tail }
+
+ _other -- ManyOccL and zapped OneOccL
+ -> ManyOccs { occ_tail = tail }
+
where
- occ1 | uniq `elemVarEnvByKey` many = markMany occ
- | uniq `elemVarEnvByKey` in_lam = markInsideLam occ
- | otherwise = occ
- occ2 | uniq `elemVarEnvByKey` no_tail = markNonTail occ1
- | otherwise = occ1
-
-alterUsageDetails :: UsageDetails -> (OccInfoEnv -> OccInfoEnv) -> UsageDetails
-alterUsageDetails !ud f
- = UD { ud_env = f (ud_env ud)
- , ud_z_many = f (ud_z_many ud)
- , ud_z_in_lam = f (ud_z_in_lam ud)
- , ud_z_no_tail = f (ud_z_no_tail ud) }
-
-flattenUsageDetails :: UsageDetails -> UsageDetails
-flattenUsageDetails ud@(UD { ud_env = env })
- = emptyDetails { ud_env = mapUFM_Directly (doZappingByUnique ud) env }
+ tail = case lookupVarEnv_Directly tail_env uniq of
+ Nothing -> NoTailCallInfo
+ Just tc -> tc
+
+ in_lam | uniq `elemVarEnvByKey` z_in_lam = IsInsideLam
+ | otherwise = NotInsideLam
-------------------
-- See Note [Adjusting right-hand sides]
@@ -3833,44 +3840,21 @@ See Invariant 2a of Note [Invariants on join points] in GHC.Core
************************************************************************
-}
-markMany, markInsideLam, markNonTail :: OccInfo -> OccInfo
-
-markMany IAmDead = IAmDead
-markMany occ = ManyOccs { occ_tail = occ_tail occ }
-
-markInsideLam occ@(OneOcc {}) = occ { occ_in_lam = IsInsideLam }
-markInsideLam occ = occ
-
+markNonTail :: OccInfo -> OccInfo
markNonTail IAmDead = IAmDead
markNonTail occ = occ { occ_tail = NoTailCallInfo }
-addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo
+andOccInfo, orOccInfo :: LocalOcc -> LocalOcc -> LocalOcc
-addOccInfo a1 a2 = assert (not (isDeadOcc a1 || isDeadOcc a2)) $
- ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo`
- tailCallInfo a2 }
- -- Both branches are at least One
- -- (Argument is never IAmDead)
+andOccInfo _ _ = ManyOccL
-- (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 })
- (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 }
+orOccInfo (OneOccL nbr1 int_cxt1) (OneOccL nbr2 int_cxt2)
+ = OneOccL (nbr1 + nbr2) (int_cxt1 `mappend` int_cxt2)
+
+orOccInfo _ _ = ManyOccL
andTailCallInfo :: TailCallInfo -> TailCallInfo -> TailCallInfo
andTailCallInfo info@(AlwaysTailCalled arity1) (AlwaysTailCalled arity2)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/16ad0494646104fe1c3183210ef1f3ac775f021e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/16ad0494646104fe1c3183210ef1f3ac775f021e
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/20230712/8d88b5c4/attachment-0001.html>
More information about the ghc-commits
mailing list