[Git][ghc/ghc][wip/strict-level] SetLevels: Name `lvl` binders according to context

[Ben Gamari (@bgamari)]

Ben Gamari pushed to branch wip/strict-level at Glasgow Haskell Compiler / GHC


Commits:
30dabb0c by Ben Gamari at 2025-03-01T11:40:36-05:00
SetLevels: Name `lvl` binders according to context

See #25802

- - - - -


1 changed file:

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


Changes:

=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -107,7 +107,7 @@ import GHC.Types.Literal      ( litIsTrivial )
 import GHC.Types.Demand       ( DmdSig, prependArgsDmdSig )
 import GHC.Types.Cpr          ( CprSig, prependArgsCprSig )
 import GHC.Types.Name         ( getOccName, mkSystemVarName )
-import GHC.Types.Name.Occurrence ( occNameFS )
+import GHC.Types.Name.Occurrence ( occNameFS, occNameString )
 import GHC.Types.Unique       ( hasKey )
 import GHC.Types.Tickish      ( tickishIsCode )
 import GHC.Types.Unique.Supply
@@ -128,6 +128,7 @@ import GHC.Utils.Panic
 import Data.Foldable ( toList )
 import Data.Functor.Identity ( Identity (..) )
 import Data.List.NonEmpty ( NonEmpty (..) )
+import Data.List ( intercalate )
 import Data.Maybe
 
 {-
@@ -637,7 +638,7 @@ lvlMFE env strict_ctxt ann_expr
   = do { expr1 <- lvlFloatRhs abs_vars dest_lvl rhs_env NonRecursive
                               is_bot_lam NotJoinPoint ann_expr
                   -- Treat the expr just like a right-hand side
-       ; var <- newLvlVar expr1 NotJoinPoint is_mk_static
+       ; var <- newLvlVar env expr1 NotJoinPoint is_mk_static
        ; let var2 = annotateBotStr var float_n_lams mb_bot_str
        ; return (Let (NonRec (TB var2 (FloatMe dest_lvl)) expr1)
                      (mkVarApps (Var var2) abs_vars)) }
@@ -658,7 +659,7 @@ lvlMFE env strict_ctxt ann_expr
                          Case expr1 (stayPut l1r ubx_bndr) box_ty
                              [Alt DEFAULT [] (App boxing_expr (Var ubx_bndr))]
 
-       ; var <- newLvlVar float_rhs NotJoinPoint is_mk_static
+       ; var <- newLvlVar env float_rhs NotJoinPoint is_mk_static
        ; let l1u      = incMinorLvlFrom env
              use_expr = Case (mkVarApps (Var var) abs_vars)
                              (stayPut l1u bx_bndr) expr_ty
@@ -1846,11 +1847,12 @@ newPolyBndrs dest_lvl
 {-# SPECIALIZE newPolyBndrs :: (MonadUnique m) => Level -> LevelEnv -> [OutVar] -> NonEmpty InId -> m (LevelEnv, NonEmpty OutId) #-}
 {-# SPECIALIZE newPolyBndrs :: (MonadUnique m) => Level -> LevelEnv -> [OutVar] -> Pair InId -> m (LevelEnv, Pair OutId) #-}
 
-newLvlVar :: LevelledExpr        -- The RHS of the new binding
+newLvlVar :: LevelEnv
+          -> LevelledExpr        -- The RHS of the new binding
           -> JoinPointHood       -- Its join arity, if it is a join point
           -> Bool                -- True <=> the RHS looks like (makeStatic ...)
           -> LvlM Id
-newLvlVar lvld_rhs join_arity_maybe is_mk_static
+newLvlVar env lvld_rhs join_arity_maybe is_mk_static
   = do { uniq <- getUniqueM
        ; return (add_join_info (mk_id uniq rhs_ty))
        }
@@ -1865,7 +1867,12 @@ newLvlVar lvld_rhs join_arity_maybe is_mk_static
       = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr"))
                             rhs_ty
       | otherwise
-      = mkSysLocal (mkFastString "lvl") uniq ManyTy rhs_ty
+      = mkSysLocal stem uniq ManyTy rhs_ty
+
+    stem =
+      case le_bind_ctxt env of
+        []  -> mkFastString "lvl"
+        ctx -> mkFastString $ intercalate "_" ("lvl" : map (occNameString . getOccName) ctx)
 
 -- | Clone the binders bound by a single-alternative case.
 cloneCaseBndrs :: Traversable t => LevelEnv -> Level -> t Var -> LvlM (LevelEnv, t Var)



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/30dabb0c7a0a79b68aeb7f315f75e9f55ef7aba2
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/20250301/b59ab714/attachment-0001.html>