Zubin pushed to branch wip/strict-level at Glasgow Haskell Compiler / GHC Commits: 2f29500c by Ben Gamari at 2025-04-23T15:52:30+05:30 SetLevels: Track binding context In preparation to use this information to provide more context-sensitive naming for generated `lvl_` identifiers as propsed in #25802. - - - - - 13bdd461 by Ben Gamari at 2025-04-23T15:52:30+05:30 SetLevels: Name `lvl` binders according to context In general we should strive to maintain some amount of information about the provenance of generated bindings. Addresses #25802. - - - - - 2 changed files: - compiler/GHC/Core/Opt/SetLevels.hs - testsuite/tests/codeGen/should_compile/T25177.stderr Changes: ===================================== compiler/GHC/Core/Opt/SetLevels.hs ===================================== @@ -109,7 +109,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 @@ -126,6 +126,7 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic +import Data.List ( intercalate ) import Data.Maybe {- @@ -635,7 +636,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)) } @@ -656,7 +657,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 @@ -1219,41 +1220,42 @@ lvlBind :: LevelEnv -> CoreBindWithFVs -> LvlM (LevelledBind, LevelEnv) -lvlBind env (AnnNonRec bndr rhs) +lvlBind env0 (AnnNonRec bndr rhs) | isTyVar bndr -- Don't float TyVar binders (simplifier gets rid of them pronto) || isCoVar bndr -- Don't float CoVars: difficult to fix up CoVar occurrences -- (see extendPolyLvlEnv) - || not (wantToFloat env NonRecursive dest_lvl is_join is_top_bindable) + || not (wantToFloat env0 NonRecursive dest_lvl is_join is_top_bindable) = -- No float - do { rhs' <- lvlRhs env NonRecursive is_bot_lam mb_join_arity rhs - ; let bind_lvl = incMinorLvl (le_ctxt_lvl env) - (env', [bndr']) = substAndLvlBndrs NonRecursive env bind_lvl [bndr] - ; return (NonRec bndr' rhs', env') } + do { rhs' <- lvlRhs env1 NonRecursive is_bot_lam mb_join_arity rhs + ; let bind_lvl = incMinorLvl (le_ctxt_lvl env1) + (env2, [bndr']) = substAndLvlBndrs NonRecursive env1 bind_lvl [bndr] + ; return (NonRec bndr' rhs', env2) } -- Otherwise we are going to float | null abs_vars = do { -- No type abstraction; clone existing binder - rhs' <- lvlFloatRhs [] dest_lvl env NonRecursive + rhs' <- lvlFloatRhs [] dest_lvl env1 NonRecursive is_bot_lam NotJoinPoint rhs - ; (env', [bndr']) <- cloneLetVars NonRecursive env dest_lvl [bndr] + ; (env2, [bndr']) <- cloneLetVars NonRecursive env1 dest_lvl [bndr] ; let bndr2 = annotateBotStr bndr' 0 mb_bot_str - ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') } + ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env2) } | otherwise = do { -- Yes, type abstraction; create a new binder, extend substitution, etc - rhs' <- lvlFloatRhs abs_vars dest_lvl env NonRecursive + rhs' <- lvlFloatRhs abs_vars dest_lvl env1 NonRecursive is_bot_lam NotJoinPoint rhs - ; (env', [bndr']) <- newPolyBndrs dest_lvl env abs_vars [bndr] + ; (env2, [bndr']) <- newPolyBndrs dest_lvl env1 abs_vars [bndr] ; let bndr2 = annotateBotStr bndr' n_extra mb_bot_str - ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') } + ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env2) } where + env1 = pushBindContext env0 bndr bndr_ty = idType bndr ty_fvs = tyCoVarsOfType bndr_ty rhs_fvs = freeVarsOf rhs bind_fvs = rhs_fvs `unionDVarSet` dIdFreeVars bndr - abs_vars = abstractVars dest_lvl env bind_fvs - dest_lvl = destLevel env bind_fvs ty_fvs (isFunction rhs) is_bot_lam + abs_vars = abstractVars dest_lvl env0 bind_fvs + dest_lvl = destLevel env0 bind_fvs ty_fvs (isFunction rhs) is_bot_lam deann_rhs = deAnnotate rhs mb_bot_str = exprBotStrictness_maybe deann_rhs @@ -1273,7 +1275,8 @@ lvlBind env (AnnRec pairs) = -- No float do { let bind_lvl = incMinorLvl (le_ctxt_lvl env) (env', bndrs') = substAndLvlBndrs Recursive env bind_lvl bndrs - lvl_rhs (b,r) = lvlRhs env' Recursive is_bot (idJoinPointHood b) r + lvl_rhs (b,r) = lvlRhs env'' Recursive is_bot (idJoinPointHood b) r + where env'' = pushBindContext env' b ; rhss' <- mapM lvl_rhs pairs ; return (Rec (bndrs' `zip` rhss'), env') } @@ -1298,8 +1301,9 @@ lvlBind env (AnnRec pairs) -- mutually recursive functions, but it's quite a bit more complicated -- -- This all seems a bit ad hoc -- sigh - let (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars + let (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env' dest_lvl abs_vars rhs_lvl = le_ctxt_lvl rhs_env + env' = pushBindContext env bndr (rhs_env', [new_bndr]) <- cloneLetVars Recursive rhs_env rhs_lvl [bndr] let @@ -1307,7 +1311,7 @@ lvlBind env (AnnRec pairs) (body_env1, lam_bndrs1) = substBndrsSL NonRecursive rhs_env' lam_bndrs (body_env2, lam_bndrs2) = lvlLamBndrs body_env1 rhs_lvl lam_bndrs1 new_rhs_body <- lvlRhs body_env2 Recursive is_bot NotJoinPoint rhs_body - (poly_env, [poly_bndr]) <- newPolyBndrs dest_lvl env abs_vars [bndr] + (poly_env, [poly_bndr]) <- newPolyBndrs dest_lvl env' abs_vars [bndr] return (Rec [(TB poly_bndr (FloatMe dest_lvl) , mkLams abs_vars_w_lvls $ mkLams lam_bndrs2 $ @@ -1332,9 +1336,10 @@ lvlBind env (AnnRec pairs) -- function in a Rec, and we don't much care what -- happens to it. False is simple! - do_rhs env (_,rhs) = lvlFloatRhs abs_vars dest_lvl env Recursive - is_bot NotJoinPoint - rhs + do_rhs env (b,rhs) = + lvlFloatRhs abs_vars dest_lvl env' Recursive + is_bot NotJoinPoint rhs + where env' = pushBindContext env b -- Finding the free vars of the binding group is annoying bind_fvs = ((unionDVarSets [ freeVarsOf rhs | (_, rhs) <- pairs]) @@ -1632,16 +1637,17 @@ countFreeIds = nonDetStrictFoldUDFM add 0 . getUniqDSet -} data LevelEnv - = LE { le_switches :: FloatOutSwitches - , le_ctxt_lvl :: !Level -- The current level - , le_lvl_env :: VarEnv Level -- Domain is *post-cloned* TyVars and Ids + = LE { le_switches :: FloatOutSwitches + , le_bind_ctxt :: [Id] + , le_ctxt_lvl :: !Level -- The current level + , le_lvl_env :: VarEnv Level -- Domain is *post-cloned* TyVars and Ids -- See Note [le_subst and le_env] - , le_subst :: Subst -- Domain is pre-cloned TyVars and Ids - -- The Id -> CoreExpr in the Subst is ignored - -- (since we want to substitute a LevelledExpr for - -- an Id via le_env) but we do use the Co/TyVar substs - , le_env :: IdEnv ([OutVar], LevelledExpr) -- Domain is pre-cloned Ids + , le_subst :: Subst -- Domain is pre-cloned TyVars and Ids + -- The Id -> CoreExpr in the Subst is ignored + -- (since we want to substitute a LevelledExpr for + -- an Id via le_env) but we do use the Co/TyVar substs + , le_env :: IdEnv ([OutVar], LevelledExpr) -- Domain is pre-cloned Ids } {- Note [le_subst and le_env] @@ -1678,6 +1684,7 @@ The domain of the le_lvl_env is the *post-cloned* Ids initialEnv :: FloatOutSwitches -> CoreProgram -> LevelEnv initialEnv float_lams binds = LE { le_switches = float_lams + , le_bind_ctxt = [] , le_ctxt_lvl = tOP_LEVEL , le_lvl_env = emptyVarEnv , le_subst = mkEmptySubst in_scope_toplvl @@ -1690,6 +1697,9 @@ initialEnv float_lams binds -- to a later one. So here we put all the top-level binders in scope before -- we start, to satisfy the lookupIdSubst invariants (#20200 and #20294) +pushBindContext :: LevelEnv -> Id -> LevelEnv +pushBindContext env i = env { le_bind_ctxt = i : le_bind_ctxt env } + addLvl :: Level -> VarEnv Level -> OutVar -> VarEnv Level addLvl dest_lvl env v' = extendVarEnv env v' dest_lvl @@ -1829,11 +1839,12 @@ newPolyBndrs dest_lvl | otherwise = new_bndr -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)) } @@ -1848,7 +1859,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 :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var]) ===================================== testsuite/tests/codeGen/should_compile/T25177.stderr ===================================== @@ -7,9 +7,9 @@ foo = \ ds -> case ds of { D a ds1 -> W# a } d = D 10## RUBBISH(IntRep) -lvl = foo d +lvl_d = foo d -bar1 = \ _ eta -> case lvl of { W# ipv -> (# eta, () #) } +bar1 = \ _ eta -> case lvl_d of { W# ipv -> (# eta, () #) } bar = bar1 `cast` Co:6 :: ... View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7cf39c79bdedc3f2a4736a92994d43d... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7cf39c79bdedc3f2a4736a92994d43d... You're receiving this email because of your account on gitlab.haskell.org.