[Git][ghc/ghc][wip/T17910] Fix for #23813

[Simon Peyton Jones (@simonpj)]

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


Commits:
d41b60cc by Simon Peyton Jones at 2023-08-08T23:42:35+01:00
Fix for #23813

Zap one-shot info when floating a join point to top level

- - - - -


2 changed files:

- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/SetLevels.hs


Changes:

=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -230,8 +230,10 @@ typeOneShot ty
 -- See Note [The state-transformer hack] in "GHC.Core.Opt.Arity"
 idStateHackOneShotInfo :: Id -> OneShotInfo
 idStateHackOneShotInfo id
-    | isStateHackType (idType id) = OneShotLam
-    | otherwise                   = idOneShotInfo id
+  = case idOneShotInfo id of
+       OneShotLam                                  -> OneShotLam
+       NoOneShotInfo | isStateHackType (idType id) -> OneShotLam
+                     | otherwise                   -> NoOneShotInfo
 
 -- | Returns whether the lambda associated with the 'Id' is
 --   certainly applied at most once


=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -1308,11 +1308,18 @@ lvlFloatRhs abs_vars dest_lvl env rec is_bot mb_join_arity rhs
                       = collectAnnBndrs rhs
     (env1, bndrs1)    = substBndrsSL NonRecursive env bndrs
     all_bndrs         = abs_vars ++ bndrs1
+
     (body_env, bndrs') | JoinPoint {} <- mb_join_arity
-                      = lvlJoinBndrs env1 dest_lvl rec all_bndrs
-                      | otherwise
-                      = case lvlLamBndrs env1 dest_lvl all_bndrs of
-                          (env2, bndrs') -> (placeJoinCeiling env2, bndrs')
+                       = if isTopLvl dest_lvl  -- No longer a join point
+                         then lvl_lam_bndrs (map zap_one_shot all_bndrs)
+                         else lvlJoinBndrs env1 dest_lvl rec all_bndrs
+                       | otherwise
+                       = lvl_lam_bndrs all_bndrs
+
+    zap_one_shot v | isId v    = clearOneShotLambda v
+                   | otherwise = v
+    lvl_lam_bndrs bndrs = case lvlLamBndrs env1 dest_lvl bndrs of
+                            (env2, bndrs') -> (placeJoinCeiling env2, bndrs')
         -- The important thing here is that we call lvlLamBndrs on
         -- all these binders at once (abs_vars and bndrs), so they
         -- all get the same major level.  Otherwise we create stupid



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

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