[Git][ghc/ghc][wip/T22404] Wibbles
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Fri Jan 6 23:59:22 UTC 2023
Simon Peyton Jones pushed to branch wip/T22404 at Glasgow Haskell Compiler / GHC
Commits:
bf9bf5d9 by Simon Peyton Jones at 2023-01-06T23:59:03+00:00
Wibbles
- - - - -
1 changed file:
- compiler/GHC/Core/Opt/OccurAnal.hs
Changes:
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -744,24 +744,62 @@ occAnalBind env lvl ire (Rec pairs) thing_inside combine
occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine
| isTyVar bndr -- A type let; we don't gather usage info
- = WithUsageDetails body_uds (combine [NonRec bndr rhs] body')
+ = let !(WithUsageDetails body_uds res) = addInScope env [bndr] thing_inside
+ in WithUsageDetails body_uds (combine [NonRec bndr rhs] res)
- | isDeadBinder tagged_bndr
- = WithUsageDetails body_uds body' -- Drop dead code
+ -- Non-recursive join points
+ | NotTopLevel <- lvl
+ , mb_join@(Just {}) <- isJoinId_maybe bndr
+ , not (isStableUnfolding (realIdUnfolding bndr))
+ , not (idHasRules bndr)
+ = let -- Analyse the rhs first, generating rhs_uds
+ rhs_env = setRhsCtxt OccVanilla env
+ WithUsageDetails rhs_uds rhs' = occAnalRhs rhs_env NonRecursive mb_join rhs
+
+ -- Now analyse the body, adding the
+ -- join-point into the environment with addJoinPoint
+ (tagged_bndr, body_wuds)
+ = occAnalNonRecBody env lvl bndr $ \env ->
+ thing_inside (addJoinPoint env bndr rhs_uds)
+
+ -- Build the WithUsageDetails for the join-point binding
+ bind_wuds = WithUsageDetails emptyDetails [NonRec tagged_bndr rhs']
+ in
+ finishNonRec combine tagged_bndr bind_wuds body_wuds
+ -- The normal case
| otherwise
- = WithUsageDetails (bind_uds `andUDs` body_uds) (combine binds' body')
+ = let -- Analyse the body first, generating tagged_bndr
+ (tagged_bndr, body_wuds) = occAnalNonRecBody env lvl bndr thing_inside
- where
- -- Analyse the body
- WithUsageDetails body_uds (tagged_bndr, body')
+ -- Analyse the binding itself
+ bind_wuds = occAnalNonRecIdBind env ire tagged_bndr rhs
+ in
+ finishNonRec combine tagged_bndr bind_wuds body_wuds
+
+-----------------
+occAnalNonRecBody :: OccEnv -> TopLevelFlag -> Id
+ -> (OccEnv -> WithUsageDetails r) -- Scope of the bind
+ -> (Id, WithUsageDetails r)
+occAnalNonRecBody env lvl bndr thing_inside
+ = let !(WithUsageDetails uds (tagged_bndr, res))
= addInScope env [bndr] $ \env ->
- let WithUsageDetails usage res = thing_inside env
- tagged_bndr = tagNonRecBinder lvl usage bndr
- in WithUsageDetails usage (tagged_bndr, res)
+ let !(WithUsageDetails inner_uds res) = thing_inside env
+ tagged_bndr = tagNonRecBinder lvl inner_uds bndr
+ in WithUsageDetails inner_uds (tagged_bndr, res)
+ in (tagged_bndr, WithUsageDetails uds res)
- -- Analyse the binding itself
- WithUsageDetails bind_uds binds' = occAnalNonRecIdBind env ire tagged_bndr rhs
+-----------------
+finishNonRec :: ([CoreBind] -> r -> r) -- How to combine the scope with new binds
+ -> Id -> WithUsageDetails [CoreBind] -> WithUsageDetails r
+ -> WithUsageDetails r
+finishNonRec combine tagged_bndr
+ (WithUsageDetails bind_uds binds)
+ (WithUsageDetails body_uds body)
+ | isDeadBinder tagged_bndr
+ = WithUsageDetails body_uds body -- Drop dead code
+ | otherwise
+ = WithUsageDetails (bind_uds `andUDs` body_uds) (combine binds body)
-----------------
@@ -770,8 +808,8 @@ occAnalNonRecIdBind :: OccEnv -> ImpRuleEdges -> Id -> CoreExpr
occAnalNonRecIdBind !env imp_rule_edges tagged_bndr rhs
= WithUsageDetails rhs_usage [NonRec final_bndr rhs']
where
- final_bndr = tagged_bndr `setIdUnfolding` unf'
- `setIdSpecialisation` mkRuleInfo rules'
+ final_bndr = tagged_bndr `setIdUnfolding` unf'
+ `setIdSpecialisation` mkRuleInfo rules'
rhs_usage = rhs_uds `andUDs` unf_uds `andUDs` rule_uds
-- Get the join info from the *new* decision
@@ -2229,7 +2267,7 @@ occAnal env (Case scrut bndr ty alts)
WithUsageDetails alts_usage (tagged_bndr, alts')
= addInScope env [bndr] $ \env ->
let alt_env = addBndrSwap scrut' bndr $
- env { occ_encl = OccVanilla }
+ setRhsCtxt OccVanilla env
WithUsageDetails alts_usage alts' = do_alts alt_env alts
tagged_bndr = tagLamBinder alts_usage bndr
in WithUsageDetails alts_usage (tagged_bndr, alts')
@@ -2254,22 +2292,6 @@ occAnal env (Case scrut bndr ty alts)
WithUsageDetails rhs_usage (Alt con tagged_bndrs rhs')
occAnal env (Let bind body)
- | NonRec bndr rhs <- bind
- , mb_join@(Just {}) <- isJoinId_maybe bndr
- , not (isStableUnfolding (realIdUnfolding bndr))
- , not (idHasRules bndr)
- = -- This is where we extend occ_join_points!
- let WithUsageDetails rhs_usage rhs' = occAnalRhs env NonRecursive mb_join rhs
- in addInScope env [bndr] $ \ body_env ->
- let body_env1 = body_env { occ_join_points = extendVarEnv (occ_join_points env)
- bndr rhs_usage }
- WithUsageDetails body_usage body' = occAnal body_env1 body
- bndr' = tagNonRecBinder NotTopLevel body_usage bndr
- in if (bndr `usedIn` body_usage)
- then WithUsageDetails body_usage (Let (NonRec bndr' rhs') body')
- else WithUsageDetails body_usage body'
-
- | otherwise
= occAnalBind env NotTopLevel noImpRuleEdges bind
(\env -> occAnal env body) mkLets
@@ -2585,7 +2607,7 @@ isRhsEnv (OccEnv { occ_encl = cxt }) = case cxt of
_ -> False
addInScope :: OccEnv -> [Var] -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a
--- Needed for all Vars not just Ids
+-- Needed for all Vars not just Ids; a TyVar might have a CoVars in its kind
addInScope env@(OccEnv { occ_join_points = join_points }) bndrs thing_inside
= fix_up_uds $ thing_inside $ drop_shadowed_swaps $ drop_shadowed_joins env
where
@@ -2617,6 +2639,9 @@ addInScope env@(OccEnv { occ_join_points = join_points }) bndrs thing_inside
bad_join_rhs :: UsageDetails -> Bool
bad_join_rhs (UD { ud_env = rhs_usage }) = any (`elemVarEnv` rhs_usage) bndrs
+addJoinPoint :: OccEnv -> Id -> UsageDetails -> OccEnv
+addJoinPoint env bndr rhs_uds
+ = env { occ_join_points = extendVarEnv (occ_join_points env) bndr rhs_uds }
--------------------
transClosureFV :: VarEnv VarSet -> VarEnv VarSet
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bf9bf5d9e22e7587ef9b3975f54d8436294159db
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bf9bf5d9e22e7587ef9b3975f54d8436294159db
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/20230106/e2b52567/attachment-0001.html>
More information about the ghc-commits
mailing list