[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
Fri Mar 31 16:00:23 UTC 2023
Sebastian Graf pushed to branch wip/T23083 at Glasgow Haskell Compiler / GHC
Commits:
9b82bdb4 by Sebastian Graf at 2023-03-31T17:48:50+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`.
- - - - -
d0bcf370 by Sebastian Graf at 2023-03-31T17:48:50+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.
Fixes #23083.
- - - - -
25 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/Ppr.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/Iface/Syntax.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Stg/CSE.hs
- compiler/GHC/StgToCmm/Expr.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- + 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,11 @@ 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.
+* An empty case is compiled as an eval on the scrutinee in
+ GHC.StgToCmm.Expr.cgCase.
+ Historically, we lowered 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. 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/Ppr.hs
=====================================
@@ -240,7 +240,13 @@ ppr_expr add_par expr@(App {})
_ -> parens (hang (pprParendExpr fun) 2 pp_args)
}
-ppr_expr add_par (Case expr var ty [Alt con args rhs])
+ppr_expr add_par (Case expr _ ty []) -- Empty Case
+ = add_par $ sep [text "case"
+ <+> pprCoreExpr expr
+ <+> whenPprDebug (text "return" <+> ppr ty),
+ text "of {}"]
+
+ppr_expr add_par (Case expr var ty [Alt con args rhs]) -- Single alt Case
= sdocOption sdocPrintCaseAsLet $ \case
True -> add_par $ -- See Note [Print case as let]
sep [ sep [ text "let! {"
@@ -264,7 +270,7 @@ ppr_expr add_par (Case expr var ty [Alt con args rhs])
where
ppr_bndr = pprBndr CaseBind
-ppr_expr add_par (Case expr var ty alts)
+ppr_expr add_par (Case expr var ty alts) -- Multi alt Case
= add_par $
sep [sep [text "case"
<+> pprCoreExpr expr
=====================================
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
@@ -1104,7 +1104,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
@@ -1318,5 +1318,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
@@ -1821,7 +1821,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
=====================================
@@ -563,7 +563,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
@@ -981,7 +981,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
=====================================
@@ -406,7 +406,7 @@ coreToStgExpr expr@(App _ _)
-- rep might not be equal to rep2
-> return (StgLit $ LitRubbish TypeLike $ getRuntimeRep (exprType expr))
- _ -> pprPanic "coreToStgExpr - Invalid app head:" (ppr expr)
+ _ -> pprPanic "coreToStgExpr - Invalid app head:" (ppr app_head $$ ppr expr)
where
(app_head, args, ticks) = myCollectArgs expr
coreToStgExpr expr@(Lam _ _)
=====================================
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,31 @@ cpeArg env dmd arg
; if okCpeArg arg2
then do { v <- newVar arg_ty
- ; let arg3 = cpeEtaExpand (exprArity arg2) arg2
+ ; let ao = cp_arityOpts (cpe_config env)
+ -- See Note [Eta expansion of arguments in CorePrep]
+ ; let arg3 | Just at <- exprEtaExpandArity ao arg2
+ , 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
+ = cpeEtaExpand (arityTypeArity at) arg2
+ | otherwise
+ = 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 +1587,36 @@ 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]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We eta expand arguments in here, in CorePrep, rather than in the Simplifier, and
+do so based on 'exprEtaExpandArity' rather than the cheaper 'exprArity' analysis
+we do on let RHSs and lambdas. The reason for the latter is that the Simplifier
+has already run the more costly analysis on lambdas and let RHSs and eta
+expanded accordingly, while it does not try to eta expand arguments at all.
+
+So why eta expand arguments in CorePrep rather than in the Simplifier?
+There are two reasons why eta expansion of arguments is useful
+
+ 1. In expressions like @f (h `seq` (g $))@ (from T23083) eta expanding the
+ argument to @f (\x -> h `seq` (g $ x))@ allows us to save allocation of a
+ closure and have a faster call sequence; a code-gen matter.
+
+ 2. The eta expansion to @f (\x -> h `seq` (g $ x))@ gives rise to another
+ opportunity: We could inline ($), saving call overhead and perhaps turning
+ an unknown call into a known call. In general, there could be further
+ simplification based on the structure of the concrete argument `x`.
+ Whether we should inline in the PAP `(g $)` (thus solving this problem
+ independently of (1)) is discussed in #22886.
+
+To profit from (1), it is enough to eta expand in CorePrep, while (2) shows
+that in some rare cases as above, eta expansion of arguments may enable
+further simplification. CorePrep would not allow to exploit (2), while eta
+expansion in the Simplifier would.
+
+Alas, trying to eta expand arguments in every round of the Simplifier is costly
+(!10088 measured a geom. mean of +2.0% regression in ghc/alloc perf, regressing
+as much as 27.2%), so we only exploit (1) for now.
-}
cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs
@@ -1977,6 +1980,9 @@ data CorePrepConfig = CorePrepConfig
, cp_convertNumLit :: !(LitNumType -> Integer -> Maybe CoreExpr)
-- ^ Convert some numeric literals (Integer, Natural) into their final
-- Core form.
+
+ , cp_arityOpts :: !ArityOpts
+ -- ^ Configuration for arity analysis ('exprEtaExpandArity').
}
data CorePrepEnv
@@ -1987,6 +1993,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,16 @@ 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_convertNumLit = convertNumLit
+ , cp_arityOpts = initArityOpts dflags
}
initCorePrepPgmConfig :: DynFlags -> [Var] -> CorePrepPgmConfig
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -1741,7 +1741,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
=====================================
@@ -1510,7 +1510,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/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/Tc/TyCl/Utils.hs
=====================================
@@ -157,7 +157,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
=====================================
@@ -1535,7 +1535,7 @@ collect_cand_qtvs_co orig_ty 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
=====================================
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/62007593d948d3b4726f5644adf12089724f689e...d0bcf3702b2c5a701525b3a0e95ca8213e6e1d52
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/62007593d948d3b4726f5644adf12089724f689e...d0bcf3702b2c5a701525b3a0e95ca8213e6e1d52
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/20230331/52617c09/attachment-0001.html>
More information about the ghc-commits
mailing list