[Git][ghc/ghc][wip/T22404] Further wibbles

[Simon Peyton Jones (@simonpj)]

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


Commits:
5a7c81a5 by Simon Peyton Jones at 2023-07-14T23:46:38+01:00
Further wibbles

- - - - -


1 changed file:

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


Changes:

=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -964,7 +964,7 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine
     else let
         unf     = idUnfolding bndr
         rhs_env = addOneShotsFromDmd bndr $
-                  setNonTailCtxt OccRhs env
+                  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
@@ -1034,8 +1034,7 @@ occAnalNonRecRhs !env imp_rule_edges mb_join bndr rhs
     --------- Right hand side ---------
     env1 | is_join_point = setTailCtxt env
          | otherwise     = setNonTailCtxt rhs_ctxt env
-    rhs_ctxt | certainly_inline = OccVanilla -- See Note [Cascading inlines]
-             | otherwise        = OccRhs
+    rhs_ctxt = mkNonRecRhsCtxt bndr unf
 
     -- See Note [Sources of one-shot information]
     rhs_env = addOneShotsFromDmd bndr env1
@@ -1075,7 +1074,13 @@ occAnalNonRecRhs !env imp_rule_edges mb_join bndr rhs
     add_rule_uds (_, l, r) uds_s
       = (l `andUDs` adjustTailArity mb_join r) : uds_s
 
+
     ----------
+mkNonRecRhsCtxt :: Id -> Unfolding -> OccEncl
+mkNonRecRhsCtxt bndr unf
+  | certainly_inline = OccVanilla -- See Note [Cascading inlines]
+  | otherwise        = OccRhs
+  where
     certainly_inline -- See Note [Cascading inlines]
       = -- certainly_inline is only used for non-join points,so idOccInfo is valid
         case idOccInfo bndr of
@@ -2560,10 +2565,10 @@ occAnalArgs !env fun args !one_shots
         !(WUD arg_uds arg') = occAnal arg_env arg
         !(arg_env, one_shots')
             | isTypeArg arg
-            = (env, one_shots)
+            = (env_args, one_shots)
             | otherwise
             = case one_shots of
-                []                -> (env, []) -- Fast path; one_shots is often empty
+                []                -> (env_args, []) -- Fast path; one_shots is often empty
                 (os : one_shots') -> (addOneShots os env_args, one_shots')
 
 {-



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5a7c81a55e84fcdfaecc6a027c434a43677bc6a0

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5a7c81a55e84fcdfaecc6a027c434a43677bc6a0
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/981b8d56/attachment-0001.html>