[Git][ghc/ghc][wip/T22404] Wibbles

[Simon Peyton Jones (@simonpj)]

Simon Peyton Jones pushed to branch wip/T22404 at Glasgow Haskell Compiler / GHC


Commits:
7a037e68 by Simon Peyton Jones at 2023-01-05T15:23:35+00:00
Wibbles

- - - - -


1 changed file:

- compiler/GHC/Core/Opt/OccurAnal.hs


Changes:

=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -753,11 +753,14 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine
   = WithUsageDetails (bind_uds `andUDs` body_uds) (combine binds' body')
 
   where
+    -- Analyse the body
     WithUsageDetails body_uds (tagged_bndr, body')
           = addInScope env [bndr] $ \env ->
             let WithUsageDetails usage res = thing_inside env
                 tagged_bndr = tagNonRecBinder lvl usage bndr
             in WithUsageDetails usage (tagged_bndr, res)
+
+    -- Analyse the binding itself
     WithUsageDetails bind_uds binds' = occAnalNonRecIdBind env ire tagged_bndr rhs
 
 
@@ -2236,10 +2239,7 @@ occAnal env (Case scrut bndr ty alts)
     in WithUsageDetails total_usage (Case scrut' tagged_bndr ty alts')
   where
     do_alts :: OccEnv -> [CoreAlt] -> WithUsageDetails [CoreAlt]
-    do_alts _ []         = WithUsageDetails emptyDetails []
-    do_alts env [alt]    = WithUsageDetails uds          [alt']
-      where
-        WithUsageDetails uds alt' = do_alt env alt
+    do_alts _   []         = WithUsageDetails emptyDetails []
     do_alts env (alt:alts) = WithUsageDetails (uds1 `orUDs` uds2) (alt':alts')
       where
         WithUsageDetails uds1 alt'  = do_alt  env alt
@@ -2257,7 +2257,8 @@ occAnal env (Let bind body)
   , mb_join@(Just {}) <- isJoinId_maybe bndr
   , not (isStableUnfolding (realIdUnfolding bndr))
   , not (idHasRules bndr)
-  = let WithUsageDetails rhs_usage rhs' = occAnalRhs env NonRecursive mb_join rhs
+  = -- 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 }
@@ -2289,7 +2290,7 @@ occAnalArgs !env fun args !one_shots
 {-
 Applications are dealt with specially because we want
 the "build hack" to work.
-g
+
 Note [Arguments of let-bound constructors]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider
@@ -2584,21 +2585,30 @@ isRhsEnv (OccEnv { occ_encl = cxt }) = case cxt of
 
 addInScope :: OccEnv -> [Var] -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a
 -- Needed for all Vars not just Ids
--- See Note [The binder-swap substitution] (BS3)
-addInScope env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = bs_rng_vars
-                       , occ_join_points = join_points }) bndrs thing_inside
-
-  | any (`elemVarSet` bs_rng_vars) bndrs
-  = fix_up_uds $
-    thing_inside (env1 { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet })
-
-  | otherwise
-  = fix_up_uds $
-    thing_inside (env1 { occ_bs_env = swap_env `delVarEnvList` bndrs })
+addInScope env@(OccEnv { occ_join_points = join_points }) bndrs thing_inside
+  = fix_up_uds $ thing_inside $ drop_shadowed_swaps $ drop_shadowed_joins env
   where
-    env1 | isEmptyVarEnv bad_joins = env
-         | otherwise               = env { occ_join_points = good_joins }
 
+    drop_shadowed_swaps :: OccEnv -> OccEnv
+    -- See Note [The binder-swap substitution] (BS3)
+    drop_shadowed_swaps env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = bs_rng_vars })
+      | any (`elemVarSet` bs_rng_vars) bndrs
+      = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }
+      | otherwise
+      = env { occ_bs_env = swap_env `delVarEnvList` bndrs }
+
+    drop_shadowed_joins :: OccEnv -> OccEnv
+    -- See Note [Occurrence analysis for join points]
+    drop_shadowed_joins env
+       | isEmptyVarEnv bad_joins
+       , not (any (`elemVarEnv` join_points) bndrs)
+                                 = env -- Non-allocating short cut; common case
+       | otherwise               = env { occ_join_points = good_joins `delVarEnvList` bndrs}
+       where
+
+    fix_up_uds :: WithUsageDetails a -> WithUsageDetails a
+    -- Add usage info for (a) CoVars used in the types of bndrs
+    -- and (b) occ_join_points that we cannot push inwards because of shadowing
     fix_up_uds (WithUsageDetails uds res)
       = with_joins `seq`
         WithUsageDetails with_joins res
@@ -2612,6 +2622,7 @@ addInScope env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = bs_rng_vars
     bad_join_rhs :: UsageDetails -> Bool
     bad_join_rhs (UD { ud_env = rhs_usage }) = any (`elemVarEnv` rhs_usage) bndrs
 
+
 --------------------
 transClosureFV :: VarEnv VarSet -> VarEnv VarSet
 -- If (f,g), (g,h) are in the input, then (f,h) is in the output
@@ -3032,9 +3043,10 @@ 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 ids to their usage
-                -- INVARIANT: never IAmDead
-                -- Deadness is signalled by not being in the map at all
+type OccInfoEnv = IdEnv OccInfo -- A finite map from an expression's
+                                -- free variables to their usage
+       -- INVARIANT: never IAmDead
+       -- Deadness is signalled by not being in the map at all
 
 type ZappedSet = OccInfoEnv -- Values are ignored
 



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7a037e68cd4ada7c76581f7ba2bc62b435de0a89

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7a037e68cd4ada7c76581f7ba2bc62b435de0a89
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/20230105/db7aef01/attachment-0001.html>