[Git][ghc/ghc][wip/coreprep-sat-name] CorePrep: Name `sat` binders more descriptively
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Tue Jan 28 21:38:17 UTC 2025
Ben Gamari pushed to branch wip/coreprep-sat-name at Glasgow Haskell Compiler / GHC
Commits:
2a9b869a by Ben Gamari at 2025-01-28T16:37:57-05:00
CorePrep: Name `sat` binders more descriptively
- - - - -
8 changed files:
- compiler/GHC/CoreToStg/Prep.hs
- testsuite/tests/core-to-stg/T14895.stderr
- testsuite/tests/core-to-stg/T24124.stderr
- testsuite/tests/ghci/should_run/T21052.stdout
- testsuite/tests/simplCore/should_compile/T20040.stderr
- testsuite/tests/simplCore/should_compile/T23083.stderr
- testsuite/tests/simplStg/should_compile/T15226b.stderr
- testsuite/tests/simplStg/should_compile/T19717.stderr
Changes:
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -61,7 +61,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
@@ -72,6 +73,7 @@ import qualified Data.ByteString.Builder as BB
import Data.ByteString.Builder.Prim
import Control.Monad
+import Data.List (intercalate)
{-
Note [CorePrep Overview]
@@ -249,11 +251,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
@@ -713,13 +715,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)
@@ -727,7 +729,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')) })
@@ -737,6 +739,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
=====================================
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];
};
=====================================
testsuite/tests/core-to-stg/T24124.stderr
=====================================
@@ -8,16 +8,16 @@ T24124.testFun1
-> (# GHC.Prim.State# GHC.Prim.RealWorld, 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 -> MkSolo# [sat];
+ __DEFAULT -> MkSolo# [testFun1_sat];
};
};
=====================================
testsuite/tests/ghci/should_run/T21052.stdout
=====================================
@@ -4,9 +4,9 @@ BCO_toplevel :: GHC.Types.IO [GHC.Types.Any]
[LclIdX] =
{} \u []
let {
- sat :: [GHC.Types.Any]
+ _sat :: [GHC.Types.Any]
[LclId, Unf=OtherCon []] =
:! [GHC.Tuple.() GHC.Types.[]];
- } in GHC.Internal.Base.returnIO sat;
+ } in GHC.Internal.Base.returnIO _sat;
=====================================
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 }
=====================================
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#
=====================================
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 MkSolo# [sat];
+ T15226b.Str! [bar1_sat];
+ } in MkSolo# [bar1_sat];
};
T15226b.bar
=====================================
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.Types.[]];
- } in : [sat sat];
+ :! [f_sat GHC.Types.[]];
+ } in : [f_sat f_sat];
};
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2a9b869a65d988cacfc00c6fe9755ff307e891b6
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2a9b869a65d988cacfc00c6fe9755ff307e891b6
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/20250128/a882177d/attachment-0001.html>
More information about the ghc-commits
mailing list