From 7cc0855009070a4ca50504d2bdda7566417e2900 Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@well-typed.com>
Date: Sat, 18 Jan 2025 00:07:05 -0500
Subject: [PATCH] CorePrep: Name `sat` binders more descriptively
---
compiler/GHC/CoreToStg/Prep.hs | 77 ++++++++++++-------
testsuite/tests/core-to-stg/T14895.stderr | 4 +-
testsuite/tests/core-to-stg/T24124.stderr | 8 +-
testsuite/tests/ghci/should_run/T21052.stdout | 4 +-
.../simplCore/should_compile/T20040.stderr | 4 +-
.../simplCore/should_compile/T23083.stderr | 6 +-
.../simplStg/should_compile/T15226b.stderr | 8 +-
.../simplStg/should_compile/T19717.stderr | 8 +-
8 files changed, 73 insertions(+), 46 deletions(-)
diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs
index cc8f82d2106..6a295fe86d7 100644
--- a/compiler/GHC/CoreToStg/Prep.hs
+++ b/compiler/GHC/CoreToStg/Prep.hs
@@ -59,7 +59,8 @@ import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Id.Make ( realWorldPrimId )
import GHC.Types.Basic
-import GHC.Types.Name ( NamedThing(..), nameSrcSpan, isInternalName )
+import GHC.Types.Name ( NamedThing(..), nameSrcSpan, isInternalName, OccName )
+import GHC.Types.Name.Occurrence (occNameString)
import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )
import GHC.Types.Literal
import GHC.Types.Tickish
@@ -70,6 +71,7 @@ import qualified Data.ByteString.Builder as BB
import Data.ByteString.Builder.Prim
import Control.Monad
+import Data.List (intercalate)
{-
Note [CorePrep Overview]
@@ -247,11 +249,11 @@ corePrepPgm logger cp_cfg pgm_cfg
withTiming logger
(text "CorePrep"<+>brackets (ppr this_mod))
(\a -> a `seqList` ()) $ do
- us <- mkSplitUniqSupply 's'
let initialCorePrepEnv = mkInitialCorePrepEnv cp_cfg
- let
- implicit_binds = mkDataConWorkers
+ us <- mkSplitUniqSupply 's'
+
+ let implicit_binds = mkDataConWorkers
(cpPgm_generateDebugInfo pgm_cfg)
mod_loc data_tycons
-- NB: we must feed mkImplicitBinds through corePrep too
@@ -711,13 +713,13 @@ cpePair :: TopLevelFlag -> RecFlag -> Demand -> Levity
-> UniqSM (Floats, CpeRhs)
-- Used for all bindings
-- The binder is already cloned, hence an OutId
-cpePair top_lvl is_rec dmd lev env bndr rhs
+cpePair top_lvl is_rec dmd lev env0 bndr rhs
= assert (not (isJoinId bndr)) $ -- those should use cpeJoinPair
do { (floats1, rhs1) <- cpeRhsE env rhs
-- See if we are allowed to float this stuff out of the RHS
; let dec = want_float_from_rhs floats1 rhs1
- ; (floats2, rhs2) <- executeFloatDecision dec floats1 rhs1
+ ; (floats2, rhs2) <- executeFloatDecision env dec floats1 rhs1
-- Make the arity match up
; (floats3, rhs3)
@@ -725,7 +727,7 @@ cpePair top_lvl is_rec dmd lev env bndr rhs
then return (floats2, cpeEtaExpand arity rhs2)
else warnPprTrace True "CorePrep: silly extra arguments:" (ppr bndr) $
-- Note [Silly extra arguments]
- (do { v <- newVar (idType bndr)
+ (do { v <- newVar env (idType bndr)
; let (float, v') = mkNonRecFloat env Lifted v rhs2
; return ( snocFloat floats2 float
, cpeEtaExpand arity (Var v')) })
@@ -735,6 +737,8 @@ cpePair top_lvl is_rec dmd lev env bndr rhs
; return (floats4, rhs4) }
where
+ env = pushBinderContext bndr env0
+
arity = idArity bndr -- We must match this arity
want_float_from_rhs floats rhs
@@ -967,36 +971,36 @@ cpeBodyNF env expr
cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody)
cpeBody env expr
= do { (floats1, rhs) <- cpeRhsE env expr
- ; (floats2, body) <- rhsToBody rhs
+ ; (floats2, body) <- rhsToBody env rhs
; return (floats1 `appFloats` floats2, body) }
--------
-rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
+rhsToBody :: CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeBody)
-- Remove top level lambdas by let-binding
-rhsToBody (Tick t expr)
+rhsToBody env (Tick t expr)
| tickishScoped t == NoScope -- only float out of non-scoped annotations
- = do { (floats, expr') <- rhsToBody expr
+ = do { (floats, expr') <- rhsToBody env expr
; return (floats, mkTick t expr') }
-rhsToBody (Cast e co)
+rhsToBody env (Cast e co)
-- You can get things like
-- case e of { p -> coerce t (\s -> ...) }
- = do { (floats, e') <- rhsToBody e
+ = do { (floats, e') <- rhsToBody env e
; return (floats, Cast e' co) }
-rhsToBody expr@(Lam {}) -- See Note [No eta reduction needed in rhsToBody]
+rhsToBody env expr@(Lam {}) -- See Note [No eta reduction needed in rhsToBody]
| all isTyVar bndrs -- Type lambdas are ok
= return (emptyFloats, expr)
| otherwise -- Some value lambdas
= do { let rhs = cpeEtaExpand (exprArity expr) expr
- ; fn <- newVar (exprType rhs)
+ ; fn <- newVar env (exprType rhs)
; let float = Float (NonRec fn rhs) LetBound TopLvlFloatable
; return (unitFloat float, Var fn) }
where
(bndrs,_) = collectBinders expr
-rhsToBody expr = return (emptyFloats, expr)
+rhsToBody _env expr = return (emptyFloats, expr)
{- Note [No eta reduction needed in rhsToBody]
@@ -1168,7 +1172,7 @@ cpeApp top_env expr
-- allocating CaseBound Floats for token and thing as needed
= do { (floats1, token) <- cpeArg env topDmd token
; (floats2, thing) <- cpeBody env thing
- ; case_bndr <- (`setIdUnfolding` evaldUnfolding) <$> newVar ty
+ ; case_bndr <- (`setIdUnfolding` evaldUnfolding) <$> newVar env ty
; let tup = mkCoreUnboxedTuple [token, Var case_bndr]
; let float = mkCaseFloat case_bndr thing
; return (floats1 `appFloats` floats2 `snocFloat` float, tup) }
@@ -1577,7 +1581,7 @@ cpeArg env dmd arg
; let arg_ty = exprType arg1
lev = typeLevity arg_ty
dec = wantFloatLocal NonRecursive dmd lev floats1 arg1
- ; (floats2, arg2) <- executeFloatDecision dec floats1 arg1
+ ; (floats2, arg2) <- executeFloatDecision env dec floats1 arg1
-- Else case: arg1 might have lambdas, and we can't
-- put them inside a wrapBinds
@@ -1586,7 +1590,7 @@ cpeArg env dmd arg
-- see Note [ANF-ising literal string arguments]
; if exprIsTrivial arg2
then return (floats2, arg2)
- else do { v <- (`setIdDemandInfo` dmd) <$> newVar arg_ty
+ else do { v <- (`setIdDemandInfo` dmd) <$> newVar env arg_ty
-- See Note [Pin demand info on floats]
; let arity = cpeArgArity env dec floats1 arg2
arg3 = cpeEtaExpand arity arg2
@@ -2424,13 +2428,13 @@ instance Outputable FloatDecision where
ppr FloatNone = text "none"
ppr FloatAll = text "all"
-executeFloatDecision :: FloatDecision -> Floats -> CpeRhs -> UniqSM (Floats, CpeRhs)
-executeFloatDecision dec floats rhs
+executeFloatDecision :: CorePrepEnv -> FloatDecision -> Floats -> CpeRhs -> UniqSM (Floats, CpeRhs)
+executeFloatDecision env dec floats rhs
= case dec of
FloatAll -> return (floats, rhs)
FloatNone
| isEmptyFloats floats -> return (emptyFloats, rhs)
- | otherwise -> do { (floats', body) <- rhsToBody rhs
+ | otherwise -> do { (floats', body) <- rhsToBody env rhs
; return (emptyFloats, wrapBinds floats $
wrapBinds floats' body) }
-- FloatNone case: `rhs` might have lambdas, and we can't
@@ -2569,6 +2573,8 @@ data CorePrepEnv
, cpe_subst :: Subst -- ^ See Note [CorePrepEnv: cpe_subst]
, cpe_rec_ids :: UnVarSet -- Faster OutIdSet; See Note [Speculative evaluation]
+
+ , cpe_context :: [OccName] -- ^ See Note [Binder context]
}
mkInitialCorePrepEnv :: CorePrepConfig -> CorePrepEnv
@@ -2576,6 +2582,7 @@ mkInitialCorePrepEnv cfg = CPE
{ cpe_config = cfg
, cpe_subst = emptySubst
, cpe_rec_ids = emptyUnVarSet
+ , cpe_context = []
}
extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
@@ -2616,6 +2623,14 @@ cpSubstCo :: CorePrepEnv -> Coercion -> Coercion
cpSubstCo (CPE { cpe_subst = subst }) co = substCo subst co
-- substCo has a short-cut if the TCvSubst is empty
+-- | See Note [Binder context]
+pushBinderContext :: Id -> CorePrepEnv -> CorePrepEnv
+pushBinderContext ident env
+ | lengthAtLeast (cpe_context env) 2
+ = env
+ | otherwise
+ = env { cpe_context = getOccName ident : cpe_context env}
+
------------------------------------------------------------------------------
-- Cloning binders
-- ---------------------------------------------------------------------------
@@ -2704,10 +2719,20 @@ fiddleCCall id
-- Generating new binders
-- ---------------------------------------------------------------------------
-newVar :: Type -> UniqSM Id
-newVar ty
- = seqType ty `seq` mkSysLocalOrCoVarM (fsLit "sat") ManyTy ty
-
+newVar :: CorePrepEnv -> Type -> UniqSM Id
+newVar env ty
+ -- See Note [Binder context]
+ = seqType ty `seq` mkSysLocalOrCoVarM (fsLit occ) ManyTy ty
+ where occ = intercalate "_" (map occNameString $ cpe_context env) ++ "_sat"
+
+{- Note [Binder context]
+ ~~~~~~~~~~~~~~~~~~~~~
+ To ensure that the compiled program (specifically symbol names)
+ remains understandable to the user we maintain a context
+ of binders that we are currently under. This allows us to give
+ identifiers conjured during CorePrep more contextually-meaningful
+ names. This is done in `newVar`.
+ -}
------------------------------------------------------------------------------
-- Floating ticks
diff --git a/testsuite/tests/core-to-stg/T14895.stderr b/testsuite/tests/core-to-stg/T14895.stderr
index 0876bf247f4..f9586fbc504 100644
--- a/testsuite/tests/core-to-stg/T14895.stderr
+++ b/testsuite/tests/core-to-stg/T14895.stderr
@@ -11,10 +11,10 @@ T14895.go
GHC.Internal.Data.Either.Left e [Occ=Once1] -> wild<TagProper>;
GHC.Internal.Data.Either.Right a1 [Occ=Once1] ->
let {
- sat [Occ=Once1] :: b
+ go_sat [Occ=Once1] :: b
[LclId] =
{a1, f} \u [] f a1;
- } in GHC.Internal.Data.Either.Right [sat];
+ } in GHC.Internal.Data.Either.Right [go_sat];
};
diff --git a/testsuite/tests/core-to-stg/T24124.stderr b/testsuite/tests/core-to-stg/T24124.stderr
index ad627e75855..4ca0047802c 100644
--- a/testsuite/tests/core-to-stg/T24124.stderr
+++ b/testsuite/tests/core-to-stg/T24124.stderr
@@ -9,16 +9,16 @@ T24124.testFun1
T24124.StrictPair a b #)
[GblId, Arity=3, Str=<L><L><L>, Cpr=1, Unf=OtherCon []] =
{} \r [x y void]
- case x of sat {
+ case x of testFun1_sat {
__DEFAULT ->
case
case y of y [OS=OneShot] {
- __DEFAULT -> T24124.MkStrictPair [sat y];
+ __DEFAULT -> T24124.MkStrictPair [testFun1_sat y];
}
of
- sat
+ testFun1_sat
{
- __DEFAULT -> GHC.Internal.Types.MkSolo# [sat];
+ __DEFAULT -> GHC.Internal.Types.MkSolo# [testFun1_sat];
};
};
diff --git a/testsuite/tests/ghci/should_run/T21052.stdout b/testsuite/tests/ghci/should_run/T21052.stdout
index b2d2bd77066..2519e608f69 100644
--- a/testsuite/tests/ghci/should_run/T21052.stdout
+++ b/testsuite/tests/ghci/should_run/T21052.stdout
@@ -4,9 +4,9 @@ BCO_toplevel :: GHC.Internal.Types.IO [GHC.Internal.Types.Any]
[LclIdX] =
{} \u []
let {
- sat :: [GHC.Internal.Types.Any]
+ _sat :: [GHC.Internal.Types.Any]
[LclId, Unf=OtherCon []] =
:! [GHC.Internal.Tuple.() GHC.Internal.Types.[]];
- } in GHC.Internal.Base.returnIO sat;
+ } in GHC.Internal.Base.returnIO _sat;
diff --git a/testsuite/tests/simplCore/should_compile/T20040.stderr b/testsuite/tests/simplCore/should_compile/T20040.stderr
index 9302da08b41..f766b1a6d26 100644
--- a/testsuite/tests/simplCore/should_compile/T20040.stderr
+++ b/testsuite/tests/simplCore/should_compile/T20040.stderr
@@ -16,7 +16,9 @@ ifoldl' =
Cons ipv2 ipv3 ->
case z of z1 {
__DEFAULT ->
- case f z1 ipv2 of sat { __DEFAULT -> ifoldl' f sat ipv3; };
+ case f z1 ipv2 of ifoldl'_sat {
+ __DEFAULT -> ifoldl' f ifoldl'_sat ipv3;
+ };
};
};
end Rec }
diff --git a/testsuite/tests/simplCore/should_compile/T23083.stderr b/testsuite/tests/simplCore/should_compile/T23083.stderr
index 32001515293..f82eb2baf4f 100644
--- a/testsuite/tests/simplCore/should_compile/T23083.stderr
+++ b/testsuite/tests/simplCore/should_compile/T23083.stderr
@@ -13,10 +13,10 @@ T23083.g :: ((GHC.Internal.Bignum.Integer.Integer -> GHC.Internal.Bignum.Integer
T23083.g
= \ (f [Occ=Once1!] :: (GHC.Internal.Bignum.Integer.Integer -> GHC.Internal.Bignum.Integer.Integer) -> GHC.Internal.Bignum.Integer.Integer) (h [Occ=OnceL1] :: GHC.Internal.Bignum.Integer.Integer -> GHC.Internal.Bignum.Integer.Integer) ->
let {
- sat [Occ=Once1] :: GHC.Internal.Bignum.Integer.Integer -> GHC.Internal.Bignum.Integer.Integer
+ g_sat [Occ=Once1] :: GHC.Internal.Bignum.Integer.Integer -> GHC.Internal.Bignum.Integer.Integer
[LclId, Unf=OtherCon []]
- sat = \ (eta [Occ=Once1] :: GHC.Internal.Bignum.Integer.Integer) -> case h of h1 [Occ=Once1] { __DEFAULT -> T23083.$$ @GHC.Internal.Bignum.Integer.Integer @GHC.Internal.Bignum.Integer.Integer h1 eta } } in
- f sat
+ g_sat = \ (eta [Occ=Once1] :: GHC.Internal.Bignum.Integer.Integer) -> case h of h1 [Occ=Once1] { __DEFAULT -> T23083.$$ @GHC.Internal.Bignum.Integer.Integer @GHC.Internal.Bignum.Integer.Integer h1 eta } } in
+ f g_sat
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
T23083.$trModule4 :: GHC.Prim.Addr#
diff --git a/testsuite/tests/simplStg/should_compile/T15226b.stderr b/testsuite/tests/simplStg/should_compile/T15226b.stderr
index 3735b85e1b0..3949ec453c4 100644
--- a/testsuite/tests/simplStg/should_compile/T15226b.stderr
+++ b/testsuite/tests/simplStg/should_compile/T15226b.stderr
@@ -8,13 +8,13 @@ T15226b.bar1
T15226b.Str (GHC.Internal.Maybe.Maybe a) #)
[GblId, Arity=2, Str=<L><L>, Cpr=1(, 1), Unf=OtherCon []] =
{} \r [x void]
- case x of sat {
+ case x of bar1_sat {
__DEFAULT ->
let {
- sat [Occ=Once1] :: T15226b.Str (GHC.Internal.Maybe.Maybe a)
+ bar1_sat [Occ=Once1] :: T15226b.Str (GHC.Internal.Maybe.Maybe a)
[LclId, Unf=OtherCon []] =
- T15226b.Str! [sat];
- } in GHC.Internal.Types.MkSolo# [sat];
+ T15226b.Str! [bar1_sat];
+ } in GHC.Internal.Types.MkSolo# [bar1_sat];
};
T15226b.bar
diff --git a/testsuite/tests/simplStg/should_compile/T19717.stderr b/testsuite/tests/simplStg/should_compile/T19717.stderr
index 37ddaa006f7..282183bcb68 100644
--- a/testsuite/tests/simplStg/should_compile/T19717.stderr
+++ b/testsuite/tests/simplStg/should_compile/T19717.stderr
@@ -6,14 +6,14 @@ Foo.f :: forall {a}. a -> [GHC.Internal.Maybe.Maybe a]
case x of x1 {
__DEFAULT ->
let {
- sat [Occ=Once1] :: GHC.Internal.Maybe.Maybe a
+ f_sat [Occ=Once1] :: GHC.Internal.Maybe.Maybe a
[LclId, Unf=OtherCon []] =
GHC.Internal.Maybe.Just! [x1]; } in
let {
- sat [Occ=Once1] :: [GHC.Internal.Maybe.Maybe a]
+ f_sat [Occ=Once1] :: [GHC.Internal.Maybe.Maybe a]
[LclId, Unf=OtherCon []] =
- :! [sat GHC.Internal.Types.[]];
- } in : [sat sat];
+ :! [f_sat GHC.Internal.Types.[]];
+ } in : [f_sat f_sat];
};
--
GitLab