[Git][ghc/ghc][wip/T23083] 2 commits: CorePrep: Do not eliminate EmptyCase, do it in StgToCmm instead
Sebastian Graf (@sgraf812)
gitlab at gitlab.haskell.org
Tue Apr 18 16:36:00 UTC 2023
Sebastian Graf pushed to branch wip/T23083 at Glasgow Haskell Compiler / GHC
Commits:
fd4dfa42 by Sebastian Graf at 2023-04-18T18:35:45+02:00
CorePrep: Do not eliminate EmptyCase, do it in StgToCmm instead
We eliminate EmptyCase by way of `cgCase e _ _ [] = cgExpr e` now.
The main reason is that it plays far better in conjunction with eta expansion
(as we aim to do for arguments in CorePrep, #23083), because we can discard
any arguments, `(case e of {}) eta == case e of {}`, whereas in `(e |> co) eta`
it's impossible to discard the argument.
It is also both much simpler to describe than the previous mechanism of emitting
an unsafe coercion and simpler to implement, removing quite a bit of commentary
and the `Bool` field of `CorePrepProv`.
- - - - -
a60cd275 by Sebastian Graf at 2023-04-18T18:35:45+02:00
CorePrep: Eta expand arguments (#23083)
Previously, we'd only eta expand let bindings and lambdas,
now we'll also eta expand arguments such as in T23083:
```hs
g f h = f (h `seq` (h $))
```
Unless `-fpedantic-bottoms` is set, we'll now transform to
```hs
g f h = f (\eta -> h eta)
```
in CorePrep.
See the new `Note [Eta expansion of arguments in CorePrep]` for the details.
We only do this optimisation with -O2 because we saw 2-3% ghc/alloc regressions
in T4801 and T5321FD.
Fixes #23083.
- - - - -
29 changed files:
- compiler/GHC/Core.hs
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/Coercion/Opt.hs
- compiler/GHC/Core/FVs.hs
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/TyCo/FVs.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Core/TyCo/Subst.hs
- compiler/GHC/Core/TyCo/Tidy.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/CoreToIface.hs
- compiler/GHC/CoreToStg.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Driver/Config/CoreToStg/Prep.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Stg/CSE.hs
- compiler/GHC/Stg/Unarise.hs
- compiler/GHC/StgToCmm/Expr.hs
- compiler/GHC/StgToJS/Expr.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- docs/users_guide/using-optimisation.rst
- + testsuite/tests/simplCore/should_compile/T23083.hs
- + testsuite/tests/simplCore/should_compile/T23083.stderr
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core.hs
=====================================
@@ -717,9 +717,13 @@ this exhaustive list can be empty!
its scrutinee is (see GHC.Core.Utils.exprIsTrivial). This is actually
important; see Note [Empty case is trivial] in GHC.Core.Utils
-* An empty case is replaced by its scrutinee during the CoreToStg
- conversion; remember STG is un-typed, so there is no need for
- the empty case to do the type conversion.
+* We stick to empty cases until code generation, when StgToX emits an eval on
+ the scrutinee in GHC.StgToCmm.Expr.cgCase and GHC.StgToJS.Expr.genCase.
+
+Historical Note: We used to lower EmptyCase in CorePrep by way of an
+unsafeCoercion on the scrutinee, but that yielded panics in CodeGen when
+we were beginning to eta expand in arguments, plus required to mess with
+heterogenously-kinded coercions. It's simpler to stick to it until Cmm anyway.
Note [Join points]
~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Core/Coercion.hs
=====================================
@@ -1390,7 +1390,7 @@ setNominalRole_maybe r co
| case prov of PhantomProv _ -> False -- should always be phantom
ProofIrrelProv _ -> True -- it's always safe
PluginProv _ -> False -- who knows? This choice is conservative.
- CorePrepProv _ -> True
+ CorePrepProv -> True
= Just $ UnivCo prov Nominal co1 co2
setNominalRole_maybe_helper _ = Nothing
@@ -1516,7 +1516,7 @@ promoteCoercion co = case co of
UnivCo (PhantomProv kco) _ _ _ -> kco
UnivCo (ProofIrrelProv kco) _ _ _ -> kco
UnivCo (PluginProv _) _ _ _ -> mkKindCo co
- UnivCo (CorePrepProv _) _ _ _ -> mkKindCo co
+ UnivCo CorePrepProv _ _ _ -> mkKindCo co
SymCo g
-> mkSymCo (promoteCoercion g)
@@ -2339,7 +2339,7 @@ seqProv :: UnivCoProvenance -> ()
seqProv (PhantomProv co) = seqCo co
seqProv (ProofIrrelProv co) = seqCo co
seqProv (PluginProv _) = ()
-seqProv (CorePrepProv _) = ()
+seqProv CorePrepProv = ()
seqCos :: [Coercion] -> ()
seqCos [] = ()
=====================================
compiler/GHC/Core/Coercion/Opt.hs
=====================================
@@ -622,7 +622,7 @@ opt_univ env sym prov role oty1 oty2
#endif
ProofIrrelProv kco -> ProofIrrelProv $ opt_co4_wrap env sym False Nominal kco
PluginProv _ -> prov
- CorePrepProv _ -> prov
+ CorePrepProv -> prov
-------------
opt_transList :: HasDebugCallStack => InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo]
=====================================
compiler/GHC/Core/FVs.hs
=====================================
@@ -410,7 +410,7 @@ orphNamesOfProv :: UnivCoProvenance -> NameSet
orphNamesOfProv (PhantomProv co) = orphNamesOfCo co
orphNamesOfProv (ProofIrrelProv co) = orphNamesOfCo co
orphNamesOfProv (PluginProv _) = emptyNameSet
-orphNamesOfProv (CorePrepProv _) = emptyNameSet
+orphNamesOfProv CorePrepProv = emptyNameSet
orphNamesOfCos :: [Coercion] -> NameSet
orphNamesOfCos = orphNamesOfThings orphNamesOfCo
@@ -798,4 +798,3 @@ freeVars = go
go (Type ty) = (tyCoVarsOfTypeDSet ty, AnnType ty)
go (Coercion co) = (tyCoVarsOfCoDSet co, AnnCoercion co)
-
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -2301,9 +2301,6 @@ lintCoercion co@(UnivCo prov r ty1 ty2)
-- see #9122 for discussion of these checks
checkTypes t1 t2
- | allow_ill_kinded_univ_co prov
- = return () -- Skip kind checks
- | otherwise
= do { checkWarnL fixed_rep_1
(report "left-hand type does not have a fixed runtime representation")
; checkWarnL fixed_rep_2
@@ -2321,13 +2318,6 @@ lintCoercion co@(UnivCo prov r ty1 ty2)
reps1 = typePrimRep t1
reps2 = typePrimRep t2
- -- CorePrep deliberately makes ill-kinded casts
- -- e.g (case error @Int "blah" of {}) :: Int#
- -- ==> (error @Int "blah") |> Unsafe Int Int#
- -- See Note [Unsafe coercions] in GHC.Core.CoreToStg.Prep
- allow_ill_kinded_univ_co (CorePrepProv homo_kind) = not homo_kind
- allow_ill_kinded_univ_co _ = False
-
validateCoercion :: PrimRep -> PrimRep -> LintM ()
validateCoercion rep1 rep2
= do { platform <- getPlatform
@@ -2357,8 +2347,8 @@ lintCoercion co@(UnivCo prov r ty1 ty2)
; check_kinds kco k1 k2
; return (ProofIrrelProv kco') }
- lint_prov _ _ prov@(PluginProv _) = return prov
- lint_prov _ _ prov@(CorePrepProv _) = return prov
+ lint_prov _ _ prov@(PluginProv _) = return prov
+ lint_prov _ _ prov at CorePrepProv = return prov
check_kinds kco k1 k2
= do { let Pair k1' k2' = coercionKind kco
=====================================
compiler/GHC/Core/TyCo/FVs.hs
=====================================
@@ -661,7 +661,7 @@ tyCoFVsOfProv :: UnivCoProvenance -> FV
tyCoFVsOfProv (PhantomProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc
tyCoFVsOfProv (ProofIrrelProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc
tyCoFVsOfProv (PluginProv _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc
-tyCoFVsOfProv (CorePrepProv _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc
+tyCoFVsOfProv CorePrepProv fv_cand in_scope acc = emptyFV fv_cand in_scope acc
tyCoFVsOfCos :: [Coercion] -> FV
tyCoFVsOfCos [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc
@@ -731,8 +731,8 @@ almost_devoid_co_var_of_prov (PhantomProv co) cv
= almost_devoid_co_var_of_co co cv
almost_devoid_co_var_of_prov (ProofIrrelProv co) cv
= almost_devoid_co_var_of_co co cv
-almost_devoid_co_var_of_prov (PluginProv _) _ = True
-almost_devoid_co_var_of_prov (CorePrepProv _) _ = True
+almost_devoid_co_var_of_prov (PluginProv _) _ = True
+almost_devoid_co_var_of_prov CorePrepProv _ = True
almost_devoid_co_var_of_type :: Type -> CoVar -> Bool
almost_devoid_co_var_of_type (TyVarTy _) _ = True
@@ -1131,7 +1131,7 @@ tyConsOfType ty
go_prov (PhantomProv co) = go_co co
go_prov (ProofIrrelProv co) = go_co co
go_prov (PluginProv _) = emptyUniqSet
- go_prov (CorePrepProv _) = emptyUniqSet
+ go_prov CorePrepProv = emptyUniqSet
-- this last case can happen from the tyConsOfType used from
-- checkTauTvUpdate
@@ -1345,5 +1345,4 @@ occCheckExpand vs_to_avoid ty
go_prov cxt (PhantomProv co) = PhantomProv <$> go_co cxt co
go_prov cxt (ProofIrrelProv co) = ProofIrrelProv <$> go_co cxt co
go_prov _ p@(PluginProv _) = return p
- go_prov _ p@(CorePrepProv _) = return p
-
+ go_prov _ p at CorePrepProv = return p
=====================================
compiler/GHC/Core/TyCo/Rep.hs
=====================================
@@ -1437,9 +1437,9 @@ data UnivCoProvenance
| PluginProv String -- ^ From a plugin, which asserts that this coercion
-- is sound. The string is for the use of the plugin.
- | CorePrepProv -- See Note [Unsafe coercions] in GHC.Core.CoreToStg.Prep
- Bool -- True <=> the UnivCo must be homogeneously kinded
- -- False <=> allow hetero-kinded, e.g. Int ~ Int#
+ | CorePrepProv -- ^ See Note [Unsafe coercions] in GHC.Core.CoreToStg.Prep
+ -- The UnivCo is always homogeneously kinded, e.g., it
+ -- disallows Int ~ Int#
deriving Data.Data
@@ -1447,7 +1447,7 @@ instance Outputable UnivCoProvenance where
ppr (PhantomProv _) = text "(phantom)"
ppr (ProofIrrelProv _) = text "(proof irrel.)"
ppr (PluginProv str) = parens (text "plugin" <+> brackets (text str))
- ppr (CorePrepProv _) = text "(CorePrep)"
+ ppr CorePrepProv = text "(CorePrep)"
-- | A coercion to be filled in by the type-checker. See Note [Coercion holes]
data CoercionHole
@@ -1760,7 +1760,7 @@ foldTyCo (TyCoFolder { tcf_view = view
go_prov env (PhantomProv co) = go_co env co
go_prov env (ProofIrrelProv co) = go_co env co
go_prov _ (PluginProv _) = mempty
- go_prov _ (CorePrepProv _) = mempty
+ go_prov _ CorePrepProv = mempty
-- | A view function that looks through nothing.
noView :: Type -> Maybe Type
@@ -1826,7 +1826,7 @@ provSize :: UnivCoProvenance -> Int
provSize (PhantomProv co) = 1 + coercionSize co
provSize (ProofIrrelProv co) = 1 + coercionSize co
provSize (PluginProv _) = 1
-provSize (CorePrepProv _) = 1
+provSize CorePrepProv = 1
{-
************************************************************************
=====================================
compiler/GHC/Core/TyCo/Subst.hs
=====================================
@@ -912,7 +912,7 @@ subst_co subst co
go_prov (PhantomProv kco) = PhantomProv (go kco)
go_prov (ProofIrrelProv kco) = ProofIrrelProv (go kco)
go_prov p@(PluginProv _) = p
- go_prov p@(CorePrepProv _) = p
+ go_prov p at CorePrepProv = p
-- See Note [Substituting in a coercion hole]
go_hole h@(CoercionHole { ch_co_var = cv })
=====================================
compiler/GHC/Core/TyCo/Tidy.hs
=====================================
@@ -252,7 +252,7 @@ tidyCo env@(_, subst) co
go_prov (PhantomProv co) = PhantomProv $! go co
go_prov (ProofIrrelProv co) = ProofIrrelProv $! go co
go_prov p@(PluginProv _) = p
- go_prov p@(CorePrepProv _) = p
+ go_prov p at CorePrepProv = p
tidyCos :: TidyEnv -> [Coercion] -> [Coercion]
tidyCos env = strictMap (tidyCo env)
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -580,7 +580,7 @@ expandTypeSynonyms ty
go_prov subst (PhantomProv co) = PhantomProv (go_co subst co)
go_prov subst (ProofIrrelProv co) = ProofIrrelProv (go_co subst co)
go_prov _ p@(PluginProv _) = p
- go_prov _ p@(CorePrepProv _) = p
+ go_prov _ p at CorePrepProv = p
-- the "False" and "const" are to accommodate the type of
-- substForAllCoBndrUsing, which is general enough to
@@ -998,7 +998,7 @@ mapTyCoX (TyCoMapper { tcm_tyvar = tyvar
go_prov env (PhantomProv co) = PhantomProv <$> go_co env co
go_prov env (ProofIrrelProv co) = ProofIrrelProv <$> go_co env co
go_prov _ p@(PluginProv _) = return p
- go_prov _ p@(CorePrepProv _) = return p
+ go_prov _ p at CorePrepProv = return p
{- *********************************************************************
=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -321,7 +321,7 @@ toIfaceCoercionX fr co
go_prov (PhantomProv co) = IfacePhantomProv (go co)
go_prov (ProofIrrelProv co) = IfaceProofIrrelProv (go co)
go_prov (PluginProv str) = IfacePluginProv str
- go_prov (CorePrepProv b) = IfaceCorePrepProv b
+ go_prov CorePrepProv = IfaceCorePrepProv
toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs
toIfaceTcArgs = toIfaceTcArgsX emptyVarSet
=====================================
compiler/GHC/CoreToStg.hs
=====================================
@@ -19,8 +19,7 @@ module GHC.CoreToStg ( CoreToStgOpts (..), coreToStg ) where
import GHC.Prelude
import GHC.Core
-import GHC.Core.Utils ( exprType, findDefault, isJoinBind
- , exprIsTickedString_maybe )
+import GHC.Core.Utils
import GHC.Core.Opt.Arity ( manifestArity )
import GHC.Core.Type
import GHC.Core.TyCon
@@ -49,7 +48,7 @@ import GHC.Unit.Module
import GHC.Data.FastString
import GHC.Platform ( Platform )
import GHC.Platform.Ways
-import GHC.Builtin.PrimOps ( PrimCall(..), primOpWrapperId )
+import GHC.Builtin.PrimOps
import GHC.Utils.Outputable
import GHC.Utils.Monad
@@ -430,29 +429,7 @@ coreToStgExpr (Cast expr _)
= coreToStgExpr expr
-- Cases require a little more real work.
-
-{-
-coreToStgExpr (Case scrut _ _ [])
- = coreToStgExpr scrut
- -- See Note [Empty case alternatives] in GHC.Core If the case
- -- alternatives are empty, the scrutinee must diverge or raise an
- -- exception, so we can just dive into it.
- --
- -- Of course this may seg-fault if the scrutinee *does* return. A
- -- belt-and-braces approach would be to move this case into the
- -- code generator, and put a return point anyway that calls a
- -- runtime system error function.
-
-coreToStgExpr e0@(Case scrut bndr _ [alt]) = do
- | isUnsafeEqualityProof scrut
- , isDeadBinder bndr -- We can only discard the case if the case-binder is dead
- -- It usually is, but see #18227
- , (_,_,rhs) <- alt
- = coreToStgExpr rhs
- -- See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce
--}
-
--- The normal case for case-expressions
+-- As Note [Empty case alternatives] in GHC.Core says, we hold on to EmptyCase
coreToStgExpr (Case scrut bndr _ alts)
= do { scrut2 <- coreToStgExpr scrut
; alts2 <- extendVarEnvCts [(bndr, LambdaBound)] (mapM vars_alt alts)
@@ -574,6 +551,11 @@ coreToStgApp f args ticks = do
-- This is the guy that turns applications into A-normal form
-- ---------------------------------------------------------------------------
+getStgArgFromTrivialArg :: HasDebugCallStack => CoreArg -> StgArg
+getStgArgFromTrivialArg e = trivial_expr_fold StgVarArg StgLitArg panic panic e
+ where
+ panic = pprPanic "getStgArgFromTrivialArg" (ppr e)
+
coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [StgTickish])
coreToStgArgs []
= return ([], [])
@@ -594,34 +576,14 @@ coreToStgArgs (Tick t e : args)
coreToStgArgs (arg : args) = do -- Non-type argument
(stg_args, ticks) <- coreToStgArgs args
- arg' <- coreToStgExpr arg
- let
- (aticks, arg'') = stripStgTicksTop tickishFloatable arg'
- stg_arg = case arg'' of
- StgApp v [] -> StgVarArg v
- StgConApp con _ [] _ -> StgVarArg (dataConWorkId con)
- StgOpApp (StgPrimOp op) [] _ -> StgVarArg (primOpWrapperId op)
- StgLit lit -> StgLitArg lit
- _ -> pprPanic "coreToStgArgs" (ppr arg $$ pprStgExpr panicStgPprOpts arg' $$ pprStgExpr panicStgPprOpts arg'')
-
- -- WARNING: what if we have an argument like (v `cast` co)
- -- where 'co' changes the representation type?
- -- (This really only happens if co is unsafe.)
- -- Then all the getArgAmode stuff in CgBindery will set the
- -- cg_rep of the CgIdInfo based on the type of v, rather
- -- than the type of 'co'.
- -- This matters particularly when the function is a primop
- -- or foreign call.
- -- Wanted: a better solution than this hacky warning
-
platform <- getPlatform
- let
+ let arg' = getStgArgFromTrivialArg arg
arg_rep = typePrimRep (exprType arg)
- stg_arg_rep = typePrimRep (stgArgType stg_arg)
+ stg_arg_rep = typePrimRep (stgArgType arg')
bad_args = not (primRepsCompatible platform arg_rep stg_arg_rep)
warnPprTrace bad_args "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" (ppr arg) $
- return (stg_arg : stg_args, ticks ++ aticks)
+ return (arg' : stg_args, ticks)
coreToStgTick :: Type -- type of the ticked expression
-> CoreTickish
@@ -959,6 +921,9 @@ myCollectBinders expr
-- | If the argument expression is (potential chain of) 'App', return the head
-- of the app chain, and collect ticks/args along the chain.
+-- INVARIANT: If the app head is trivial, return the atomic Var/Lit that was
+-- wrapped in casts, empty case, ticks, etc.
+-- So keep in sync with 'exprIsTrivial'.
myCollectArgs :: HasDebugCallStack => CoreExpr -> (CoreExpr, [CoreArg], [CoreTickish])
myCollectArgs expr
= go expr [] []
@@ -970,8 +935,10 @@ myCollectArgs expr
-- See Note [Ticks in applications]
go e as (t:ts) -- ticks can appear in type apps
go (Cast e _) as ts = go e as ts
+ go (Case e _ _ []) as ts = assertPpr (null as) (ppr e $$ ppr as $$ ppr expr) $
+ go e [] ts -- NB: Empty case discards arguments
go (Lam b e) as ts
- | isTyVar b = go e as ts -- Note [Collect args]
+ | isTyVar b = go e (drop 1 as) ts -- Note [Collect args]
go e as ts = (e, as, ts)
{- Note [Collect args]
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -142,7 +142,7 @@ The goal of this pass is to prepare for code generation.
profiling mode. We have to do this here because we won't have unfoldings
after this pass (see `trimUnfolding` and Note [Drop unfoldings and rules].
-12. Eliminate case clutter in favour of unsafe coercions.
+12. Eliminate unsafeEqualityProof in favour of unsafe coercions.
See Note [Unsafe coercions]
13. Eliminate some magic Ids, specifically
@@ -159,45 +159,17 @@ any trivial or useless bindings.
Note [Unsafe coercions]
~~~~~~~~~~~~~~~~~~~~~~~
-CorePrep does these two transformations:
-
-1. Convert empty case to cast with an unsafe coercion
- (case e of {}) ===> e |> unsafe-co
- See Note [Empty case alternatives] in GHC.Core: if the case
- alternatives are empty, the scrutinee must diverge or raise an
- exception, so we can just dive into it.
-
- Of course, if the scrutinee *does* return, we may get a seg-fault.
- A belt-and-braces approach would be to persist empty-alternative
- cases to code generator, and put a return point anyway that calls a
- runtime system error function.
-
- Notice that eliminating empty case can lead to an ill-kinded coercion
- case error @Int "foo" of {} :: Int#
- ===> error @Int "foo" |> unsafe-co
- where unsafe-co :: Int ~ Int#
- But that's fine because the expression diverges anyway. And it's
- no different to what happened before.
-
-2. Eliminate unsafeEqualityProof in favour of an unsafe coercion
- case unsafeEqualityProof of UnsafeRefl g -> e
- ===> e[unsafe-co/g]
- See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce
-
- Note that this requires us to substitute 'unsafe-co' for 'g', and
- that is the main (current) reason for cpe_tyco_env in CorePrepEnv.
- Tiresome, but not difficult.
-
-These transformations get rid of "case clutter", leaving only casts.
-We are doing no further significant transformations, so the reasons
-for the case forms have disappeared. And it is extremely helpful for
-the ANF-ery, CoreToStg, and backends, if trivial expressions really do
-look trivial. #19700 was an example.
-
-In both cases, the "unsafe-co" is just (UnivCo ty1 ty2 (CorePrepProv b)),
-The boolean 'b' says whether the unsafe coercion is supposed to be
-kind-homogeneous (yes for (2), no for (1). This information is used
-/only/ by Lint.
+CorePrep eliminates unsafeEqualityProof in favour of an unsafe coercion
+ case unsafeEqualityProof of UnsafeRefl g -> e
+ ===> e[unsafe-co/g]
+See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce.
+
+The "unsafe-co" is just (UnivCo ty1 ty2 CorePrepProv),
+a coercion that is always kind-homogeneous (as checked by Lint).
+
+Note that this requires us to substitute 'unsafe-co' for 'g', and
+that is the main (current) reason for cpe_tyco_env in CorePrepEnv.
+Tiresome, but not difficult.
Note [CorePrep invariants]
~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -830,23 +802,6 @@ cpeRhsE env expr@(Lam {})
; body' <- cpeBodyNF env' body
; return (emptyFloats, mkLams bndrs' body') }
--- Eliminate empty case
--- See Note [Unsafe coercions]
-cpeRhsE env (Case scrut _ ty [])
- = do { (floats, scrut') <- cpeRhsE env scrut
- ; let ty' = cpSubstTy env ty
- scrut_ty' = exprType scrut'
- co' = mkUnivCo prov Representational scrut_ty' ty'
- prov = CorePrepProv False
- -- False says that the kinds of two types may differ
- -- E.g. we might cast Int to Int#. This is fine
- -- because the scrutinee is guaranteed to diverge
-
- ; return (floats, Cast scrut' co') }
- -- This can give rise to
- -- Warning: Unsafe coercion: between unboxed and boxed value
- -- but it's fine because 'scrut' diverges
-
-- Eliminate unsafeEqualityProof
-- See Note [Unsafe coercions]
cpeRhsE env (Case scrut bndr _ alts)
@@ -855,8 +810,7 @@ cpeRhsE env (Case scrut bndr _ alts)
-- is dead. It usually is, but see #18227
, [Alt _ [co_var] rhs] <- alts
, let Pair ty1 ty2 = coVarTypes co_var
- the_co = mkUnivCo prov Nominal (cpSubstTy env ty1) (cpSubstTy env ty2)
- prov = CorePrepProv True -- True <=> kind homogeneous
+ the_co = mkUnivCo CorePrepProv Nominal (cpSubstTy env ty1) (cpSubstTy env ty2)
env' = extendCoVarEnv env co_var the_co
= cpeRhsE env' rhs
@@ -1491,12 +1445,33 @@ cpeArg env dmd arg
; if okCpeArg arg2
then do { v <- newVar arg_ty
- ; let arg3 = cpeEtaExpand (exprArity arg2) arg2
+ -- See Note [Eta expansion of arguments in CorePrep]
+ ; let arity | Just ao <- cp_arityOpts (cpe_config env) -- Just <=> -O2
+ , not (is_join_head arg2)
+ -- See Note [Eta expansion for join points]
+ -- Eta expanding the join point would
+ -- introduce crap that we can't generate
+ -- code for
+ = case exprEtaExpandArity ao arg2 of
+ Nothing -> 0
+ Just at -> arityTypeArity at
+ | otherwise
+ = exprArity arg2 -- this is cheap enough for -O0 and -O1
+ arg3 = cpeEtaExpand arity arg2
arg_float = mkFloat env dmd is_unlifted v arg3
; return (addFloat floats2 arg_float, varToCoreExpr v) }
else return (floats2, arg2)
}
+is_join_head :: CoreExpr -> Bool
+-- ^ Identify the cases where our mishandling described in
+-- Note [Eta expansion for join points] would generate crap
+is_join_head (Let bs e) = isJoinBind bs || is_join_head e
+is_join_head (Cast e _) = is_join_head e
+is_join_head (Tick _ e) = is_join_head e
+is_join_head (Case _ _ _ alts) = any is_join_head (rhssOfAlts alts)
+is_join_head _ = False
+
{-
Note [Floating unlifted arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1614,6 +1589,44 @@ and now we do NOT want eta expansion to give
Instead GHC.Core.Opt.Arity.etaExpand gives
f = /\a -> \y -> let s = h 3 in g s y
+Note [Eta expansion of arguments in CorePrep]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose `g = \x y. blah` and consider the expression `f (g x)`; we ANFise to
+
+ let t = g x
+ in f t
+
+We really don't want that `t` to be a thunk! That just wastes runtime, updating
+a thunk with a PAP etc. The code generator could in principle allocate a PAP,
+but in fact it does not know how to do that -- it's easier just to eta-expand:
+
+ let t = \y. g x y
+ in f t
+
+To what arity should we eta-expand the argument? `cpeArg` uses two strategies,
+governed by the presence of `-fdo-clever-arg-eta-expansion` (implied by -O):
+
+ 1. Cheap, with -O0: just use `exprArity`.
+ 2. More clever but expensive, with -O1 -O2: use `exprEtaExpandArity`,
+ same function the Simplifier uses to eta expand RHSs and lambda bodies.
+
+The only reason for using (1) rather than (2) is to keep compile times down.
+Using (2) in -O0 bumped up compiler allocations by 2-3% in tests T4801 and
+T5321*. However, Plan (2) catches cases that (1) misses.
+For example (#23083, assuming -fno-pedantic-bottoms):
+
+ let t = case z of __DEFAULT -> g x
+ in f t
+
+to
+
+ let t = \y -> case z of __DEFAULT -> g x y
+ in f t
+
+Note that there is a missed opportunity in eta expanding `t` earlier, in the
+Simplifier: It would allow us to inline `g`, potentially enabling further
+simplification. But then we could have inlined `g` into the PAP to begin with,
+and that is discussed in #23150; hence we needn't worry about that in CorePrep.
-}
cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs
@@ -1977,6 +1990,11 @@ data CorePrepConfig = CorePrepConfig
, cp_convertNumLit :: !(LitNumType -> Integer -> Maybe CoreExpr)
-- ^ Convert some numeric literals (Integer, Natural) into their final
-- Core form.
+
+ , cp_arityOpts :: !(Maybe ArityOpts)
+ -- ^ Configuration for arity analysis ('exprEtaExpandArity').
+ -- See Note [Eta expansion of arguments in CorePrep]
+ -- When 'Nothing' (e.g., -O0, -O1), use the cheaper 'exprArity' instead
}
data CorePrepEnv
@@ -1987,6 +2005,7 @@ data CorePrepEnv
-- enabled we instead produce an 'error' expression to catch
-- the case where a function we think should bottom
-- unexpectedly returns.
+
, cpe_env :: IdEnv CoreExpr -- Clone local Ids
-- ^ This environment is used for three operations:
--
=====================================
compiler/GHC/Driver/Config/CoreToStg/Prep.hs
=====================================
@@ -9,6 +9,7 @@ import GHC.Core.Opt.Pipeline.Types ( CoreToDo(..) )
import GHC.Driver.Env
import GHC.Driver.Session
import GHC.Driver.Config.Core.Lint
+import GHC.Driver.Config.Core.Opt.Arity
import GHC.Tc.Utils.Env
import GHC.Types.Var
import GHC.Utils.Outputable ( alwaysQualify )
@@ -17,14 +18,18 @@ import GHC.CoreToStg.Prep
initCorePrepConfig :: HscEnv -> IO CorePrepConfig
initCorePrepConfig hsc_env = do
+ let dflags = hsc_dflags hsc_env
convertNumLit <- do
- let platform = targetPlatform $ hsc_dflags hsc_env
+ let platform = targetPlatform dflags
home_unit = hsc_home_unit hsc_env
lookup_global = lookupGlobal hsc_env
mkConvertNumLiteral platform home_unit lookup_global
return $ CorePrepConfig
- { cp_catchNonexhaustiveCases = gopt Opt_CatchNonexhaustiveCases $ hsc_dflags hsc_env
+ { cp_catchNonexhaustiveCases = gopt Opt_CatchNonexhaustiveCases dflags
, cp_convertNumLit = convertNumLit
+ , cp_arityOpts = if gopt Opt_DoCleverArgEtaExpansion dflags
+ then Just (initArityOpts dflags)
+ else Nothing
}
initCorePrepPgmConfig :: DynFlags -> [Var] -> CorePrepPgmConfig
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -262,6 +262,7 @@ data GeneralFlag
| Opt_SpecConstr
| Opt_SpecConstrKeen
| Opt_DoLambdaEtaExpansion
+ | Opt_DoCleverArgEtaExpansion -- More sophisticated eta expansion of arguments in CorePrep
| Opt_IgnoreAsserts
| Opt_DoEtaReduction
| Opt_CaseMerge
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -3467,6 +3467,7 @@ fFlagsDeps = [
Opt_DmdTxDictSel "effect is now unconditionally enabled",
flagSpec "do-eta-reduction" Opt_DoEtaReduction,
flagSpec "do-lambda-eta-expansion" Opt_DoLambdaEtaExpansion,
+ flagSpec "do-clever-arg-eta-expansion" Opt_DoCleverArgEtaExpansion,
flagSpec "eager-blackholing" Opt_EagerBlackHoling,
flagSpec "embed-manifest" Opt_EmbedManifest,
flagSpec "enable-rewrite-rules" Opt_EnableRewriteRules,
@@ -4059,6 +4060,7 @@ optLevelFlags :: [([Int], GeneralFlag)]
-- Default settings of flags, before any command-line overrides
optLevelFlags -- see Note [Documenting optimisation flags]
= [ ([0,1,2], Opt_DoLambdaEtaExpansion)
+ , ([1,2], Opt_DoCleverArgEtaExpansion)
, ([0,1,2], Opt_DoEtaReduction) -- See Note [Eta-reduction in -O0]
, ([0,1,2], Opt_LlvmTBAA)
, ([0,1,2], Opt_ProfManualCcs )
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -1748,7 +1748,7 @@ freeNamesIfProv :: IfaceUnivCoProv -> NameSet
freeNamesIfProv (IfacePhantomProv co) = freeNamesIfCoercion co
freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co
freeNamesIfProv (IfacePluginProv _) = emptyNameSet
-freeNamesIfProv (IfaceCorePrepProv _) = emptyNameSet
+freeNamesIfProv IfaceCorePrepProv = emptyNameSet
freeNamesIfVarBndr :: VarBndr IfaceBndr vis -> NameSet
freeNamesIfVarBndr (Bndr bndr _) = freeNamesIfBndr bndr
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -402,7 +402,7 @@ data IfaceUnivCoProv
= IfacePhantomProv IfaceCoercion
| IfaceProofIrrelProv IfaceCoercion
| IfacePluginProv String
- | IfaceCorePrepProv Bool -- See defn of CorePrepProv
+ | IfaceCorePrepProv -- See defn of CorePrepProv
{- Note [Holes in IfaceCoercion]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -624,7 +624,7 @@ substIfaceType env ty
go_prov (IfacePhantomProv co) = IfacePhantomProv (go_co co)
go_prov (IfaceProofIrrelProv co) = IfaceProofIrrelProv (go_co co)
go_prov co@(IfacePluginProv _) = co
- go_prov co@(IfaceCorePrepProv _) = co
+ go_prov co at IfaceCorePrepProv = co
substIfaceAppArgs :: IfaceTySubst -> IfaceAppArgs -> IfaceAppArgs
substIfaceAppArgs env args
@@ -1860,7 +1860,7 @@ pprIfaceUnivCoProv (IfaceProofIrrelProv co)
= text "irrel" <+> pprParendIfaceCoercion co
pprIfaceUnivCoProv (IfacePluginProv s)
= text "plugin" <+> doubleQuotes (text s)
-pprIfaceUnivCoProv (IfaceCorePrepProv _)
+pprIfaceUnivCoProv IfaceCorePrepProv
= text "CorePrep"
-------------------
@@ -2229,9 +2229,8 @@ instance Binary IfaceUnivCoProv where
put_ bh (IfacePluginProv a) = do
putByte bh 3
put_ bh a
- put_ bh (IfaceCorePrepProv a) = do
+ put_ bh IfaceCorePrepProv = do
putByte bh 4
- put_ bh a
get bh = do
tag <- getByte bh
@@ -2242,8 +2241,7 @@ instance Binary IfaceUnivCoProv where
return $ IfaceProofIrrelProv a
3 -> do a <- get bh
return $ IfacePluginProv a
- 4 -> do a <- get bh
- return (IfaceCorePrepProv a)
+ 4 -> do return IfaceCorePrepProv
_ -> panic ("get IfaceUnivCoProv " ++ show tag)
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -1520,7 +1520,7 @@ tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance
tcIfaceUnivCoProv (IfacePhantomProv kco) = PhantomProv <$> tcIfaceCo kco
tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco
tcIfaceUnivCoProv (IfacePluginProv str) = return $ PluginProv str
-tcIfaceUnivCoProv (IfaceCorePrepProv b) = return $ CorePrepProv b
+tcIfaceUnivCoProv IfaceCorePrepProv = return CorePrepProv
{-
************************************************************************
=====================================
compiler/GHC/Stg/CSE.hs
=====================================
@@ -447,7 +447,7 @@ stgCseRhs env bndr (StgRhsClosure ext ccs upd args body)
mkStgCase :: StgExpr -> OutId -> AltType -> [StgAlt] -> StgExpr
-mkStgCase scrut bndr ty alts | all isBndr alts = scrut
+mkStgCase scrut bndr ty alts | all isBndr alts = scrut -- NB: Always true for empty Case!
| otherwise = StgCase scrut bndr ty alts
where
=====================================
compiler/GHC/Stg/Unarise.hs
=====================================
@@ -650,6 +650,9 @@ elimCase _ args bndr alt_ty alts
--------------------------------------------------------------------------------
unariseAlts :: UnariseEnv -> AltType -> InId -> [StgAlt] -> UniqSM [StgAlt]
+unariseAlts _ _ _ []
+ = return [] -- See Note [Empty case alternatives]
+
unariseAlts rho (MultiValAlt n) bndr [GenStgAlt{ alt_con = DEFAULT
, alt_bndrs = []
, alt_rhs = e}]
=====================================
compiler/GHC/StgToCmm/Expr.hs
=====================================
@@ -53,7 +53,6 @@ import GHC.Utils.Misc
import GHC.Data.FastString
import GHC.Utils.Outputable
import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
import Control.Monad ( unless, void )
import Control.Arrow ( first )
@@ -427,6 +426,8 @@ data GcPlan
-------------------------------------
cgCase :: CgStgExpr -> Id -> AltType -> [CgStgAlt] -> FCode ReturnKind
+cgCase e _ _ [] = cgExpr e -- See Note [Empty case alternatives]
+
{-
Note [Scrutinising VoidRep]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1028,7 +1029,7 @@ cgIdApp fun_id args = do
(text "TagCheck failed on entry in" <+> ppr mod <+> text "- value:" <> ppr fun_id <+> pdoc platform fun))
fun
- EnterIt -> assert (null args) $ -- Discarding arguments
+ EnterIt -> assertPpr (null args) (ppr fun_id $$ ppr args) $ -- Discarding arguments
emitEnter fun
SlowCall -> do -- A slow function call via the RTS apply routines
=====================================
compiler/GHC/StgToJS/Expr.hs
=====================================
@@ -571,6 +571,9 @@ genCase :: HasDebugCallStack
-> LiveVars
-> G (JStat, ExprResult)
genCase ctx bnd e at alts l
+ | [] <- alts = genExpr ctx e
+ -- See Note [Empty case alternatives];
+ -- we simply generate code for eval'ing the scrutinee
| snd (isInlineExpr (ctxEvaluatedIds ctx) e) = do
bndi <- identsForId bnd
let ctx' = ctxSetTop bnd
=====================================
compiler/GHC/Tc/TyCl/Utils.hs
=====================================
@@ -156,7 +156,7 @@ synonymTyConsOfType ty
go_prov (PhantomProv co) = go_co co
go_prov (ProofIrrelProv co) = go_co co
go_prov (PluginProv _) = emptyNameEnv
- go_prov (CorePrepProv _) = emptyNameEnv
+ go_prov CorePrepProv = emptyNameEnv
go_tc tc | isTypeSynonymTyCon tc = unitNameEnv (tyConName tc) tc
| otherwise = emptyNameEnv
=====================================
compiler/GHC/Tc/Utils/TcMType.hs
=====================================
@@ -1578,7 +1578,7 @@ collect_cand_qtvs_co orig_ty cur_lvl bound = go_co
go_prov dv (PhantomProv co) = go_co dv co
go_prov dv (ProofIrrelProv co) = go_co dv co
go_prov dv (PluginProv _) = return dv
- go_prov dv (CorePrepProv _) = return dv
+ go_prov dv CorePrepProv = return dv
go_cv :: CandidatesQTvs -> CoVar -> TcM CandidatesQTvs
go_cv dv@(DV { dv_cvs = cvs }) cv
=====================================
docs/users_guide/using-optimisation.rst
=====================================
@@ -467,6 +467,17 @@ by saying ``-fno-wombat``.
Eta-expand let-bindings to increase their arity.
+.. ghc-flag:: -fdo-clever-arg-eta-expansion
+ :shortdesc: Enable sophisticated argument eta-expansion. Implied by :ghc-flag:`-O2`.
+ :type: dynamic
+ :reverse: -fno-do-clever-arg-eta-expansion
+ :category:
+
+ :default: off
+
+ Eta-expand arguments to increase their arity to avoid allocating unnecessary
+ thunks for them.
+
.. ghc-flag:: -feager-blackholing
:shortdesc: Turn on :ref:`eager blackholing <parallel-compile-options>`
:type: dynamic
=====================================
testsuite/tests/simplCore/should_compile/T23083.hs
=====================================
@@ -0,0 +1,6 @@
+{-# OPTIONS_GHC -O2 -fforce-recomp #-}
+
+module T23083 where
+
+g :: ((Integer -> Integer) -> Integer) -> (Integer -> Integer) -> Integer
+g f h = f (h `seq` (h $))
=====================================
testsuite/tests/simplCore/should_compile/T23083.stderr
=====================================
@@ -0,0 +1,42 @@
+
+==================== CorePrep ====================
+Result size of CorePrep = {terms: 27, types: 24, coercions: 0, joins: 0/1}
+
+-- RHS size: {terms: 12, types: 13, coercions: 0, joins: 0/1}
+T23083.g :: ((GHC.Num.Integer.Integer -> GHC.Num.Integer.Integer) -> GHC.Num.Integer.Integer) -> (GHC.Num.Integer.Integer -> GHC.Num.Integer.Integer) -> GHC.Num.Integer.Integer
+[GblId, Arity=2, Str=<1C(1,L)><ML>, Unf=OtherCon []]
+T23083.g
+ = \ (f [Occ=Once1!] :: (GHC.Num.Integer.Integer -> GHC.Num.Integer.Integer) -> GHC.Num.Integer.Integer) (h [Occ=OnceL1] :: GHC.Num.Integer.Integer -> GHC.Num.Integer.Integer) ->
+ let {
+ sat [Occ=Once1] :: GHC.Num.Integer.Integer -> GHC.Num.Integer.Integer
+ [LclId]
+ sat = \ (eta [Occ=Once1] :: GHC.Num.Integer.Integer) -> case h of h1 [Occ=Once1] { __DEFAULT -> GHC.Base.$ @GHC.Types.LiftedRep @GHC.Num.Integer.Integer @GHC.Num.Integer.Integer h1 eta } } in
+ f sat
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T23083.$trModule4 :: GHC.Prim.Addr#
+[GblId, Unf=OtherCon []]
+T23083.$trModule4 = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T23083.$trModule3 :: GHC.Types.TrName
+[GblId, Unf=OtherCon []]
+T23083.$trModule3 = GHC.Types.TrNameS T23083.$trModule4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T23083.$trModule2 :: GHC.Prim.Addr#
+[GblId, Unf=OtherCon []]
+T23083.$trModule2 = "T23083"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T23083.$trModule1 :: GHC.Types.TrName
+[GblId, Unf=OtherCon []]
+T23083.$trModule1 = GHC.Types.TrNameS T23083.$trModule2
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T23083.$trModule :: GHC.Types.Module
+[GblId, Unf=OtherCon []]
+T23083.$trModule = GHC.Types.Module T23083.$trModule3 T23083.$trModule1
+
+
+
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -477,3 +477,4 @@ test('T23012', normal, compile, ['-O'])
test('RewriteHigherOrderPatterns', normal, compile, ['-O -ddump-rule-rewrites -dsuppress-all -dsuppress-uniques'])
test('T23024', normal, multimod_compile, ['T23024', '-O -v0'])
test('T23026', normal, compile, ['-O'])
+test('T23083', [ grep_errmsg(r'eta.+::.+Integer') ], compile, ['-O -ddump-prep -dsuppress-uniques -dppr-cols=99999'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/469dbdf53edb300a888a90b6abf6193c4c804039...a60cd2757f45e341bbd6df34acc16fead945547a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/469dbdf53edb300a888a90b6abf6193c4c804039...a60cd2757f45e341bbd6df34acc16fead945547a
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/20230418/d54d4a48/attachment-0001.html>
More information about the ghc-commits
mailing list