[Git][ghc/ghc][wip/T23083] 2 commits: CorePrep: Eliminate EmptyCase and unsafeEqualityProof in CoreToStg instead
Sebastian Graf (@sgraf812)
gitlab at gitlab.haskell.org
Fri Apr 28 10:49:02 UTC 2023
Sebastian Graf pushed to branch wip/T23083 at Glasgow Haskell Compiler / GHC
Commits:
50b72e99 by Sebastian Graf at 2023-04-28T12:48:42+02:00
CorePrep: Eliminate EmptyCase and unsafeEqualityProof in CoreToStg instead
We eliminate EmptyCase by way of `coreToStg (Case e _ _ []) = coreToStg 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.
We do also give the same treatment to unsafeCoerce proofs and treat them as
trivial iff their RHS is trivial.
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 `CorePrepProv`.
- - - - -
cd7b0b2a by Sebastian Graf at 2023-04-28T12:48:42+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.
- - - - -
30 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/Core/Unfold.hs
- compiler/GHC/Core/Utils.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/StgToCmm/Expr.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Utils/Trace.hs
- docs/users_guide/using-optimisation.rst
- libraries/base/Unsafe/Coerce.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,12 @@ 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 lower empty cases in GHC.CoreToStg to an eval on the scrutinee.
+
+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 just a bit longer.
Note [Join points]
~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Core/Coercion.hs
=====================================
@@ -1390,7 +1390,6 @@ 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
= Just $ UnivCo prov Nominal co1 co2
setNominalRole_maybe_helper _ = Nothing
@@ -1516,7 +1515,6 @@ promoteCoercion co = case co of
UnivCo (PhantomProv kco) _ _ _ -> kco
UnivCo (ProofIrrelProv kco) _ _ _ -> kco
UnivCo (PluginProv _) _ _ _ -> mkKindCo co
- UnivCo (CorePrepProv _) _ _ _ -> mkKindCo co
SymCo g
-> mkSymCo (promoteCoercion g)
@@ -2339,7 +2337,6 @@ seqProv :: UnivCoProvenance -> ()
seqProv (PhantomProv co) = seqCo co
seqProv (ProofIrrelProv co) = seqCo co
seqProv (PluginProv _) = ()
-seqProv (CorePrepProv _) = ()
seqCos :: [Coercion] -> ()
seqCos [] = ()
=====================================
compiler/GHC/Core/Coercion/Opt.hs
=====================================
@@ -622,7 +622,6 @@ opt_univ env sym prov role oty1 oty2
#endif
ProofIrrelProv kco -> ProofIrrelProv $ opt_co4_wrap env sym False Nominal kco
PluginProv _ -> prov
- CorePrepProv _ -> prov
-------------
opt_transList :: HasDebugCallStack => InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo]
=====================================
compiler/GHC/Core/FVs.hs
=====================================
@@ -410,7 +410,6 @@ orphNamesOfProv :: UnivCoProvenance -> NameSet
orphNamesOfProv (PhantomProv co) = orphNamesOfCo co
orphNamesOfProv (ProofIrrelProv co) = orphNamesOfCo co
orphNamesOfProv (PluginProv _) = emptyNameSet
-orphNamesOfProv (CorePrepProv _) = emptyNameSet
orphNamesOfCos :: [Coercion] -> NameSet
orphNamesOfCos = orphNamesOfThings orphNamesOfCo
@@ -798,4 +797,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,7 @@ 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
check_kinds kco k1 k2
= do { let Pair k1' k2' = coercionKind kco
=====================================
compiler/GHC/Core/TyCo/FVs.hs
=====================================
@@ -661,7 +661,6 @@ 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
tyCoFVsOfCos :: [Coercion] -> FV
tyCoFVsOfCos [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc
@@ -731,8 +730,7 @@ 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_type :: Type -> CoVar -> Bool
almost_devoid_co_var_of_type (TyVarTy _) _ = True
@@ -1131,9 +1129,6 @@ tyConsOfType ty
go_prov (PhantomProv co) = go_co co
go_prov (ProofIrrelProv co) = go_co co
go_prov (PluginProv _) = emptyUniqSet
- go_prov (CorePrepProv _) = emptyUniqSet
- -- this last case can happen from the tyConsOfType used from
- -- checkTauTvUpdate
go_cos cos = foldr (unionUniqSets . go_co) emptyUniqSet cos
@@ -1345,5 +1340,3 @@ 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
-
=====================================
compiler/GHC/Core/TyCo/Rep.hs
=====================================
@@ -1437,17 +1437,12 @@ 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#
-
deriving Data.Data
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)"
-- | A coercion to be filled in by the type-checker. See Note [Coercion holes]
data CoercionHole
@@ -1760,7 +1755,6 @@ 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
-- | A view function that looks through nothing.
noView :: Type -> Maybe Type
@@ -1826,7 +1820,6 @@ provSize :: UnivCoProvenance -> Int
provSize (PhantomProv co) = 1 + coercionSize co
provSize (ProofIrrelProv co) = 1 + coercionSize co
provSize (PluginProv _) = 1
-provSize (CorePrepProv _) = 1
{-
************************************************************************
=====================================
compiler/GHC/Core/TyCo/Subst.hs
=====================================
@@ -912,7 +912,6 @@ 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
-- See Note [Substituting in a coercion hole]
go_hole h@(CoercionHole { ch_co_var = cv })
=====================================
compiler/GHC/Core/TyCo/Tidy.hs
=====================================
@@ -252,7 +252,6 @@ 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
tidyCos :: TidyEnv -> [Coercion] -> [Coercion]
tidyCos env = strictMap (tidyCo env)
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -580,7 +580,6 @@ 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
-- the "False" and "const" are to accommodate the type of
-- substForAllCoBndrUsing, which is general enough to
@@ -998,7 +997,6 @@ 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
{- *********************************************************************
=====================================
compiler/GHC/Core/Unfold.hs
=====================================
@@ -249,8 +249,11 @@ inlineBoringOk e
, exprIsTrivial a = go (credit-1) f
go credit (Tick _ e) = go credit e -- dubious
go credit (Cast e _) = go credit e
- go credit (Case scrut _ _ [Alt _ _ rhs]) -- See Note [Inline unsafeCoerce]
- | isUnsafeEqualityProof scrut = go credit rhs
+ go credit (Case e b _ alts)
+ | null alts
+ = go credit e -- EmptyCase is like e
+ | Just rhs <- isUnsafeEqualityCase e b alts
+ = go credit rhs -- See Note [Inline unsafeCoerce]
go _ (Var {}) = boringCxtOk
go _ (Lit l) = litIsTrivial l && boringCxtOk
go _ _ = boringCxtNotOk
@@ -304,7 +307,7 @@ calcUnfoldingGuidance opts is_top_bottoming expr
We really want to inline unsafeCoerce, even when applied to boring
arguments. It doesn't look as if its RHS is smaller than the call
unsafeCoerce x = case unsafeEqualityProof @a @b of UnsafeRefl -> x
-but that case is discarded -- see Note [Implementing unsafeCoerce]
+but that case is discarded in CoreToStg -- see Note [Implementing unsafeCoerce]
in base:Unsafe.Coerce.
Moreover, if we /don't/ inline it, we may be left with
@@ -312,7 +315,9 @@ Moreover, if we /don't/ inline it, we may be left with
which will build a thunk -- bad, bad, bad.
Conclusion: we really want inlineBoringOk to be True of the RHS of
-unsafeCoerce. This is (U4) in Note [Implementing unsafeCoerce].
+unsafeCoerce. And it really is, because we regard
+ case unsafeEqualityProof @a @b of UnsafeRefl -> rhs
+as trivial iff rhs is. This is (U4) in Note [Implementing unsafeCoerce].
Note [Computing the size of an expression]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -59,7 +59,7 @@ module GHC.Core.Utils (
mkStrictFieldSeqs, shouldStrictifyIdForCbv, shouldUseCbvForId,
-- * unsafeEqualityProof
- isUnsafeEqualityProof,
+ isUnsafeEqualityCase,
-- * Dumping stuff
dumpIdInfoOfProgram
@@ -79,7 +79,7 @@ import GHC.Core.Reduction
import GHC.Core.TyCon
import GHC.Core.Multiplicity
-import GHC.Builtin.Names ( makeStaticName, unsafeEqualityProofIdKey )
+import GHC.Builtin.Names ( makeStaticName, unsafeEqualityProofIdKey, unsafeReflDataConKey )
import GHC.Builtin.PrimOps
import GHC.Types.Var
@@ -1072,7 +1072,11 @@ trivial_expr_fold k_id k_lit k_triv k_not_triv = go
go (Lam b e) | not (isRuntimeVar b) = go e
go (Tick t e) | not (tickishIsCode t) = go e -- See Note [Tick trivial]
go (Cast e _) = go e
- go (Case e _ _ []) = go e -- See Note [Empty case is trivial]
+ go (Case e b _ as)
+ | null as
+ = go e -- See Note [Empty case is trivial]
+ | Just rhs <- isUnsafeEqualityCase e b as
+ = go rhs -- See (U2) of Note [Implementing unsafeCoerce] in base:Unsafe.Coerce
go _ = k_not_triv
exprIsTrivial :: CoreExpr -> Bool
@@ -2707,11 +2711,22 @@ wantCbvForId cbv_for_strict v
* *
********************************************************************* -}
-isUnsafeEqualityProof :: CoreExpr -> Bool
+isUnsafeEqualityCase :: CoreExpr -> Id -> [CoreAlt] -> Maybe CoreExpr
-- See (U3) and (U4) in
-- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce
-isUnsafeEqualityProof e
- | Var v `App` Type _ `App` Type _ `App` Type _ <- e
- = v `hasKey` unsafeEqualityProofIdKey
- | otherwise
- = False
+isUnsafeEqualityCase scrut bndr [Alt ac _ rhs]
+ | DataAlt dc <- ac
+ , not (dc `hasKey` unsafeReflDataConKey)
+ = Nothing -- fast path for DataAlt
+
+ | isDeadBinder bndr
+ -- We can only discard the case if the case-binder is dead
+ -- It usually is, but see #18227
+ , Var v `App` _ `App` _ `App` _ <- scrut
+ , v `hasKey` unsafeEqualityProofIdKey
+ -- Check that the scrutinee really is unsafeEqualityProof
+ -- and not, say, error
+ = Just rhs
+
+isUnsafeEqualityCase _ _ _
+ = Nothing
=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -321,7 +321,6 @@ 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
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,30 +429,23 @@ coreToStgExpr (Cast expr _)
= coreToStgExpr expr
-- Cases require a little more real work.
-
-{-
-coreToStgExpr (Case scrut _ _ [])
+coreToStgExpr (Case scrut bndr _ alts)
+ | null alts
+ -- 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 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
+
+ | Just rhs <- isUnsafeEqualityCase scrut bndr alts
+ -- See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce
= coreToStgExpr rhs
- -- See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce
--}
--- The normal case for case-expressions
-coreToStgExpr (Case scrut bndr _ alts)
+ | otherwise
= do { scrut2 <- coreToStgExpr scrut
; alts2 <- extendVarEnvCts [(bndr, LambdaBound)] (mapM vars_alt alts)
; return (StgCase scrut2 bndr (mkStgAltType bndr alts) alts2) }
@@ -574,6 +566,15 @@ coreToStgApp f args ticks = do
-- This is the guy that turns applications into A-normal form
-- ---------------------------------------------------------------------------
+getStgArgFromTrivialArg :: HasDebugCallStack => CoreArg -> StgArg
+-- A (non-erased) trivial CoreArg corresponds to an atomic StgArg.
+-- CoreArgs may not immediately look trivial, e.g., `case e of {}` or
+-- `case unsafeequalityProof of UnsafeRefl -> e` might intervene.
+-- Good thing we can just call `trivial_expr_fold` here.
+getStgArgFromTrivialArg e = trivial_expr_fold StgVarArg StgLitArg panic panic e
+ where
+ panic = pprPanic "getStgArgFromTrivialArg" (ppr e)
+
coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [StgTickish])
coreToStgArgs []
= return ([], [])
@@ -586,42 +587,29 @@ coreToStgArgs (Coercion _ : args) -- Coercion argument; See Note [Coercion token
= do { (args', ts) <- coreToStgArgs args
; return (StgVarArg coercionTokenId : args', ts) }
-coreToStgArgs (Tick t e : args)
- = assert (not (tickishIsCode t)) $
- do { (args', ts) <- coreToStgArgs (e : args)
- ; let !t' = coreToStgTick (exprType e) t
- ; return (args', t':ts) }
-
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
-
+ -- We know that `arg` must be trivial, but it may contain Ticks.
+ -- Example from test case `decodeMyStack`:
+ -- $ @... ((src<decodeMyStack.hs:18:26-28> Data.Tuple.snd) @Int @[..])
+ -- Note that unfortunately the Tick is not at the top.
+ -- So we'll traverse the expression twice:
+ -- * Once with `stripTicksT` (which collects *all* ticks from the expression)
+ -- * and another time with `getStgArgFromTrivialArg`.
+ -- Since the argument is trivial, the only place the Tick can occur is
+ -- somehow wrapping a variable (give or take type args, as above).
platform <- getPlatform
- let
- arg_rep = typePrimRep (exprType arg)
- stg_arg_rep = typePrimRep (stgArgType stg_arg)
+ let arg_ty = exprType arg
+ ticks' = map (coreToStgTick arg_ty) (stripTicksT (not . tickishIsCode) arg)
+ arg' = getStgArgFromTrivialArg arg
+ arg_rep = typePrimRep arg_ty
+ 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)
+ massertPpr (length ticks' <= 1) (text "More than one Tick in trivial arg:" <+> ppr arg)
+ warnPprTraceM bad_args "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" (ppr arg)
+
+ return (arg' : stg_args, ticks' ++ ticks)
coreToStgTick :: Type -- type of the ticked expression
-> CoreTickish
@@ -959,6 +947,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 +961,14 @@ 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 b _ alts) as ts
+ | null alts
+ = assertPpr (null as) (ppr e $$ ppr as $$ ppr expr) $
+ go e [] ts -- NB: Empty case discards arguments
+ | Just rhs <- isUnsafeEqualityCase e b alts
+ = go rhs as ts -- Discards unsafeCoerce in App heads
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
=====================================
@@ -40,12 +40,10 @@ import GHC.Core.Coercion
import GHC.Core.TyCon
import GHC.Core.DataCon
import GHC.Core.Opt.OccurAnal
-import GHC.Core.TyCo.Rep( UnivCoProvenance(..) )
import GHC.Data.Maybe
import GHC.Data.OrdList
import GHC.Data.FastString
-import GHC.Data.Pair
import GHC.Data.Graph.UnVar
import GHC.Utils.Error
@@ -71,7 +69,6 @@ import GHC.Types.TyThing
import GHC.Types.Unique.Supply
import Data.List ( unfoldr )
-import Data.Functor.Identity
import Control.Monad
{-
@@ -142,10 +139,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.
- See Note [Unsafe coercions]
-
-13. Eliminate some magic Ids, specifically
+12. Eliminate some magic Ids, specifically
runRW# (\s. e) ==> e[readWorldId/s]
lazy e ==> e (see Note [lazyId magic] in GHC.Types.Id.Make)
noinline e ==> e
@@ -157,48 +151,6 @@ This is all done modulo type applications and abstractions, so that
when type erasure is done for conversion to STG, we don't end up with
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.
-
Note [CorePrep invariants]
~~~~~~~~~~~~~~~~~~~~~~~~~~
Here is the syntax of the Core produced by CorePrep:
@@ -785,10 +737,10 @@ cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
-- For example
-- f (g x) ===> ([v = g x], f v)
-cpeRhsE env (Type ty)
- = return (emptyFloats, Type (cpSubstTy env ty))
-cpeRhsE env (Coercion co)
- = return (emptyFloats, Coercion (cpSubstCo env co))
+cpeRhsE _ (Type ty)
+ = return (emptyFloats, Type ty)
+cpeRhsE _ (Coercion co)
+ = return (emptyFloats, Coercion co)
cpeRhsE env expr@(Lit (LitNumber nt i))
= case cp_convertNumLit (cpe_config env) nt i of
Nothing -> return (emptyFloats, expr)
@@ -822,7 +774,7 @@ cpeRhsE env (Tick tickish expr)
cpeRhsE env (Cast expr co)
= do { (floats, expr') <- cpeRhsE env expr
- ; return (floats, Cast expr' (cpSubstCo env co)) }
+ ; return (floats, Cast expr' co) }
cpeRhsE env expr@(Lam {})
= do { let (bndrs,body) = collectBinders expr
@@ -830,36 +782,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)
- | isUnsafeEqualityProof scrut
- , isDeadBinder bndr -- We can only discard the case if the case-binder
- -- 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
- env' = extendCoVarEnv env co_var the_co
- = cpeRhsE env' rhs
-
cpeRhsE env (Case scrut bndr ty alts)
= do { (floats, scrut') <- cpeBody env scrut
; (env', bndr2) <- cpCloneBndr env bndr
@@ -1205,14 +1127,10 @@ cpeApp top_env expr
in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth
CpeApp (Type arg_ty)
- -> rebuild_app' env as (App fun' (Type arg_ty')) floats ss rt_ticks req_depth
- where
- arg_ty' = cpSubstTy env arg_ty
+ -> rebuild_app' env as (App fun' (Type arg_ty)) floats ss rt_ticks req_depth
CpeApp (Coercion co)
- -> rebuild_app' env as (App fun' (Coercion co')) floats (drop 1 ss) rt_ticks req_depth
- where
- co' = cpSubstCo env co
+ -> rebuild_app' env as (App fun' (Coercion co)) floats (drop 1 ss) rt_ticks req_depth
CpeApp arg -> do
let (ss1, ss_rest) -- See Note [lazyId magic] in GHC.Types.Id.Make
@@ -1224,9 +1142,7 @@ cpeApp top_env expr
rebuild_app' env as (App fun' arg') (fs `appendFloats` floats) ss_rest rt_ticks (req_depth-1)
CpeCast co
- -> rebuild_app' env as (Cast fun' co') floats ss rt_ticks req_depth
- where
- co' = cpSubstCo env co
+ -> rebuild_app' env as (Cast fun' co) floats ss rt_ticks req_depth
-- See Note [Ticks and mandatory eta expansion]
CpeTick tickish
| tickishPlace tickish == PlaceRuntime
@@ -1497,11 +1413,32 @@ cpeArg env dmd arg
; if exprIsTrivial arg2
then return (floats2, arg2)
else 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) }
}
+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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1619,6 +1556,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
@@ -1982,6 +1957,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
@@ -1992,6 +1972,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:
--
@@ -2005,8 +1986,6 @@ data CorePrepEnv
-- see Note [lazyId magic], Note [Inlining in CorePrep]
-- and Note [CorePrep inlines trivial CoreExpr not Id] (#12076)
- , cpe_tyco_env :: Maybe CpeTyCoEnv -- See Note [CpeTyCoEnv]
-
, cpe_rec_ids :: UnVarSet -- Faster OutIdSet; See Note [Speculative evaluation]
}
@@ -2014,7 +1993,6 @@ mkInitialCorePrepEnv :: CorePrepConfig -> CorePrepEnv
mkInitialCorePrepEnv cfg = CPE
{ cpe_config = cfg
, cpe_env = emptyVarEnv
- , cpe_tyco_env = Nothing
, cpe_rec_ids = emptyUnVarSet
}
@@ -2041,117 +2019,6 @@ enterRecGroupRHSs :: CorePrepEnv -> [OutId] -> CorePrepEnv
enterRecGroupRHSs env grp
= env { cpe_rec_ids = extendUnVarSetList grp (cpe_rec_ids env) }
-------------------------------------------------------------------------------
--- CpeTyCoEnv
--- ---------------------------------------------------------------------------
-
-{- Note [CpeTyCoEnv]
-~~~~~~~~~~~~~~~~~~~~
-The cpe_tyco_env :: Maybe CpeTyCoEnv field carries a substitution
-for type and coercion variables
-
-* We need the coercion substitution to support the elimination of
- unsafeEqualityProof (see Note [Unsafe coercions])
-
-* We need the type substitution in case one of those unsafe
- coercions occurs in the kind of tyvar binder (sigh)
-
-We don't need an in-scope set because we don't clone any of these
-binders at all, so no new capture can take place.
-
-The cpe_tyco_env is almost always empty -- it only gets populated
-when we get under an usafeEqualityProof. Hence the Maybe CpeTyCoEnv,
-which makes everything into a no-op in the common case.
--}
-
-data CpeTyCoEnv = TCE TvSubstEnv CvSubstEnv
-
-emptyTCE :: CpeTyCoEnv
-emptyTCE = TCE emptyTvSubstEnv emptyCvSubstEnv
-
-extend_tce_cv :: CpeTyCoEnv -> CoVar -> Coercion -> CpeTyCoEnv
-extend_tce_cv (TCE tv_env cv_env) cv co
- = TCE tv_env (extendVarEnv cv_env cv co)
-
-extend_tce_tv :: CpeTyCoEnv -> TyVar -> Type -> CpeTyCoEnv
-extend_tce_tv (TCE tv_env cv_env) tv ty
- = TCE (extendVarEnv tv_env tv ty) cv_env
-
-lookup_tce_cv :: CpeTyCoEnv -> CoVar -> Coercion
-lookup_tce_cv (TCE _ cv_env) cv
- = case lookupVarEnv cv_env cv of
- Just co -> co
- Nothing -> mkCoVarCo cv
-
-lookup_tce_tv :: CpeTyCoEnv -> TyVar -> Type
-lookup_tce_tv (TCE tv_env _) tv
- = case lookupVarEnv tv_env tv of
- Just ty -> ty
- Nothing -> mkTyVarTy tv
-
-extendCoVarEnv :: CorePrepEnv -> CoVar -> Coercion -> CorePrepEnv
-extendCoVarEnv cpe@(CPE { cpe_tyco_env = mb_tce }) cv co
- = cpe { cpe_tyco_env = Just (extend_tce_cv tce cv co) }
- where
- tce = mb_tce `orElse` emptyTCE
-
-
-cpSubstTy :: CorePrepEnv -> Type -> Type
-cpSubstTy (CPE { cpe_tyco_env = mb_env }) ty
- = case mb_env of
- Just env -> runIdentity (subst_ty env ty)
- Nothing -> ty
-
-cpSubstCo :: CorePrepEnv -> Coercion -> Coercion
-cpSubstCo (CPE { cpe_tyco_env = mb_env }) co
- = case mb_env of
- Just tce -> runIdentity (subst_co tce co)
- Nothing -> co
-
-subst_tyco_mapper :: TyCoMapper CpeTyCoEnv Identity
-subst_tyco_mapper = TyCoMapper
- { tcm_tyvar = \env tv -> return (lookup_tce_tv env tv)
- , tcm_covar = \env cv -> return (lookup_tce_cv env cv)
- , tcm_hole = \_ hole -> pprPanic "subst_co_mapper:hole" (ppr hole)
- , tcm_tycobinder = \env tcv _vis -> if isTyVar tcv
- then return (subst_tv_bndr env tcv)
- else return (subst_cv_bndr env tcv)
- , tcm_tycon = \tc -> return tc }
-
-subst_ty :: CpeTyCoEnv -> Type -> Identity Type
-subst_co :: CpeTyCoEnv -> Coercion -> Identity Coercion
-(subst_ty, _, subst_co, _) = mapTyCoX subst_tyco_mapper
-
-cpSubstTyVarBndr :: CorePrepEnv -> TyVar -> (CorePrepEnv, TyVar)
-cpSubstTyVarBndr env@(CPE { cpe_tyco_env = mb_env }) tv
- = case mb_env of
- Nothing -> (env, tv)
- Just tce -> (env { cpe_tyco_env = Just tce' }, tv')
- where
- (tce', tv') = subst_tv_bndr tce tv
-
-subst_tv_bndr :: CpeTyCoEnv -> TyVar -> (CpeTyCoEnv, TyVar)
-subst_tv_bndr tce tv
- = (extend_tce_tv tce tv (mkTyVarTy tv'), tv')
- where
- tv' = mkTyVar (tyVarName tv) kind'
- kind' = runIdentity $ subst_ty tce $ tyVarKind tv
-
-cpSubstCoVarBndr :: CorePrepEnv -> CoVar -> (CorePrepEnv, CoVar)
-cpSubstCoVarBndr env@(CPE { cpe_tyco_env = mb_env }) cv
- = case mb_env of
- Nothing -> (env, cv)
- Just tce -> (env { cpe_tyco_env = Just tce' }, cv')
- where
- (tce', cv') = subst_cv_bndr tce cv
-
-subst_cv_bndr :: CpeTyCoEnv -> CoVar -> (CpeTyCoEnv, CoVar)
-subst_cv_bndr tce cv
- = (extend_tce_cv tce cv (mkCoVarCo cv'), cv')
- where
- cv' = mkCoVar (varName cv) ty'
- ty' = runIdentity (subst_ty tce $ varType cv)
-
------------------------------------------------------------------------------
-- Cloning binders
-- ---------------------------------------------------------------------------
@@ -2161,12 +2028,8 @@ cpCloneBndrs env bs = mapAccumLM cpCloneBndr env bs
cpCloneBndr :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar)
cpCloneBndr env bndr
- | isTyVar bndr
- = return (cpSubstTyVarBndr env bndr)
-
- | isCoVar bndr
- = return (cpSubstCoVarBndr env bndr)
-
+ | isTyCoVar bndr
+ = return (env, bndr)
| otherwise
= do { bndr' <- clone_it bndr
@@ -2186,8 +2049,7 @@ cpCloneBndr env bndr
clone_it bndr
| isLocalId bndr
= do { uniq <- getUniqueM
- ; let ty' = cpSubstTy env (idType bndr)
- ; return (setVarUnique (setIdType bndr ty') uniq) }
+ ; return (setVarUnique bndr uniq) }
| otherwise -- Top level things, which we don't want
-- to clone, have become GlobalIds by now
=====================================
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,6 @@ freeNamesIfProv :: IfaceUnivCoProv -> NameSet
freeNamesIfProv (IfacePhantomProv co) = freeNamesIfCoercion co
freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co
freeNamesIfProv (IfacePluginProv _) = emptyNameSet
-freeNamesIfProv (IfaceCorePrepProv _) = emptyNameSet
freeNamesIfVarBndr :: VarBndr IfaceBndr vis -> NameSet
freeNamesIfVarBndr (Bndr bndr _) = freeNamesIfBndr bndr
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -402,7 +402,6 @@ data IfaceUnivCoProv
= IfacePhantomProv IfaceCoercion
| IfaceProofIrrelProv IfaceCoercion
| IfacePluginProv String
- | IfaceCorePrepProv Bool -- See defn of CorePrepProv
{- Note [Holes in IfaceCoercion]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -624,7 +623,6 @@ 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
substIfaceAppArgs :: IfaceTySubst -> IfaceAppArgs -> IfaceAppArgs
substIfaceAppArgs env args
@@ -1860,8 +1858,6 @@ pprIfaceUnivCoProv (IfaceProofIrrelProv co)
= text "irrel" <+> pprParendIfaceCoercion co
pprIfaceUnivCoProv (IfacePluginProv s)
= text "plugin" <+> doubleQuotes (text s)
-pprIfaceUnivCoProv (IfaceCorePrepProv _)
- = text "CorePrep"
-------------------
instance Outputable IfaceTyCon where
@@ -2229,9 +2225,6 @@ instance Binary IfaceUnivCoProv where
put_ bh (IfacePluginProv a) = do
putByte bh 3
put_ bh a
- put_ bh (IfaceCorePrepProv a) = do
- putByte bh 4
- put_ bh a
get bh = do
tag <- getByte bh
@@ -2242,8 +2235,6 @@ instance Binary IfaceUnivCoProv where
return $ IfaceProofIrrelProv a
3 -> do a <- get bh
return $ IfacePluginProv a
- 4 -> do a <- get bh
- return (IfaceCorePrepProv a)
_ -> panic ("get IfaceUnivCoProv " ++ show tag)
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -1520,7 +1520,6 @@ 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
{-
************************************************************************
=====================================
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 )
@@ -1028,7 +1027,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
=====================================
@@ -156,7 +156,6 @@ 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_tc tc | isTypeSynonymTyCon tc = unitNameEnv (tyConName tc) tc
| otherwise = emptyNameEnv
=====================================
compiler/GHC/Tc/Utils/TcMType.hs
=====================================
@@ -1578,7 +1578,6 @@ 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_cv :: CandidatesQTvs -> CoVar -> TcM CandidatesQTvs
go_cv dv@(DV { dv_cvs = cvs }) cv
=====================================
compiler/GHC/Utils/Trace.hs
=====================================
@@ -8,6 +8,7 @@ module GHC.Utils.Trace
, pprSTrace
, pprTraceException
, warnPprTrace
+ , warnPprTraceM
, pprTraceUserWarning
, trace
)
@@ -84,6 +85,9 @@ warnPprTrace True s msg x
(text s $$ msg $$ withFrozenCallStack traceCallStackDoc )
x
+warnPprTraceM :: (Applicative f, HasCallStack) => Bool -> String -> SDoc -> f ()
+warnPprTraceM b s doc = withFrozenCallStack warnPprTrace b s doc (pure ())
+
-- | For when we want to show the user a non-fatal WARNING so that they can
-- report a GHC bug, but don't want to panic.
pprTraceUserWarning :: HasCallStack => SDoc -> a -> a
=====================================
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
=====================================
libraries/base/Unsafe/Coerce.hs
=====================================
@@ -88,13 +88,13 @@ several ways
(U1) unsafeEqualityProof is /never/ inlined.
-(U2) In CoreToStg.Prep, we transform
+(U2) In CoreToStg, we transform
case unsafeEqualityProof of UnsafeRefl g -> blah
==>
- blah[unsafe-co/g]
+ blah
- This eliminates the overhead of evaluating the unsafe
- equality proof.
+ This eliminates the overhead of evaluating the unsafe equality proof.
+ (It follows that the Case is trivial iff `blah` is.)
Any /other/ occurrence of unsafeEqualityProof is left alone.
For example you could write
@@ -131,9 +131,11 @@ several ways
Floating the case is OK here, even though it broadens the
scope, because we are done with simplification.
-(U4) Ditto GHC.Core.Unfold.inlineBoringOk we want to treat
- the RHS of unsafeCoerce as very small; see
- Note [Inline unsafeCoerce] in that module.
+(U4) We regard `case unsafeEqualityProof of UnsafeRefl -> rhs` as trivial iff
+ `rhs` is. One reason is that we want to treat the RHS of unsafeCoerce as
+ very small; see Note [Inline unsafeCoerce] in that module.
+ Another is that we do not want to allocate a thunk in CorePrep when we
+ wouldn't do so for `rhs`, because we discard the case in CoreToStg anyway.
(U5) The definition of unsafeEqualityProof in Unsafe.Coerce
looks very strange:
=====================================
testsuite/tests/simplCore/should_compile/T23083.hs
=====================================
@@ -0,0 +1,10 @@
+module T23083 where
+
+-- Just ($), but NOINLINE so that we don't inline it eagerly, subverting the
+-- test case
+($$) :: (a -> b) -> a -> b
+($$) f x = f x
+{-# NOINLINE ($$) #-}
+
+g :: ((Integer -> Integer) -> Integer) -> (Integer -> Integer) -> Integer
+g f h = f (h `seq` (h $$))
=====================================
testsuite/tests/simplCore/should_compile/T23083.stderr
=====================================
@@ -0,0 +1,47 @@
+
+==================== CorePrep ====================
+Result size of CorePrep = {terms: 34, types: 34, coercions: 0, joins: 0/1}
+
+-- RHS size: {terms: 6, types: 5, coercions: 0, joins: 0/0}
+(T23083.$$) [InlPrag=NOINLINE] :: forall a b. (a -> b) -> a -> b
+[GblId, Arity=2, Str=<1C(1,L)><L>, Unf=OtherCon []]
+(T23083.$$) = \ (@a) (@b) (f [Occ=Once1!] :: a -> b) (x [Occ=Once1] :: a) -> f x
+
+-- RHS size: {terms: 12, types: 12, 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 -> T23083.$$ @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/17b0d150ceb7b22bc28593fea40fa8188ecc2138...cd7b0b2a9519eae24c2973d28dacc108e5a17968
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/17b0d150ceb7b22bc28593fea40fa8188ecc2138...cd7b0b2a9519eae24c2973d28dacc108e5a17968
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/20230428/31caabbb/attachment-0001.html>
More information about the ghc-commits
mailing list