diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2021-07-23 23:57:01 +0100 |
|---|---|---|
| committer | Simon Peyton Jones <simon.peytonjones@gmail.com> | 2022-01-04 15:10:58 +0000 |
| commit | 3335c5cf7acf923b91dda9931907a5c9f4c1dade (patch) | |
| tree | a894c119f832a743febef427d73dbf69afeb481f | |
| parent | 54cba9f6b2e381e46c9f277fe81f34e22cf54c68 (diff) | |
| download | haskell-3335c5cf7acf923b91dda9931907a5c9f4c1dade.tar.gz | |
A bunch of changes related to eta reduction
This is a large collection of changes all relating to eta
reduction, originally triggered by #18993, but there followed
a long saga.
Specifics:
* Move state-hack stuff from GHC.Types.Id (where it never belonged)
to GHC.Core.Opt.Arity (which seems much more appropriate).
* Add a crucial mkCast in the Cast case of
GHC.Core.Opt.Arity.eta_expand; helps with T18223
* Add clarifying notes about eta-reducing to PAPs.
See Note [Do not eta reduce PAPs]
* I moved tryEtaReduce from GHC.Core.Utils to GHC.Core.Opt.Arity,
where it properly belongs. See Note [Eta reduce PAPs]
* In GHC.Core.Opt.Simplify.Utils.tryEtaExpandRhs, pull out the code for
when eta-expansion is wanted, to make wantEtaExpansion, and all that
same function in GHC.Core.Opt.Simplify.simplStableUnfolding. It was
previously inconsistent, but it's doing the same thing.
* I did a substantial refactor of ArityType; see Note [ArityType].
This allowed me to do away with the somewhat mysterious takeOneShots;
more generally it allows arityType to describe the function, leaving
its clients to decide how to use that information.
I made ArityType abstract, so that clients have to use functions
to access it.
* Make GHC.Core.Opt.Simplify.Utils.rebuildLam (was stupidly called
mkLam before) aware of the floats that the simplifier builds up, so
that it can still do eta-reduction even if there are some floats.
(Previously that would not happen.) That means passing the floats
to rebuildLam, and an extra check when eta-reducting (etaFloatOk).
* In GHC.Core.Opt.Simplify.Utils.tryEtaExpandRhs, make use of call-info
in the idDemandInfo of the binder, as well as the CallArity info. The
occurrence analyser did this but we were failing to take advantage here.
In the end I moved the heavy lifting to GHC.Core.Opt.Arity.findRhsArity;
see Note [Combining arityType with demand info], and functions
idDemandOneShots and combineWithDemandOneShots.
(These changes partly drove my refactoring of ArityType.)
* In GHC.Core.Opt.Arity.findRhsArity
* I'm now taking account of the demand on the binder to give
extra one-shot info. E.g. if the fn is always called with two
args, we can give better one-shot info on the binders
than if we just look at the RHS.
* Don't do any fixpointing in the non-recursive
case -- simple short cut.
* Trim arity inside the loop. See Note [Trim arity inside the loop]
* Make SimpleOpt respect the eta-reduction flag
(Some associated refactoring here.)
* I made the CallCtxt which the Simplifier uses distinguish between
recursive and non-recursive right-hand sides.
data CallCtxt = ... | RhsCtxt RecFlag | ...
It affects two things:
- We call an RHS context interesting only if it is non-recursive
see Note [RHS of lets] in GHC.Core.Unfold
- We only eta-reduce non-recursive RHS, rather than eta-reducing
every lambda. I'm not sure about the "non-recursive" bit; ToDo.
* Remove eta-reduction in GHC.CoreToStg.Prep, a welcome simplification.
See Note [No eta reduction needed in rhsToBody] in GHC.CoreToStg.Prep.
Other incidental changes
* Fix a fairly long-standing outright bug in the ApplyToVal case of
GHC.Core.Opt.Simplify.mkDupableContWithDmds. I was failing to take the
tail of 'dmds' in the recursive call, which meant the demands were All
Wrong. I have no idea why this has not caused problems before now.
* Delete dead function GHC.Core.Opt.Simplify.Utils.contIsRhsOrArg
33 files changed, 1811 insertions, 835 deletions
diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs index 87dc9e0656..c95379cc4d 100644 --- a/compiler/GHC/Core/Opt/Arity.hs +++ b/compiler/GHC/Core/Opt/Arity.hs @@ -11,15 +11,29 @@ -- | Arity and eta expansion module GHC.Core.Opt.Arity - ( manifestArity, joinRhsArity, exprArity - , typeArity, typeOneShots - , exprEtaExpandArity, findRhsArity - , etaExpand, etaExpandAT - , exprBotStrictness_maybe + ( -- Finding arity + manifestArity, joinRhsArity, exprArity + , findRhsArity, exprBotStrictness_maybe + + -- ** Eta expansion + , exprEtaExpandArity, etaExpand, etaExpandAT + + -- ** Eta reduction + , tryEtaReduce -- ** ArityType - , ArityType(..), mkBotArityType, mkTopArityType, expandableArityType - , arityTypeArity, maxWithArity, minWithArity, idArityType + , ArityType, mkBotArityType, mkManifestArityType + , expandableArityType + , arityTypeArity, arityTypeArityDiv, idArityType + + -- ** typeArity and the state hack + , typeArity, typeOneShots, typeOneShot + , isOneShotBndr, isProbablyOneShotLambda + , isStateHackType + + -- * Lambdas + , zapLamBndrs + -- ** Join points , etaExpandToJoinPoint, etaExpandToJoinPointRule @@ -40,7 +54,7 @@ import GHC.Core.Utils import GHC.Core.DataCon import GHC.Core.TyCon ( tyConArity ) import GHC.Core.TyCon.RecWalk ( initRecTc, checkRecTc ) -import GHC.Core.Predicate ( isDictTy, isCallStackPredTy ) +import GHC.Core.Predicate ( isDictTy, isEvVar, isCallStackPredTy ) import GHC.Core.Multiplicity -- We have two sorts of substitution: @@ -51,17 +65,19 @@ import GHC.Core.Type as Type import GHC.Core.Coercion as Type import GHC.Types.Demand -import GHC.Types.Var -import GHC.Types.Var.Env import GHC.Types.Id +import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Basic import GHC.Types.Tickish +import GHC.Builtin.Types.Prim import GHC.Builtin.Uniques + import GHC.Data.FastString import GHC.Data.Pair +import GHC.Utils.GlobalVars( unsafeHasNoStateHack ) import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Outputable import GHC.Utils.Panic @@ -140,6 +156,41 @@ exprArity e = go e go _ = 0 --------------- +exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, DmdSig) +-- A cheap and cheerful function that identifies bottoming functions +-- and gives them a suitable strictness signatures. It's used during +-- float-out +exprBotStrictness_maybe e + = case getBotArity (arityType botStrictnessArityEnv e) of + Nothing -> Nothing + Just ar -> Just (ar, sig ar) + where + sig ar = mkClosedDmdSig (replicate ar topDmd) botDiv + + +{- Note [exprArity for applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we come to an application we check that the arg is trivial. + eg f (fac x) does not have arity 2, + even if f has arity 3! + +* We require that is trivial rather merely cheap. Suppose f has arity 2. + Then f (Just y) + has arity 0, because if we gave it arity 1 and then inlined f we'd get + let v = Just y in \w. <f-body> + which has arity 0. And we try to maintain the invariant that we don't + have arity decreases. + +* The `max 0` is important! (\x y -> f x) has arity 2, even if f is + unknown, hence arity 0 + + +************************************************************************ +* * + typeArity and the "state hack" +* * +********************************************************************* -} + typeArity :: Type -> Arity typeArity = length . typeOneShots @@ -175,21 +226,68 @@ typeOneShots ty | otherwise = [] ---------------- -exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, DmdSig) --- A cheap and cheerful function that identifies bottoming functions --- and gives them a suitable strictness signatures. It's used during --- float-out -exprBotStrictness_maybe e - = case getBotArity (arityType botStrictnessArityEnv e) of - Nothing -> Nothing - Just ar -> Just (ar, sig ar) - where - sig ar = mkClosedDmdSig (replicate ar topDmd) botDiv +typeOneShot :: Type -> OneShotInfo +typeOneShot ty + | isStateHackType ty = OneShotLam + | otherwise = NoOneShotInfo + +-- | Like 'idOneShotInfo', but taking the Horrible State Hack in to account +-- See Note [The state-transformer hack] in "GHC.Core.Opt.Arity" +idStateHackOneShotInfo :: Id -> OneShotInfo +idStateHackOneShotInfo id + | isStateHackType (idType id) = OneShotLam + | otherwise = idOneShotInfo id + +-- | Returns whether the lambda associated with the 'Id' is certainly applied at most once +-- This one is the "business end", called externally. +-- It works on type variables as well as Ids, returning True +-- Its main purpose is to encapsulate the Horrible State Hack +-- See Note [The state-transformer hack] in "GHC.Core.Opt.Arity" +isOneShotBndr :: Var -> Bool +isOneShotBndr var + | isTyVar var = True + | OneShotLam <- idStateHackOneShotInfo var = True + | otherwise = False + +isStateHackType :: Type -> Bool +isStateHackType ty + | unsafeHasNoStateHack -- Switch off with -fno-state-hack + = False + | otherwise + = case tyConAppTyCon_maybe ty of + Just tycon -> tycon == statePrimTyCon + _ -> False + -- This is a gross hack. It claims that + -- every function over realWorldStatePrimTy is a one-shot + -- function. This is pretty true in practice, and makes a big + -- difference. For example, consider + -- a `thenST` \ r -> ...E... + -- The early full laziness pass, if it doesn't know that r is one-shot + -- will pull out E (let's say it doesn't mention r) to give + -- let lvl = E in a `thenST` \ r -> ...lvl... + -- When `thenST` gets inlined, we end up with + -- let lvl = E in \s -> case a s of (r, s') -> ...lvl... + -- and we don't re-inline E. + -- + -- It would be better to spot that r was one-shot to start with, but + -- I don't want to rely on that. + -- + -- Another good example is in fill_in in PrelPack.hs. We should be able to + -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet. + +isProbablyOneShotLambda :: Id -> Bool +isProbablyOneShotLambda id = case idStateHackOneShotInfo id of + OneShotLam -> True + NoOneShotInfo -> False + + +{- Note [typeArity invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(typeArity ty) says how many arrows GHC can expose in 'ty', after +looking through newtypes. More generally, (typeOneShots ty) returns +ty's [OneShotInfo], based only on the type itself, using typeOneShot +on the argument type to access the "state hack". -{- -Note [typeArity invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~ We have the following invariants around typeArity (1) In any binding x = e, @@ -215,12 +313,13 @@ Suppose we have f x y = x+y -- Arity 2 g :: F Int - g = case x of { True -> f |> co1 - ; False -> g |> co2 } + g = case <cond> of { True -> f |> co1 + ; False -> g |> co2 } -Now, we can't eta-expand g to have arity 2, because etaExpand, which works -off the /type/ of the expression, doesn't know how to make an eta-expanded -binding +where F is a type family. Now, we can't eta-expand g to have arity 2, +because etaExpand, which works off the /type/ of the expression +(albeit looking through newtypes), doesn't know how to make an +eta-expanded binding g = (\a b. case x of ...) |> co because can't make up `co` or the types of `a` and `b`. @@ -230,7 +329,7 @@ and handle what typeArity says. Note [Arity trimming] ~~~~~~~~~~~~~~~~~~~~~ -Arity trimming, implemented by minWithArity, directly implements +Arity trimming, implemented by trimArityType, directly implements invariant (1) of Note [typeArity invariants]. Failing to do so, and hence breaking invariant (1) led to #5441. @@ -294,26 +393,34 @@ trying to *make* it hold, but it's tricky and I gave up. The test simplCore/should_compile/T3722 is an excellent example. -------- End of old out of date comments, just for interest ----------- +-} +{- ******************************************************************** +* * + Zapping lambda binders +* * +********************************************************************* -} -Note [exprArity for applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we come to an application we check that the arg is trivial. - eg f (fac x) does not have arity 2, - even if f has arity 3! - -* We require that is trivial rather merely cheap. Suppose f has arity 2. - Then f (Just y) - has arity 0, because if we gave it arity 1 and then inlined f we'd get - let v = Just y in \w. <f-body> - which has arity 0. And we try to maintain the invariant that we don't - have arity decreases. +zapLamBndrs :: FullArgCount -> [Var] -> [Var] +-- If (\xyz. t) appears under-applied to only two arguments, +-- we must zap the occ-info on x,y, because they appear under the \x +-- See Note [Occurrence analysis for lambda binders] in GHc.Core.Opt.OccurAnal +-- +-- NB: both `arg_count` and `bndrs` include both type and value args/bndrs +zapLamBndrs arg_count bndrs + | no_need_to_zap = bndrs + | otherwise = zap_em arg_count bndrs + where + no_need_to_zap = all isOneShotBndr (drop arg_count bndrs) -* The `max 0` is important! (\x y -> f x) has arity 2, even if f is - unknown, hence arity 0 + zap_em :: FullArgCount -> [Var] -> [Var] + zap_em 0 bs = bs + zap_em _ [] = [] + zap_em n (b:bs) | isTyVar b = b : zap_em (n-1) bs + | otherwise = zapLamIdInfo b : zap_em (n-1) bs -************************************************************************ +{- ********************************************************************* * * Computing the "arity" of an expression * * @@ -488,19 +595,60 @@ but not to introduce a new lambda. Note [ArityType] ~~~~~~~~~~~~~~~~ +ArityType can be thought of as an abstraction of an expression. +The ArityType + AT [ (IsCheap, NoOneShotInfo) + , (IsExpensive, OneShotLam) + , (IsCheap, OneShotLam) ] Dunno) + +abstracts an expression like + \x. let <expensive> in + \y{os}. + \z{os}. blah + +In general we have (AT prs div). Then +* In prs :: [(Cost,OneShotInfo)] + * The Cost flag describes the part of the expression down + to the first (value) lambda. + * The OneShotInfo flag gives the one-shot info on that lambda. + +* If 'div' is dead-ending ('isDeadEndDiv'), then application to + 'length prs' arguments will surely diverge, similar to the situation + with 'DmdType'. + ArityType is the result of a compositional analysis on expressions, from which we can decide the real arity of the expression (extracted with function exprEtaExpandArity). We use the following notation: - at ::= \o1..on.div + at ::= \p1..pn.div div ::= T | x | ⊥ - o ::= ? | 1 + p ::= (c o) + c ::= X | C -- Expensive or Cheap + o ::= ? | 1 -- NotOneShot or OneShotLam + And omit the \. if n = 0. Examples: - \?11.T stands for @AT [NoOneShotInfo,OneShotLam,OneShotLam] topDiv@ - ⊥ stands for @AT [] botDiv@ + \(C?)(X1)(C1).T +stands for + @AT [(IsCheap,NoOneShotInfo),(IsExpensive,OneShotLam),(IsCheap,OneShotLam)] topDiv@ + +And ⊥ stands for @AT [] botDiv@ See the 'Outputable' instance for more information. It's pretty simple. +Example: + f = \x\y. let v = <expensive> in + \s(one-shot) \t(one-shot). blah + 'f' has arity type \(C?)(C?)(X1)(C1).T + The one-shot-ness means we can, in effect, push that + 'let' inside the \st, and expand to arity 4 + + +Suppose f = \xy. x+y +Then f :: \(C?)(C?).T + f v :: \(C?).T + f <expensive> :: \(X?).T + + Here is what the fields mean. If an arbitrary expression 'f' has ArityType 'at', then @@ -513,9 +661,9 @@ ArityType 'at', then let x = <expensive> in \y. error (g x y) ==> \y. let x = <expensive> in error (g x y) - * If @at = AT [o1,..,on] topDiv@ (notation: \o1..on.T), then expanding 'f' - to @\x1..xn. f x1..xn@ loses no sharing, assuming the calls of f respect - the one-shot-ness o1..on of its definition. + * If `f` has ArityType `at` we can eta-expand `f` by (aritTypeOneShots at) + arguments without losing sharing. This function checks that the either + there are no expensive expressions, or the lambdas are one-shots. NB 'f' is an arbitrary expression, eg @f = g e1 e2@. This 'f' can have arity type @AT oss _@, with @length oss > 0@, only if e1 e2 are themselves @@ -528,18 +676,6 @@ ArityType 'at', then So eta expansion is dynamically ok; see Note [State hack and bottoming functions], the part about catch# -Example: - f = \x\y. let v = <expensive> in - \s(one-shot) \t(one-shot). blah - 'f' has arity type \??11.T - The one-shot-ness means we can, in effect, push that - 'let' inside the \st. - - -Suppose f = \xy. x+y -Then f :: \??.T - f v :: \?.T - f <expensive> :: T -} @@ -572,8 +708,8 @@ Then f :: \??.T -- -- We rely on this lattice structure for fixed-point iteration in -- 'findRhsArity'. For the semantics of 'ArityType', see Note [ArityType]. -data ArityType - = AT ![OneShotInfo] !Divergence +data ArityType -- See Note [ArityType] + = AT ![(Cost,OneShotInfo)] !Divergence -- ^ @AT oss div@ means this value can safely be eta-expanded @length oss@ -- times, provided use sites respect the 'OneShotInfo's in @oss@. -- A 'OneShotLam' annotation can come from two sources: @@ -588,6 +724,16 @@ data ArityType -- with 'DmdType'. deriving Eq +data Cost = IsCheap | IsExpensive + deriving( Eq ) + +allCosts :: (a -> Cost) -> [a] -> Cost +allCosts f xs = foldr (addCost . f) IsCheap xs + +addCost :: Cost -> Cost -> Cost +addCost IsCheap IsCheap = IsCheap +addCost _ _ = IsExpensive + -- | This is the BNF of the generated output: -- -- @ @@ -606,58 +752,61 @@ instance Outputable ArityType where pp_div Diverges = char '⊥' pp_div ExnOrDiv = char 'x' pp_div Dunno = char 'T' - pp_os OneShotLam = char '1' - pp_os NoOneShotInfo = char '?' + pp_os (IsCheap, OneShotLam) = text "(C1)" + pp_os (IsExpensive, OneShotLam) = text "(X1)" + pp_os (IsCheap, NoOneShotInfo) = text "(C?)" + pp_os (IsExpensive, NoOneShotInfo) = text "(X?)" mkBotArityType :: [OneShotInfo] -> ArityType -mkBotArityType oss = AT oss botDiv +mkBotArityType oss = AT [(IsCheap,os) | os <- oss] botDiv botArityType :: ArityType botArityType = mkBotArityType [] -mkTopArityType :: [OneShotInfo] -> ArityType -mkTopArityType oss = AT oss topDiv +mkManifestArityType :: [OneShotInfo] -> ArityType +mkManifestArityType oss = AT [(IsCheap,os) | os <- oss] topDiv topArityType :: ArityType -topArityType = mkTopArityType [] +topArityType = AT [] topDiv -- | The number of value args for the arity type arityTypeArity :: ArityType -> Arity -arityTypeArity (AT oss _) = length oss +arityTypeArity at = length (arityTypeOneShots at) + +arityTypeArityDiv :: ArityType -> (Arity, Divergence) +arityTypeArityDiv at@(AT oss div) + = (length oss', div') + where + oss' = arityTypeOneShots at + div' | oss `equalLength` oss' = div + | otherwise = topDiv + +arityTypeOneShots :: ArityType -> [OneShotInfo] +-- Returns a list only as long as the arity should be +arityTypeOneShots (AT prs _) + = go IsCheap prs + where + go :: Cost -> [(Cost,OneShotInfo)] -> [OneShotInfo] + go _ [] = [] + go ch1 ((ch2,os):prs) + = case (ch1 `addCost` ch2, os) of + (IsExpensive, NoOneShotInfo) -> [] + (ch, _) -> os : go ch prs -- | True <=> eta-expansion will add at least one lambda expandableArityType :: ArityType -> Bool -expandableArityType at = arityTypeArity at > 0 - --- | See Note [Dead ends] in "GHC.Types.Demand". --- Bottom implies a dead end. -isDeadEndArityType :: ArityType -> Bool -isDeadEndArityType (AT _ div) = isDeadEndDiv div - ------------------------ -infixl 2 `maxWithArity`, `minWithArity` +expandableArityType at = not (null (arityTypeOneShots at)) --- | Expand a non-bottoming arity type so that it has at least the given arity. -maxWithArity :: ArityType -> Arity -> ArityType -maxWithArity at@(AT oss div) !ar - | isDeadEndArityType at = at - | oss `lengthAtLeast` ar = at - | otherwise = AT (take ar $ oss ++ repeat NoOneShotInfo) div +infixl 2 `trimArityType` -- | Trim an arity type so that it has at most the given arity. -- Any excess 'OneShotInfo's are truncated to 'topDiv', even if they end in -- 'ABot'. See Note [Arity trimming] -minWithArity :: ArityType -> Arity -> ArityType -minWithArity at@(AT oss _) ar +trimArityType :: ArityType -> Arity -> ArityType +trimArityType at@(AT oss _) ar | oss `lengthAtMost` ar = at | otherwise = AT (take ar oss) topDiv ----------------------- -takeWhileOneShot :: ArityType -> ArityType -takeWhileOneShot (AT oss div) - | isDeadEndDiv div = AT (takeWhile isOneShotInfo oss) topDiv - | otherwise = AT (takeWhile isOneShotInfo oss) div - -- | The Arity returned is the number of value args the -- expression can be applied to without doing much work exprEtaExpandArity :: DynFlags -> CoreExpr -> ArityType @@ -672,7 +821,13 @@ getBotArity (AT oss div) | isDeadEndDiv div = Just $ length oss | otherwise = Nothing ----------------------- + +{- ********************************************************************* +* * + findRhsArity +* * +********************************************************************* -} + findRhsArity :: DynFlags -> RecFlag -> Id -> CoreExpr -> Arity -> ArityType -- This implements the fixpoint loop for arity analysis -- See Note [Arity analysis] @@ -680,17 +835,37 @@ findRhsArity :: DynFlags -> RecFlag -> Id -> CoreExpr -> Arity -> ArityType -- (a) any application of e to <n arguments will not do much work, -- so it is safe to expand e ==> (\x1..xn. e x1 .. xn) -- (b) if is_bot=True, then e applied to n args is guaranteed bottom - -findRhsArity dflags NonRecursive _ rhs _ - = arityType (findRhsArityEnv dflags) rhs - -findRhsArity dflags Recursive bndr rhs old_arity - = go 0 botArityType - -- We always do one step, but usually that produces a result equal to - -- old_arity, and then we stop right away, because old_arity is assumed - -- to be sound. In other words, arities should never decrease. - -- Result: the common case is that there is just one iteration +-- +-- Returns an ArityType that is guaranteed trimmed to typeArity of 'bndr' +-- See Note [Arity trimming] +-- +findRhsArity dflags is_rec bndr rhs old_arity + = case is_rec of + Recursive -> go 0 botArityType + NonRecursive -> step init_env where + init_env :: ArityEnv + init_env = findRhsArityEnv dflags + + ty_arity = typeArity (idType bndr) + id_one_shots = idDemandOneShots bndr + + step :: ArityEnv -> ArityType + step env = arityType env rhs + `combineWithDemandOneShots` id_one_shots + `trimArityType` ty_arity + -- See Note [Trim arity inside the loop] + -- combineWithDemandOneShots: take account of the demand on the + -- binder. Perhaps it is always called with 2 args + -- let f = \x. blah in (f 3 4, f 1 9) + -- f's demand-info says how many args it is called with + + -- The fixpoint iteration (go), done for recursive bindings. We + -- always do one step, but usually that produces a result equal + -- to old_arity, and then we stop right away, because old_arity + -- is assumed to be sound. In other words, arities should never + -- decrease. Result: the common case is that there is just one + -- iteration go :: Int -> ArityType -> ArityType go !n cur_at@(AT oss div) | not (isDeadEndDiv div) -- the "stop right away" case @@ -703,20 +878,46 @@ findRhsArity dflags Recursive bndr rhs old_arity ( ppr bndr <+> ppr cur_at <+> ppr next_at $$ ppr rhs)) $ go (n+1) next_at where - next_at = step cur_at - - step :: ArityType -> ArityType - step at = -- pprTrace "step" (vcat [ ppr bndr <+> ppr at <+> ppr (arityType env rhs) - -- , ppr (idType bndr) - -- , ppr (typeArity (idType bndr)) ]) $ - arityType env rhs - where - env = extendSigEnv (findRhsArityEnv dflags) bndr at + next_at = step (extendSigEnv init_env bndr cur_at) +infixl 2 `combineWithDemandOneShots` -{- -Note [Arity analysis] -~~~~~~~~~~~~~~~~~~~~~ +combineWithDemandOneShots :: ArityType -> [OneShotInfo] -> ArityType +-- See Note [Combining arity type with demand info] +combineWithDemandOneShots (AT prs div) oss + = AT (zip_prs prs oss) div + where + zip_prs prs [] = prs + zip_prs [] oss = [(IsExpensive,os) | os <- oss] + zip_prs ((ch,os1):prs) (os2:oss) + = (ch, os1 `bestOneShot` os2) : zip_prs prs oss + +idDemandOneShots :: Id -> [OneShotInfo] +idDemandOneShots bndr + = call_arity_one_shots `zip_oss` dmd_one_shots + where + call_arity_one_shots :: [OneShotInfo] + call_arity_one_shots + | call_arity == 0 = [] + | otherwise = NoOneShotInfo : replicate (call_arity-1) OneShotLam + -- Call Arity analysis says the function is always called + -- applied to this many arguments. The first NoOneShotInfo is because + -- if Call Arity says "always applied to 3 args" then the one-shot info + -- we get is [NoOneShotInfo, OneShotLam, OneShotLam] + call_arity = idCallArity bndr + + dmd_one_shots :: [OneShotInfo] + -- If the demand info is Cx(C1(C1(.))) then we know that an + -- application to one arg is also an application to three + dmd_one_shots = argOneShots (idDemandInfo bndr) + + -- Take the *longer* list + zip_oss (os1:oss1) (os2:oss2) = (os1 `bestOneShot` os2) : zip_oss oss1 oss2 + zip_oss [] oss2 = oss2 + zip_oss oss1 [] = oss1 + +{- Note [Arity analysis] +~~~~~~~~~~~~~~~~~~~~~~~~ The motivating example for arity analysis is this: f = \x. let g = f (x+1) @@ -778,57 +979,95 @@ to floatIn the non-cheap let-binding. Which is all perfectly benign, but means we do two iterations (well, actually 3 'step's to detect we are stable) and don't want to emit the warning. -Note [Eta expanding through dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the experimental -fdicts-cheap flag is on, we eta-expand through -dictionary bindings. This improves arities. Thereby, it also -means that full laziness is less prone to floating out the -application of a function to its dictionary arguments, which -can thereby lose opportunities for fusion. Example: - foo :: Ord a => a -> ... - foo = /\a \(d:Ord a). let d' = ...d... in \(x:a). .... - -- So foo has arity 1 +Note [Trim arity inside the loop] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here's an example (from gadt/nbe.hs) which caused trouble. + data Exp g t where + Lam :: Ty a -> Exp (g,a) b -> Exp g (a->b) - f = \x. foo dInt $ bar x + eval :: Exp g t -> g -> t + eval (Lam _ e) g = \a -> eval e (g,a) -The (foo DInt) is floated out, and makes ineffective a RULE - foo (bar x) = ... +The danger is that we get arity 3 from analysing this; and the +next time arity 4, and so on for ever. Solution: use trimArityType +on each iteration. -One could go further and make exprIsCheap reply True to any -dictionary-typed expression, but that's more work. +Note [Combining arity type with demand info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + let f = \x. let y = <expensive> in \p \q{os}. blah + in ...(f a b)...(f c d)... + +* From the RHS we get an ArityType like + AT [ (True,?), (False,?), (True,OneShotLam) ] Dunno + where "?" means NoOneShotInfo + +* From the body, the demand analyser, or Call Arity, will tell us + that the function is always applied to at least two arguments. + +Combining these two pieces of info, we can get the final ArityType + AT [ (True,?), (False,OneShotLam), (True,OneShotLam) ] Dunno +result: arity=3, which is better than we could do from either +source alone. + +The "combining" part is done by combineWithDemandOneShots. It +uses info from both Call Arity and demand analysis. -} + +{- ********************************************************************* +* * + arityType +* * +********************************************************************* -} + arityLam :: Id -> ArityType -> ArityType -arityLam id (AT oss div) = AT (idStateHackOneShotInfo id : oss) div +arityLam id (AT oss div) + = AT ((IsCheap, idStateHackOneShotInfo id) : oss) div -floatIn :: Bool -> ArityType -> ArityType +floatIn :: Cost -> ArityType -> ArityType -- We have something like (let x = E in b), -- where b has the given arity type. -floatIn cheap at - | isDeadEndArityType at || cheap = at - -- If E is not cheap, keep arity only for one-shots - | otherwise = takeWhileOneShot at +floatIn IsCheap at = at +floatIn IsExpensive at = addWork at + +addWork :: ArityType -> ArityType +addWork at@(AT prs div) + = case prs of + [] -> at + pr:prs' -> AT (add_work pr : prs') div + where + add_work (_,os) = (IsExpensive,os) -arityApp :: ArityType -> Bool -> ArityType +arityApp :: ArityType -> Cost -> ArityType -- Processing (fun arg) where at is the ArityType of fun, -- Knock off an argument and behave like 'let' -arityApp (AT (_:oss) div) cheap = floatIn cheap (AT oss div) -arityApp at _ = at +arityApp (AT ((ch1,_):oss) div) ch2 = floatIn (ch1 `addCost` ch2) (AT oss div) +arityApp at _ = at -- | Least upper bound in the 'ArityType' lattice. -- See the haddocks on 'ArityType' for the lattice. -- -- Used for branches of a @case@. andArityType :: ArityType -> ArityType -> ArityType -andArityType (AT (os1:oss1) div1) (AT (os2:oss2) div2) - | AT oss' div' <- andArityType (AT oss1 div1) (AT oss2 div2) - = AT ((os1 `bestOneShot` os2) : oss') div' -- See Note [Combining case branches] -andArityType (AT [] div1) at2 - | isDeadEndDiv div1 = at2 -- Note [ABot branches: max arity wins] - | otherwise = takeWhileOneShot at2 -- See Note [Combining case branches] -andArityType at1 (AT [] div2) - | isDeadEndDiv div2 = at1 -- Note [ABot branches: max arity wins] - | otherwise = takeWhileOneShot at1 -- See Note [Combining case branches] +andArityType (AT (pr1:prs1) div1) (AT (pr2:prs2) div2) + | AT prs' div' <- andArityType (AT prs1 div1) (AT prs2 div2) + = AT ((pr1 `and_pr` pr2) : prs') div' -- See Note [Combining case branches] + where + (ch1,os1) `and_pr` (ch2,os2) + = ( ch1 `addCost` ch2, os1 `bestOneShot` os2) + +andArityType (AT [] div1) at2 = andWithTail div1 at2 +andArityType at1 (AT [] div2) = andWithTail div2 at1 + +andWithTail :: Divergence -> ArityType -> ArityType +andWithTail div1 at2@(AT oss2 _) + | isDeadEndDiv div1 -- case x of { T -> error; F -> \y.e } + = at2 + | otherwise -- case x of { T -> plusInt <expensive>; F -> \y.e } + = addWork (AT oss2 topDiv) -- We know div1 = topDiv + -- Note [ABot branches: max arity wins] + -- See Note [Combining case branches] {- Note [ABot branches: max arity wins] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -860,29 +1099,6 @@ basis that if we know one branch is one-shot, then they all must be. Surprisingly, this means that the one-shot arity type is effectively the top element of the lattice. -Note [Arity trimming] -~~~~~~~~~~~~~~~~~~~~~ -Consider ((\x y. blah) |> co), where co :: (Int->Int->Int) ~ (Int -> F a) , and -F is some type family. - -Because of Note [exprArity invariant], item (2), we must return with arity at -most 1, because typeArity (Int -> F a) = 1. So we have to trim the result of -calling arityType on (\x y. blah). Failing to do so, and hence breaking the -exprArity invariant, led to #5441. - -How to trim? If we end in topDiv, it's easy. But we must take great care with -dead ends (i.e. botDiv). Suppose the expression was (\x y. error "urk"), -we'll get \??.⊥. We absolutely must not trim that to \?.⊥, because that -claims that ((\x y. error "urk") |> co) diverges when given one argument, -which it absolutely does not. And Bad Things happen if we think something -returns bottom when it doesn't (#16066). - -So, if we need to trim a dead-ending arity type, switch (conservatively) to -topDiv. - -Historical note: long ago, we unconditionally switched to topDiv when we -encountered a cast, but that is far too conservative: see #5475 - Note [Eta expanding through CallStacks] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Just as it's good to eta-expand through dictionaries, so it is good to @@ -893,6 +1109,25 @@ do so through CallStacks. #20103 is a case in point, where we got We really want to eta-expand this! #20103 is quite convincing! We do this regardless of -fdicts-cheap; it's not really a dictionary. + +Note [Eta expanding through dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the experimental -fdicts-cheap flag is on, we eta-expand through +dictionary bindings. This improves arities. Thereby, it also +means that full laziness is less prone to floating out the +application of a function to its dictionary arguments, which +can thereby lose opportunities for fusion. Example: + foo :: Ord a => a -> ... + foo = /\a \(d:Ord a). let d' = ...d... in \(x:a). .... + -- So foo has arity 1 + + f = \x. foo dInt $ bar x + +The (foo DInt) is floated out, and makes ineffective a RULE + foo (bar x) = ... + +One could go further and make exprIsCheap reply True to any +dictionary-typed expression, but that's more work. -} --------------------------- @@ -925,6 +1160,7 @@ data AnalysisMode -- ^ Used for regular, fixed-point arity analysis ('findRhsArity'). -- See Note [Arity analysis] for details about fixed-point iteration. -- INVARIANT: Disjoint with 'ae_joins'. + -- am_dicts_cheap: see Note [Eta expanding through dictionaries] data ArityEnv = AE @@ -1013,6 +1249,11 @@ pedanticBottoms AE{ ae_mode = mode } = case mode of EtaExpandArity{ am_ped_bot = ped_bot } -> ped_bot FindRhsArity{ am_ped_bot = ped_bot } -> ped_bot +exprCost :: ArityEnv -> CoreExpr -> Maybe Type -> Cost +exprCost env e mb_ty + | myExprIsCheap env e mb_ty = IsCheap + | otherwise = IsExpensive + -- | A version of 'exprIsCheap' that considers results from arity analysis -- and optionally the expression's type. -- Under 'exprBotStrictness_maybe', no expressions are cheap. @@ -1040,15 +1281,18 @@ myExprIsCheap AE{ae_mode = mode} e mb_ty = case mode of -- it's important. myIsCheapApp :: IdEnv ArityType -> CheapAppFun myIsCheapApp sigs fn n_val_args = case lookupVarEnv sigs fn of + -- Nothing means not a local function, fall back to regular -- 'GHC.Core.Utils.isCheapApp' - Nothing -> isCheapApp fn n_val_args + Nothing -> isCheapApp fn n_val_args + -- @Just at@ means local function with @at@ as current ArityType. -- Roughly approximate what 'isCheapApp' is doing. Just (AT oss div) | isDeadEndDiv div -> True -- See Note [isCheapApp: bottoming functions] in GHC.Core.Utils - | n_val_args < length oss -> True -- Essentially isWorkFreeApp - | otherwise -> False + | n_val_args == 0 -> True -- Essentially + | n_val_args < length oss -> True -- isWorkFreeApp + | otherwise -> False ---------------- arityType :: ArityEnv -> CoreExpr -> ArityType @@ -1075,7 +1319,10 @@ arityType env (Lam x e) arityType env (App fun (Type _)) = arityType env fun arityType env (App fun arg ) - = arityApp (arityType env fun) (myExprIsCheap env arg Nothing) + = arityApp fun_at arg_cost + where + fun_at = arityType env fun + arg_cost = exprCost env arg Nothing -- Case/Let; keep arity if either the expression is cheap -- or it's a 1-shot lambda @@ -1096,9 +1343,8 @@ arityType env (Case scrut bndr _ alts) | exprOkForSpeculation scrut = alts_type - | otherwise -- In the remaining cases we may not push - = takeWhileOneShot alts_type -- evaluation of the scrutinee in - + | otherwise -- In the remaining cases we may not push + = addWork alts_type -- evaluation of the scrutinee in where env' = delInScope env bndr arity_type_alt (Alt _con bndrs rhs) = arityType (delInScopeList env' bndrs) rhs @@ -1127,16 +1373,16 @@ arityType env (Let (Rec pairs) body) = pprPanic "arityType:joinrec" (ppr pairs) arityType env (Let (NonRec b r) e) - = floatIn cheap_rhs (arityType env' e) + = floatIn rhs_cost (arityType env' e) where - cheap_rhs = myExprIsCheap env r (Just (idType b)) - env' = extendSigEnv env b (arityType env r) + rhs_cost = exprCost env r (Just (idType b)) + env' = extendSigEnv env b (arityType env r) arityType env (Let (Rec prs) e) - = floatIn (all is_cheap prs) (arityType env' e) + = floatIn (allCosts bind_cost prs) (arityType env' e) where - env' = delInScopeList env (map fst prs) - is_cheap (b,e) = myExprIsCheap env' e (Just (idType b)) + env' = delInScopeList env (map fst prs) + bind_cost (b,e) = exprCost env' e (Just (idType b)) arityType env (Tick t e) | not (tickishIsCode t) = arityType env e @@ -1207,8 +1453,8 @@ idArityType v | otherwise = AT (take (idArity v) one_shots) topDiv where - one_shots :: [OneShotInfo] -- One-shot-ness derived from the type - one_shots = typeOneShots (idType v) + one_shots :: [(Cost,OneShotInfo)] -- One-shot-ness derived from the type + one_shots = repeat IsCheap `zip` typeOneShots (idType v) {- %************************************************************************ @@ -1317,7 +1563,7 @@ Consider We'll get an ArityType for foo of \?1.T. Then we want to eta-expand to - foo = (\x. \eta{os}. (case x of ...as before...) eta)) |> some_co + foo = (\x. \eta{os}. (case x of ...as before...) eta) |> some_co That 'eta' binder is fresh, and we really want it to have the one-shot flag from the inner \s{os}. By expanding with the @@ -1351,8 +1597,8 @@ etaExpandAT :: InScopeSet -> ArityType -> CoreExpr -> CoreExpr -- We pass in the InScopeSet from the simplifier to avoid recomputing -- it here, which can be jolly expensive if the casts are big -- In #18223 it took 10% of compile time just to do the exprFreeVars! -etaExpandAT in_scope (AT oss _) orig_expr - = eta_expand in_scope oss orig_expr +etaExpandAT in_scope at orig_expr + = eta_expand in_scope (arityTypeOneShots at) orig_expr -- etaExpand arity e = res -- Then 'res' has at least 'arity' lambdas at the top @@ -1367,7 +1613,11 @@ etaExpandAT in_scope (AT oss _) orig_expr eta_expand :: InScopeSet -> [OneShotInfo] -> CoreExpr -> CoreExpr eta_expand in_scope one_shots (Cast expr co) - = Cast (eta_expand in_scope one_shots expr) co + = mkCast (eta_expand in_scope one_shots expr) co + -- This mkCast is important, because eta_expand might return an + -- expression with a cast at the outside; and tryCastWorkerWrapper + -- asssumes that we don't have nested casts. Makes a difference + -- in compile-time for T18223 eta_expand in_scope one_shots orig_expr = go in_scope one_shots [] orig_expr @@ -1438,7 +1688,7 @@ casts complicate the question. If we have and e :: N (N Int) then the eta-expansion should look like - (\(x::S) (y::S) -> e |> co x y) |> sym co + (\(x::S) (y::S) -> (e |> co) x y) |> sym co where co :: N (N Int) ~ S -> S -> Int co = axN @(N Int) ; (S -> axN @Int) @@ -1674,6 +1924,279 @@ mkEtaWW orig_oss ppr_orig_expr in_scope orig_ty -- with an explicit lambda having a non-function type +{- +************************************************************************ +* * + Eta reduction +* * +************************************************************************ + +Note [Eta reduction conditions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given (\x. <fun> x), what condition on <stuff> allows us to eta-reduce? +This test is implemented by 'ok_fun' in tryEtaReduce. + +There are some particularly delicate points here: + +* Clearly <fun> must not mention x! + +* We want to eta-reduce if doing so leaves + a trivial expression, + *including* a cast. For example + \x. (f |> co) x --> f |> co + (provided co doesn't mention x) + + c.f. Note [Which RHSs do we eta-expand?] in GHC.Core.Opt.Simplify.Utils. + If we eta-reduce to 'e', we don't want to eta-expand 'e'! + +* Note that we only eta-reduce if the result is /trivial/, + not if it is a PAP. See Note [Do not eta reduce PAPs] + +* Eta reduction is not valid in general: + \x. bot /= bot + This matters, partly for old-fashioned correctness reasons but, + worse, getting it wrong can yield a seg fault. Consider + f = \x.f x + h y = case (case y of { True -> f `seq` True; False -> False }) of + True -> ...; False -> ... + + If we (unsoundly) eta-reduce f to get f=f, the strictness analyser + says f=bottom, and replaces the (f `seq` True) with just + (f `cast` unsafe-co). BUT, as thing stand, 'f' got arity 1, and it + *keeps* arity 1 (perhaps also wrongly). So CorePrep eta-expands + the definition again, so that it does not terminate after all. + Result: seg-fault because the boolean case actually gets a function value. + See #1947. + + So it's important to do the right thing. + +* With linear types, eta-reduction can break type-checking: + f :: A ⊸ B + g :: A -> B + g = \x. f x + + The above is correct, but eta-reducing g would yield g=f, the linter will + complain that g and f don't have the same type. + +* Note [Arity care]: we need to be careful if we just look at f's + arity. Currently (Dec07), f's arity is visible in its own RHS (see + Note [Arity robustness] in GHC.Core.Opt.Simplify.Env) so we must *not* trust the + arity when checking that 'f' is a value. Otherwise we will + eta-reduce + f = \x. f x + to + f = f + Which might change a terminating program (think (f `seq` e)) to a + non-terminating one. So we check for being a loop breaker first. + + However for GlobalIds we can look at the arity. + +* Type and dictionary abstraction. + Regardless of whether 'f' is a value, we always want to reduce + (/\a -> f a) --> f + This came up in a RULE: foldr (build (/\a -> g a)) + did not match foldr (build (/\b -> ...something complex...)) + The type checker can insert these eta-expanded versions, + with both type and dictionary lambdas; hence the slightly + ad-hoc (all ok_lam bndrs) + +* Never *reduce* arity. For example + f = \xy. g x y + Then if g has arity 1 we don't want to eta-reduce because then + f's arity would decrease, and that is bad + +These delicacies are why we don't use exprIsTrivial and exprIsHNF here. +Alas. + +Note [Do not eta reduce PAPs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +I considered eta-reducing if the result is a PAP: + \x. f e1 e2 x ==> f e1 e2 + +This reduces clutter, sometimes a lot. See Note [Do not eta-expand PAPs] +in GHC.Core.Opt.Simplify.Utils, where we are careful not to eta-expand +a PAP. If eta-expanding is bad, then eta-reducing is good! + +Also the code generator likes eta-reduced PAPs; see GHC.CoreToStg.Prep +Note [No eta reduction needed in rhsToBody]. + +But note that we don't want to eta-reduce + \x y. f <expensive> x y +to + f <expensive> +The former has arity 2, and repeats <expensive> for every call of the +function; the latter has arity 0, and shares <expensive>. We don't want +to change behaviour. Hence the call to exprIsCheap in ok_fun. + +I noticed this when examining #18993 and, although it is delicate, +eta-reducing to a PAP happens to fix the regression in #18993. + +HOWEVER, if we transform + \x. f y x ==> f y +that might mean that f isn't saturated any more, and does not inline. +This led to some other regressions. + +TL;DR currrently we do /not/ eta reduce if the result is a PAP. + +Note [Eta reduction with casted arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + (\(x:t3). f (x |> g)) :: t3 -> t2 + where + f :: t1 -> t2 + g :: t3 ~ t1 +This should be eta-reduced to + + f |> (sym g -> t2) + +So we need to accumulate a coercion, pushing it inward (past +variable arguments only) thus: + f (x |> co_arg) |> co --> (f |> (sym co_arg -> co)) x + f (x:t) |> co --> (f |> (t -> co)) x + f @ a |> co --> (f |> (forall a.co)) @ a + f @ (g:t1~t2) |> co --> (f |> (t1~t2 => co)) @ (g:t1~t2) +These are the equations for ok_arg. + +Note [Eta reduction with casted function] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Since we are pushing a coercion inwards, it is easy to accommodate + (\xy. (f x |> g) y) + (\xy. (f x y) |> g) + +See the `(Cast e co)` equation for `go` in `tryEtaReduce`. The +eta-expander pushes those casts outwards, so you might think we won't +ever see a cast here, but if we have + \xy. (f x y |> g) +we will call tryEtaReduce [x,y] (f x y |> g), and we'd like that to +work. This happens in GHC.Core.Opt.Simplify.Utils.rebuildLam, where +eta-expansion may be turned off (by sm_eta_expand). + +Note [Eta reduction of an eval'd function] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Haskell it is not true that f = \x. f x +because f might be bottom, and 'seq' can distinguish them. + +But it *is* true that f = f `seq` \x. f x +and we'd like to simplify the latter to the former. This amounts +to the rule that + * when there is just *one* value argument, + * f is not bottom +we can eta-reduce \x. f x ===> f + +This turned up in #7542. +-} + +tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr +-- Return an expression equal to (\bndrs. body) +tryEtaReduce bndrs body + = go (reverse bndrs) body refl_co + where + refl_co = mkRepReflCo (exprType body) + incoming_arity = count isId bndrs + + go :: [Var] -- Binders, innermost first, types [a3,a2,a1] + -> CoreExpr -- Of type tr + -> Coercion -- Of type tr ~ ts + -> Maybe CoreExpr -- Of type a1 -> a2 -> a3 -> ts + -- See Note [Eta reduction with casted arguments] + -- for why we have an accumulating coercion + -- + -- Invariant: (go bs body co) returns an expression + -- equivalent to (\(reverse bs). body |> co) + -- See Note [Eta reduction with casted function] + go bs (Cast e co1) co2 + = go bs e (co1 `mkTransCo` co2) + + go bs@(_ : _) (Tick t e) co + | tickishFloatable t + = fmap (Tick t) $ go bs e co + -- Float app ticks: \x -> Tick t (e x) ==> Tick t e + + go (b : bs) (App fun arg) co + | Just (co', ticks) <- ok_arg b arg co (exprType fun) + = fmap (flip (foldr mkTick) ticks) $ go bs fun co' + -- Float arg ticks: \x -> e (Tick t x) ==> Tick t e + + go remaining_bndrs fun co + | all isTyVar remaining_bndrs + -- We might have /\a \b. f [a] b, and we want to + -- eta-reduce to /\a. f [a] + -- See #20040 + , remaining_bndrs `ltLength` bndrs + -- Only reply Just if /something/ has happened + , all ok_lam bndrs || ok_fun fun + , let etad_expr = mkLams (reverse remaining_bndrs) (mkCast fun co) + used_vars = exprFreeVars etad_expr + , not (any (`elemVarSet` used_vars) bndrs) + = Just etad_expr + + go _ _ _ = Nothing -- Failure! + + --------------- + -- Note [Eta reduction conditions] + ok_fun (App fun (Type {})) = ok_fun fun + ok_fun (Cast fun _) = ok_fun fun + ok_fun (Tick _ expr) = ok_fun expr + ok_fun (Var fun_id) = ok_fun_id fun_id || all ok_lam bndrs + ok_fun _fun = False + + --------------- + ok_fun_id fun = -- There are arguments to reduce + fun_arity fun >= incoming_arity && + -- We always want args for join points so + -- we should never eta-reduce to a trivial expression. + -- See Note [Invariants on join points] in GHC.Core, and #20599 + not (isJoinId fun) + + --------------- + fun_arity fun -- See Note [Arity care] +-- | isLocalId fun +-- , isStrongLoopBreaker (idOccInfo fun) = 0 + | arity > 0 = arity + | isEvaldUnfolding (idUnfolding fun) = 1 + -- See Note [Eta reduction of an eval'd function] + | otherwise = 0 + where + arity = idArity fun + + --------------- + ok_lam v = isTyVar v || isEvVar v + -- See Note [Eta reduction conditions]: + -- bullet on Type and dictionary abstractions + + --------------- + ok_arg :: Var -- Of type bndr_t + -> CoreExpr -- Of type arg_t + -> Coercion -- Of kind (t1~t2) + -> Type -- Type (arg_t -> t1) of the function + -- to which the argument is supplied + -> Maybe (Coercion -- Of type (arg_t -> t1 ~ bndr_t -> t2) + -- (and similarly for tyvars, coercion args) + , [CoreTickish]) + -- See Note [Eta reduction with casted arguments] + ok_arg bndr (Type ty) co _ + | Just tv <- getTyVar_maybe ty + , bndr == tv = Just (mkHomoForAllCos [tv] co, []) + ok_arg bndr (Var v) co fun_ty + | bndr == v + , let mult = idMult bndr + , Just (fun_mult, _, _) <- splitFunTy_maybe fun_ty + , mult `eqType` fun_mult -- There is no change in multiplicity, otherwise we must abort + = Just (mkFunResCo Representational (idScaledType bndr) co, []) + ok_arg bndr (Cast e co_arg) co fun_ty + | (ticks, Var v) <- stripTicksTop tickishFloatable e + , Just (fun_mult, _, _) <- splitFunTy_maybe fun_ty + , bndr == v + , fun_mult `eqType` idMult bndr + = Just (mkFunCo Representational (multToCo fun_mult) (mkSymCo co_arg) co, ticks) + -- The simplifier combines multiple casts into one, + -- so we can have a simple-minded pattern match here + ok_arg bndr (Tick t arg) co fun_ty + | tickishFloatable t, Just (co', ticks) <- ok_arg bndr arg co fun_ty + = Just (co', t:ticks) + + ok_arg _ _ _ _ = Nothing + {- ********************************************************************* * * The "push rules" diff --git a/compiler/GHC/Core/Opt/CallArity.hs b/compiler/GHC/Core/Opt/CallArity.hs index f0847574c5..cadbdb975c 100644 --- a/compiler/GHC/Core/Opt/CallArity.hs +++ b/compiler/GHC/Core/Opt/CallArity.hs @@ -17,7 +17,7 @@ import GHC.Types.Var.Env import GHC.Types.Basic import GHC.Core import GHC.Types.Id -import GHC.Core.Opt.Arity ( typeArity, typeOneShots ) +import GHC.Core.Opt.Arity ( typeArity ) import GHC.Core.Utils ( exprIsCheap, exprIsTrivial ) import GHC.Data.Graph.UnVar import GHC.Types.Demand @@ -544,7 +544,7 @@ callArityAnal arity int (Let bind e) -- Which bindings should we look at? -- See Note [Which variables are interesting] isInteresting :: Var -> Bool -isInteresting v = not $ null $ typeOneShots $ idType v +isInteresting v = typeArity (idType v) > 0 interestingBinds :: CoreBind -> [Var] interestingBinds = filter isInteresting . bindersOf diff --git a/compiler/GHC/Core/Opt/FloatIn.hs b/compiler/GHC/Core/Opt/FloatIn.hs index 6e4b724310..922ee4953d 100644 --- a/compiler/GHC/Core/Opt/FloatIn.hs +++ b/compiler/GHC/Core/Opt/FloatIn.hs @@ -22,13 +22,14 @@ import GHC.Prelude import GHC.Platform import GHC.Core +import GHC.Core.Opt.Arity( isOneShotBndr ) import GHC.Core.Make hiding ( wrapFloats ) import GHC.Core.Utils import GHC.Core.FVs import GHC.Core.Type import GHC.Types.Basic ( RecFlag(..), isRec ) -import GHC.Types.Id ( isOneShotBndr, idType, isJoinId, isJoinId_maybe ) +import GHC.Types.Id ( idType, isJoinId, isJoinId_maybe ) import GHC.Types.Tickish import GHC.Types.Var import GHC.Types.Var.Set diff --git a/compiler/GHC/Core/Opt/OccurAnal.hs b/compiler/GHC/Core/Opt/OccurAnal.hs index 1e873591c4..932be9519e 100644 --- a/compiler/GHC/Core/Opt/OccurAnal.hs +++ b/compiler/GHC/Core/Opt/OccurAnal.hs @@ -24,7 +24,7 @@ import GHC.Core import GHC.Core.FVs import GHC.Core.Utils ( exprIsTrivial, isDefaultAlt, isExpandableApp, stripTicksTopE, mkTicks ) -import GHC.Core.Opt.Arity ( joinRhsArity ) +import GHC.Core.Opt.Arity ( joinRhsArity, isOneShotBndr ) import GHC.Core.Coercion import GHC.Core.Type import GHC.Core.TyCo.FVs( tyCoVarsOfMCo ) diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs index c5ad4e4b1c..17dfb434fb 100644 --- a/compiler/GHC/Core/Opt/SetLevels.hs +++ b/compiler/GHC/Core/Opt/SetLevels.hs @@ -85,7 +85,7 @@ import GHC.Core.Utils ( exprType, exprIsHNF , collectMakeStaticArgs , mkLamTypes ) -import GHC.Core.Opt.Arity ( exprBotStrictness_maybe ) +import GHC.Core.Opt.Arity ( exprBotStrictness_maybe, isProbablyOneShotLambda ) import GHC.Core.FVs -- all of it import GHC.Core.Subst import GHC.Core.Make ( sortQuantVars ) diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index 0e9c4629bd..e92d6d1032 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -37,9 +37,9 @@ import GHC.Core.Ppr ( pprCoreExpr ) import GHC.Core.Unfold import GHC.Core.Unfold.Make import GHC.Core.Utils -import GHC.Core.Opt.Arity ( ArityType(..), typeArity - , pushCoTyArg, pushCoValArg - , etaExpandAT ) +import GHC.Core.Opt.Arity ( ArityType, arityTypeArityDiv, exprArity + , pushCoTyArg, pushCoValArg, zapLamBndrs + , typeArity, arityTypeArity, etaExpandAT ) import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe ) import GHC.Core.FVs ( mkRuleInfo ) import GHC.Core.Rules ( lookupRule, getRules, initRuleOpts ) @@ -297,7 +297,6 @@ simplRecOrTopPair env top_lvl is_rec mb_cont old_bndr new_bndr rhs | Just cont <- mb_cont = {-#SCC "simplRecOrTopPair-join" #-} assert (isNotTopLevel top_lvl && isJoinId new_bndr ) - simplTrace env "SimplBind:join" (ppr old_bndr) $ simplJoinBind env is_rec cont old_bndr new_bndr rhs env | otherwise @@ -351,7 +350,7 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se -- See Note [Floating and type abstraction] in GHC.Core.Opt.Simplify.Utils -- Simplify the RHS - ; let rhs_cont = mkRhsStop (substTy body_env (exprType body)) + ; let rhs_cont = mkRhsStop (substTy body_env (exprType body)) is_rec ; (body_floats0, body0) <- {-#SCC "simplExprF" #-} simplExprF body_env body rhs_cont -- Never float join-floats out of a non-join let-binding (which this is) @@ -371,7 +370,7 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se ; (rhs_floats, body3) <- if not (doFloatFromRhs top_lvl is_rec False body_floats2 body2) then -- No floating, revert to body1 - return (emptyFloats env, wrapFloats body_floats2 body1) + return (emptyFloats env, wrapFloats body_floats1 body1) else if null tvs then -- Simple floating {-#SCC "simplLazyBind-simple-floating" #-} @@ -383,17 +382,16 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se do { tick LetFloatFromLet ; (poly_binds, body3) <- abstractFloats (seUnfoldingOpts env) top_lvl tvs' body_floats2 body2 - ; let floats = foldl' extendFloats (emptyFloats env) poly_binds - ; return (floats, body3) } + ; let poly_floats = foldl' extendFloats (emptyFloats env) poly_binds + ; return (poly_floats, body3) } ; let env' = env `setInScopeFromF` rhs_floats - ; rhs' <- mkLam env' tvs' body3 rhs_cont + ; rhs' <- rebuildLam env' tvs' body3 rhs_cont ; (bind_float, env2) <- completeBind env' top_lvl is_rec Nothing bndr bndr1 rhs' ; return (rhs_floats `addFloats` bind_float, env2) } -------------------------- -simplJoinBind :: SimplEnv - -> RecFlag +simplJoinBind :: SimplEnv -> RecFlag -> SimplCont -> InId -> OutId -- Binder, both pre-and post simpl -- The OutId has IdInfo, except arity, @@ -622,6 +620,8 @@ tryCastWorkerWrapper env top_lvl old_bndr occ_info bndr (Cast rhs co) triv_rhs = Cast (Var work_id_w_unf) co + + ; traceSmpl "tcww:yes" (vcat [text "work_id" <+> ppr work_id_w_unf, text "rhs" <+> ppr rhs, text "work_rhs" <+> ppr work_rhs ]) ; if postInlineUnconditionally env top_lvl bndr occ_info triv_rhs -- Almost always True, because the RHS is trivial -- In that case we want to eliminate the binding fast @@ -665,7 +665,9 @@ tryCastWorkerWrapper env top_lvl old_bndr occ_info bndr (Cast rhs co) _ -> mkLetUnfolding (sm_uf_opts mode) top_lvl InlineRhs work_id work_rhs tryCastWorkerWrapper env _ _ _ bndr rhs -- All other bindings - = return (mkFloatBind env (NonRec bndr rhs)) + = do { traceSmpl "tcww:no" (vcat [ text "bndr:" <+> ppr bndr + , text "rhs:" <+> ppr rhs ]) + ; return (mkFloatBind env (NonRec bndr rhs)) } mkCastWrapperInlinePrag :: InlinePragma -> InlinePragma -- See Note [Cast worker/wrapper] @@ -790,25 +792,11 @@ makeTrivial env top_lvl dmd occ_fs expr = do { (floats, triv_expr) <- makeTrivial env top_lvl dmd occ_fs expr' ; return (floats, Cast triv_expr co) } - | otherwise - = do { (floats, new_id) <- makeTrivialBinding env top_lvl occ_fs - id_info expr expr_ty - ; return (floats, Var new_id) } - where - id_info = vanillaIdInfo `setDemandInfo` dmd - expr_ty = exprType expr - -makeTrivialBinding :: SimplEnv -> TopLevelFlag - -> FastString -- ^ a "friendly name" to build the new binder from - -> IdInfo - -> OutExpr -- ^ This expression satisfies the let/app invariant - -> OutType -- Type of the expression - -> SimplM (LetFloats, OutId) -makeTrivialBinding env top_lvl occ_fs info expr expr_ty + | otherwise -- 'expr' is not of form (Cast e co) = do { (floats, expr1) <- prepareRhs env top_lvl occ_fs expr ; uniq <- getUniqueM ; let name = mkSystemVarName uniq occ_fs - var = mkLocalIdWithInfo name Many expr_ty info + var = mkLocalIdWithInfo name Many expr_ty id_info -- Now something very like completeBind, -- but without the postInlineUnconditionally part @@ -822,9 +810,12 @@ makeTrivialBinding env top_lvl occ_fs info expr expr_ty ; let final_id = addLetBndrInfo var arity_type unf bind = NonRec final_id expr2 - ; return ( floats `addLetFlts` unitLetFloat bind, final_id ) } + ; traceSmpl "makeTrivial" (vcat [text "final_id" <+> ppr final_id, text "rhs" <+> ppr expr2 ]) + ; return ( floats `addLetFlts` unitLetFloat bind, Var final_id ) } where - mode = getMode env + id_info = vanillaIdInfo `setDemandInfo` dmd + expr_ty = exprType expr + mode = getMode env bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool -- True iff we can have a binding of this expression at this level @@ -942,8 +933,7 @@ addLetBndrInfo :: OutId -> ArityType -> Unfolding -> OutId addLetBndrInfo new_bndr new_arity_type new_unf = new_bndr `setIdInfo` info5 where - AT oss div = new_arity_type - new_arity = length oss + (new_arity, div) = arityTypeArityDiv new_arity_type info1 = idInfo new_bndr `setArityInfo` new_arity @@ -1634,10 +1624,10 @@ simplLam env bndrs body (TickIt tickish cont) -- Not enough args, so there are real lambdas left to put in the result simplLam env bndrs body cont - = do { (env', bndrs') <- simplLamBndrs env bndrs + = do { (env', bndrs') <- simplLamBndrs env bndrs ; body' <- simplExpr env' body - ; new_lam <- mkLam env' bndrs' body' cont - ; rebuild env' new_lam cont } + ; new_lam <- rebuildLam env' bndrs' body' cont + ; rebuild env new_lam cont } ------------- simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) @@ -3504,8 +3494,8 @@ mkDupableContWithDmds env dmds -- let a = ...arg... -- in [...hole...] a -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable - do { let (dmd:_) = dmds -- Never fails - ; (floats1, cont') <- mkDupableContWithDmds env dmds cont + do { let (dmd:cont_dmds) = dmds -- Never fails + ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont ; let env' = env `setInScopeFromF` floats1 ; (_, se', arg') <- simplArg env' dup se arg ; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg' @@ -4043,7 +4033,9 @@ simplStableUnfolding env top_lvl mb_cont id rhs_ty id_arity unf -- See Note [Rules and unfolding for join points] simplJoinRhs unf_env id expr cont Nothing -> -- Binder is not a join point - do { expr' <- simplExprC unf_env expr (mkBoringStop rhs_ty) + do { expr' <- simplExprC unf_env expr (mkRhsStop rhs_ty NonRecursive) + -- mkRhsStop: switch off eta-expansion at the top level + -- The is_rec flag doesn't matter so NonRecursive is fine ; return (eta_expand expr') } ; case guide of UnfWhen { ug_arity = arity @@ -4090,11 +4082,13 @@ simplStableUnfolding env top_lvl mb_cont id rhs_ty id_arity unf -- See Note [Simplifying inside stable unfoldings] in GHC.Core.Opt.Simplify.Utils -- See Note [Eta-expand stable unfoldings] - eta_expand expr - | not eta_on = expr - | exprIsTrivial expr = expr - | otherwise = etaExpandAT (getInScope env) id_arity expr - eta_on = sm_eta_expand (getMode env) + -- Use the arity from the main Id (in id_arity), rather than computing it from rhs + eta_expand expr | sm_eta_expand (getMode env) + , exprArity expr < arityTypeArity id_arity + , wantEtaExpansion expr + = etaExpandAT (getInScope env) id_arity expr + | otherwise + = expr {- Note [Eta-expand stable unfoldings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs index 54a5f171ec..d085e2818e 100644 --- a/compiler/GHC/Core/Opt/Simplify/Env.hs +++ b/compiler/GHC/Core/Opt/Simplify/Env.hs @@ -20,7 +20,7 @@ module GHC.Core.Opt.Simplify.Env ( getSimplRules, -- * Substitution results - SimplSR(..), mkContEx, substId, lookupRecBndr, refineFromInScope, + SimplSR(..), mkContEx, substId, lookupRecBndr, -- * Simplifying 'Id' binders simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs, @@ -32,6 +32,7 @@ module GHC.Core.Opt.Simplify.Env ( SimplFloats(..), emptyFloats, mkRecFloats, mkFloatBind, addLetFloats, addJoinFloats, addFloats, extendFloats, wrapFloats, + isEmptyFloats, isEmptyJoinFloats, isEmptyLetFloats, doFloatFromRhs, getTopFloatBinds, -- * LetFloats @@ -139,6 +140,10 @@ emptyFloats env , sfJoinFloats = emptyJoinFloats , sfInScope = seInScope env } +isEmptyFloats :: SimplFloats -> Bool +isEmptyFloats (SimplFloats { sfLetFloats = lf, sfJoinFloats = jf }) + = isEmptyLetFloats lf && isEmptyJoinFloats jf + pprSimplEnv :: SimplEnv -> SDoc -- Used for debugging; selective pprSimplEnv env @@ -510,9 +515,15 @@ so we must take the 'or' of the two. emptyLetFloats :: LetFloats emptyLetFloats = LetFloats nilOL FltLifted +isEmptyLetFloats :: LetFloats -> Bool +isEmptyLetFloats (LetFloats fs _) = isNilOL fs + emptyJoinFloats :: JoinFloats emptyJoinFloats = nilOL +isEmptyJoinFloats :: JoinFloats -> Bool +isEmptyJoinFloats = isNilOL + unitLetFloat :: OutBind -> LetFloats -- This key function constructs a singleton float with the right form unitLetFloat bind = assert (all (not . isJoinId) (bindersOf bind)) $ @@ -792,7 +803,6 @@ simplRecBndrs env@(SimplEnv {}) ids do { let (!env1, ids1) = mapAccumL substIdBndr env ids ; seqIds ids1 `seq` return env1 } - --------------- substIdBndr :: SimplEnv -> InBndr -> (SimplEnv, OutBndr) -- Might be a coercion variable @@ -1019,7 +1029,7 @@ getTCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env , seCvSubst = cv_env }) = mkTCvSubst in_scope (tv_env, cv_env) -substTy :: SimplEnv -> Type -> Type +substTy :: HasDebugCallStack => SimplEnv -> Type -> Type substTy env ty = Type.substTy (getTCvSubst env) ty substTyVar :: SimplEnv -> TyVar -> Type diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs index 3716d7f79e..b8c483aa50 100644 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -8,7 +8,8 @@ The simplifier utilities module GHC.Core.Opt.Simplify.Utils ( -- Rebuilding - mkLam, mkCase, prepareAlts, tryEtaExpandRhs, + rebuildLam, mkCase, prepareAlts, + tryEtaExpandRhs, wantEtaExpansion, -- Inlining, preInlineUnconditionally, postInlineUnconditionally, @@ -22,7 +23,7 @@ module GHC.Core.Opt.Simplify.Utils ( contIsDupable, contResultType, contHoleType, contHoleScaling, contIsTrivial, contArgs, countArgs, - mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg, + mkBoringStop, mkRhsStop, mkLazyArgStop, interestingCallContext, -- ArgInfo @@ -394,23 +395,17 @@ mkFunRules rs = Just (n_required, rs) mkBoringStop :: OutType -> SimplCont mkBoringStop ty = Stop ty BoringCtxt -mkRhsStop :: OutType -> SimplCont -- See Note [RHS of lets] in GHC.Core.Unfold -mkRhsStop ty = Stop ty RhsCtxt +mkRhsStop :: OutType -> RecFlag -> SimplCont -- See Note [RHS of lets] in GHC.Core.Unfold +mkRhsStop ty is_rec = Stop ty (RhsCtxt is_rec) mkLazyArgStop :: OutType -> CallCtxt -> SimplCont mkLazyArgStop ty cci = Stop ty cci ------------------- -contIsRhsOrArg :: SimplCont -> Bool -contIsRhsOrArg (Stop {}) = True -contIsRhsOrArg (StrictBind {}) = True -contIsRhsOrArg (StrictArg {}) = True -contIsRhsOrArg _ = False - -contIsRhs :: SimplCont -> Bool -contIsRhs (Stop _ RhsCtxt) = True -contIsRhs (CastIt _ k) = contIsRhs k -- For f = e |> co, treat e as Rhs context -contIsRhs _ = False +contIsRhs :: SimplCont -> Maybe RecFlag +contIsRhs (Stop _ (RhsCtxt is_rec)) = Just is_rec +contIsRhs (CastIt _ k) = contIsRhs k -- For f = e |> co, treat e as Rhs context +contIsRhs _ = Nothing ------------------- contIsStop :: SimplCont -> Bool @@ -698,13 +693,16 @@ strictArgContext (ArgInfo { ai_encl = encl_rules, ai_discs = discs }) -- Use this for strict arguments | encl_rules = RuleArgCtxt | disc:_ <- discs, disc > 0 = DiscArgCtxt -- Be keener here - | otherwise = RhsCtxt - -- Why RhsCtxt? if we see f (g x) (h x), and f is strict, we + | otherwise = RhsCtxt NonRecursive + -- Why RhsCtxt? if we see f (g x), and f is strict, we -- want to be a bit more eager to inline g, because it may -- expose an eval (on x perhaps) that can be eliminated or -- shared. I saw this in nofib 'boyer2', RewriteFuns.onewayunify1 -- It's worth an 18% improvement in allocation for this -- particular benchmark; 5% on 'mate' and 1.3% on 'multiplier' + -- + -- Why NonRecursive? Becuase it's a bit like + -- let a = g x in f a interestingCallContext :: SimplEnv -> SimplCont -> CallCtxt -- See Note [Interesting call context] @@ -893,11 +891,10 @@ updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode -- See Note [Simplifying inside stable unfoldings] updModeForStableUnfoldings unf_act current_mode = current_mode { sm_phase = phaseFromActivation unf_act - , sm_inline = True - , sm_eta_expand = False } - -- sm_eta_expand: see Note [No eta expansion in stable unfoldings] + , sm_inline = True } + -- sm_eta_expand: see Historical Note [No eta expansion in stable unfoldings] -- sm_rules: just inherit; sm_rules might be "off" - -- because of -fno-enable-rewrite-rules + -- because of -fno-enable-rewrite-rules where phaseFromActivation (ActiveAfter _ n) = Phase n phaseFromActivation _ = InitialPhase @@ -913,15 +910,23 @@ updModeForRules current_mode {- Note [Simplifying rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When simplifying a rule LHS, refrain from /any/ inlining or applying -of other RULES. +of other RULES. Doing anything to the LHS is plain confusing, because +it means that what the rule matches is not what the user +wrote. c.f. #10595, and #10528. + +* sm_inline, sm_rules: inlining (or applying rules) on rule LHSs risks + introducing Ticks into the LHS, which makes matching + trickier. #10665, #10745. -Doing anything to the LHS is plain confusing, because it means that what the -rule matches is not what the user wrote. c.f. #10595, and #10528. -Moreover, inlining (or applying rules) on rule LHSs risks introducing -Ticks into the LHS, which makes matching trickier. #10665, #10745. + Doing this to either side confounds tools like HERMIT, which seek to reason + about and apply the RULES as originally written. See #10829. -Doing this to either side confounds tools like HERMIT, which seek to reason -about and apply the RULES as originally written. See #10829. + See also Note [Do not expose strictness if sm_inline=False] + +* sm_eta_expand: the template (LHS) of a rule must only mention coercion + /variables/ not arbitrary coercions. See Note [Casts in the template] in + GHC.Core.Rules. Eta expansion can create new coercions; so we switch + it off. There is, however, one case where we are pretty much /forced/ to transform the LHS of a rule: postInlineUnconditionally. For instance, in the case of @@ -938,24 +943,25 @@ postInlineUnconditionally substituted in a trivial expression that contains ticks. See Note [Tick annotations in RULE matching] in GHC.Core.Rules for details. -Note [No eta expansion in stable unfoldings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have a stable unfolding - - f :: Ord a => a -> IO () - -- Unfolding template - -- = /\a \(d:Ord a) (x:a). bla - -we do not want to eta-expand to - - f :: Ord a => a -> IO () - -- Unfolding template - -- = (/\a \(d:Ord a) (x:a) (eta:State#). bla eta) |> co - -because not specialisation of the overloading doesn't work properly -(see Note [Specialisation shape] in GHC.Core.Opt.Specialise), #9509. - -So we disable eta-expansion in stable unfoldings. +Historical Note [No eta expansion in stable unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note is no longer relevant because the specialiser has improved. +See Note [Account for casts in binding] in GHC.Core.Opt.Specialise. +So we do not override sm_eta_expand in updModeForStableUnfoldings. + + Old note: If we have a stable unfolding + f :: Ord a => a -> IO () + -- Unfolding template + -- = /\a \(d:Ord a) (x:a). bla + we do not want to eta-expand to + f :: Ord a => a -> IO () + -- Unfolding template + -- = (/\a \(d:Ord a) (x:a) (eta:State#). bla eta) |> co + because not specialisation of the overloading doesn't work properly + (see Note [Specialisation shape] in GHC.Core.Opt.Specialise), #9509. + So we disable eta-expansion in stable unfoldings. + + End of Historical Note Note [Inlining in gentle mode] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1554,60 +1560,83 @@ won't inline because 'e' is too big. ************************************************************************ -} -mkLam :: SimplEnv -> [OutBndr] -> OutExpr -> SimplCont -> SimplM OutExpr --- mkLam tries three things +rebuildLam :: SimplEnv + -> [OutBndr] -> OutExpr + -> SimplCont -> SimplM OutExpr +-- (rebuildLam env bndrs body cont) +-- returns expr which means the same as \bndrs. body +-- +-- But it tries -- a) eta reduction, if that gives a trivial expression -- b) eta expansion [only if there are some value lambdas] -- -- NB: the SimplEnv already includes the [OutBndr] in its in-scope set -mkLam _env [] body _cont + +rebuildLam _env [] body _cont = return body -mkLam env bndrs body cont - = {-#SCC "mkLam" #-} - do { dflags <- getDynFlags - ; mkLam' dflags bndrs body } + +rebuildLam env bndrs body cont + = do { dflags <- getDynFlags + ; try_eta dflags bndrs body } where - mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr - mkLam' dflags bndrs (Cast body co) - | not (any bad bndrs) - -- Note [Casts and lambdas] - = do { lam <- mkLam' dflags bndrs body - ; return (mkCast lam (mkPiCos Representational bndrs co)) } - where - co_vars = tyCoVarsOfCo co - bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars + mb_rhs :: Maybe RecFlag -- Just => continuation is the RHS of a let + mb_rhs = contIsRhs cont - mkLam' dflags bndrs body@(Lam {}) - = mkLam' dflags (bndrs ++ bndrs1) body1 - where - (bndrs1, body1) = collectBinders body + in_scope = getInScope env -- Includes 'bndrs' - mkLam' dflags bndrs (Tick t expr) - | tickishFloatable t - = mkTick t <$> mkLam' dflags bndrs expr - - mkLam' dflags bndrs body + try_eta :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr + try_eta dflags bndrs body | gopt Opt_DoEtaReduction dflags + , case mb_rhs of { Just Recursive -> False; _ -> True } + -- Is this lambda the RHS of a non-recursive let? + -- See Note [Do not eta reduce PAPs] in GHC.Core.Opt.Arity, and + -- Note [Do not eta-expand PAPs] in this module + -- If so try eta-reduction; but not otherwise , Just etad_lam <- tryEtaReduce bndrs body = do { tick (EtaReduction (head bndrs)) ; return etad_lam } - | not (contIsRhs cont) -- See Note [Eta-expanding lambdas] + | Nothing <- mb_rhs -- See Note [Eta-expanding lambdas] , sm_eta_expand (getMode env) - , any isRuntimeVar bndrs + , any isRuntimeVar bndrs -- Only when there is at least one value lambda already , let body_arity = exprEtaExpandArity dflags body - , expandableArityType body_arity + , expandableArityType body_arity -- This guard is only so that we only do + -- a tick if there so something to do = do { tick (EtaExpansion (head bndrs)) - ; let res = mkLams bndrs $ - etaExpandAT in_scope body_arity body - ; traceSmpl "eta expand" (vcat [text "before" <+> ppr (mkLams bndrs body) - , text "after" <+> ppr res]) - ; return res } + ; let body' = etaExpandAT in_scope body_arity body + ; traceSmpl "eta expand" (vcat [text "before" <+> ppr body + , text "after" <+> ppr body']) + -- NB: body' might have an outer Cast, but if so + -- mk_lams will pull it further out, past 'bndrs' to the top + ; mk_lams dflags bndrs body' } | otherwise - = return (mkLams bndrs body) + = mk_lams dflags bndrs body + + mk_lams :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr + -- mk_lams pulls casts and ticks to the top + mk_lams dflags bndrs body@(Lam {}) + = mk_lams dflags (bndrs ++ bndrs1) body1 + where + (bndrs1, body1) = collectBinders body + + mk_lams dflags bndrs (Tick t expr) + | tickishFloatable t + = do { expr' <- mk_lams dflags bndrs expr + ; return (mkTick t expr') } + + mk_lams dflags bndrs (Cast body co) + | -- Note [Casts and lambdas] + sm_eta_expand (getMode env) + , not (any bad bndrs) + = do { lam <- mk_lams dflags bndrs body + ; return (mkCast lam (mkPiCos Representational bndrs co)) } where - in_scope = getInScope env -- Includes 'bndrs' + co_vars = tyCoVarsOfCo co + bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars + + mk_lams _ bndrs body + = return (mkLams bndrs body) {- Note [Eta expanding lambdas] @@ -1634,16 +1663,35 @@ NB: We check the SimplEnv (sm_eta_expand), not DynFlags. Note [Casts and lambdas] ~~~~~~~~~~~~~~~~~~~~~~~~ Consider - (\x. (\y. e) `cast` g1) `cast` g2 -There is a danger here that the two lambdas look separated, and the -full laziness pass might float an expression to between the two. + (\(x:tx). (\(y:ty). e) `cast` co) + +We float the cast out, thus + (\(x:tx) (y:ty). e) `cast` (tx -> co) + +We do this for at least three reasons: + +1. There is a danger here that the two lambdas look separated, and the + full laziness pass might float an expression to between the two. -So this equation in mkLam' floats the g1 out, thus: - (\x. e `cast` g1) --> (\x.e) `cast` (tx -> g1) -where x:tx. +2. The occurrence analyser will mark x as InsideLam if the Lam nodes + are separated (see the Lam case of occAnal). By floating the cast + out we put the two Lams together, so x can get a vanilla Once + annotation. If this lambda is the RHS of a let, which we inline, + we can do preInlineUnconditionally on that x=arg binding. With the + InsideLam OccInfo, we can't do that, which results in an extra + iteration of the Simplifier. -In general, this floats casts outside lambdas, where (I hope) they -might meet and cancel with some other cast: +3. It may cancel with another cast. E.g + (\x. e |> co1) |> co2 + If we float out co1 it might cancel with co2. Similarly + let f = (\x. e |> co1) in ... + If we float out co1, and then do cast worker/wrapper, we get + let f1 = \x.e; f = f1 |> co1 in ... + and now we can inline f, hoping that co1 may cancel at a call site. + +TL;DR: put the lambdas together if at all possible. + +In general, here's the transformation: \x. e `cast` co ===> (\x. e) `cast` (tx -> co) /\a. e `cast` co ===> (/\a. e) `cast` (/\a. co) /\g. e `cast` co ===> (/\g. e) `cast` (/\g. co) @@ -1681,7 +1729,7 @@ tryEtaExpandRhs env is_rec bndr rhs = do { let (join_bndrs, join_body) = collectNBinders join_arity rhs oss = [idOneShotInfo id | id <- join_bndrs, isId id] arity_type | exprIsDeadEnd join_body = mkBotArityType oss - | otherwise = mkTopArityType oss + | otherwise = mkManifestArityType oss ; return (arity_type, rhs) } -- Note [Do not eta-expand join points] -- But do return the correct arity and bottom-ness, because @@ -1690,7 +1738,7 @@ tryEtaExpandRhs env is_rec bndr rhs | sm_eta_expand mode -- Provided eta-expansion is on , new_arity > old_arity -- And the current manifest arity isn't enough - , want_eta rhs + , wantEtaExpansion rhs = do { tick (EtaExpansion bndr) ; return (arity_type, etaExpandAT in_scope arity_type rhs) } @@ -1698,33 +1746,23 @@ tryEtaExpandRhs env is_rec bndr rhs = return (arity_type, rhs) where - mode = getMode env - in_scope = getInScope env - dflags = sm_dflags mode - old_arity = exprArity rhs - ty_arity = typeArity (idType bndr) - + mode = getMode env + in_scope = getInScope env + dflags = sm_dflags mode + old_arity = exprArity rhs arity_type = findRhsArity dflags is_rec bndr rhs old_arity - `maxWithArity` idCallArity bndr - `minWithArity` ty_arity - -- minWithArity: see Note [Arity trimming] in GHC.Core.Opt.Arity - - new_arity = arityTypeArity arity_type - - -- See Note [Which RHSs do we eta-expand?] - want_eta (Cast e _) = want_eta e - want_eta (Tick _ e) = want_eta e - want_eta (Lam b e) | isTyVar b = want_eta e - want_eta (App e a) | exprIsTrivial a = want_eta e - want_eta (Var {}) = False - want_eta (Lit {}) = False - want_eta _ = True -{- - want_eta _ = case arity_type of - ATop (os:_) -> isOneShotInfo os - ATop [] -> False - ABot {} -> True --} + new_arity = arityTypeArity arity_type + +wantEtaExpansion :: CoreExpr -> Bool +-- Mostly True; but False of PAPs which will immediately eta-reduce again +-- See Note [Which RHSs do we eta-expand?] +wantEtaExpansion (Cast e _) = wantEtaExpansion e +wantEtaExpansion (Tick _ e) = wantEtaExpansion e +wantEtaExpansion (Lam b e) | isTyVar b = wantEtaExpansion e +wantEtaExpansion (App e _) = wantEtaExpansion e +wantEtaExpansion (Var {}) = False +wantEtaExpansion (Lit {}) = False +wantEtaExpansion _ = True {- Note [Eta-expanding at let bindings] diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs index 720bc895c8..e1b418b7f3 100644 --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -90,14 +90,15 @@ little dance in action; the full Simplifier is a lot more complicated. data SimpleOpts = SimpleOpts { so_uf_opts :: !UnfoldingOpts -- ^ Unfolding options , so_co_opts :: !OptCoercionOpts -- ^ Coercion optimiser options + , so_eta_red :: !Bool -- ^ Eta reduction on? } -- | Default options for the Simple optimiser. defaultSimpleOpts :: SimpleOpts defaultSimpleOpts = SimpleOpts { so_uf_opts = defaultUnfoldingOpts - , so_co_opts = OptCoercionOpts - { optCoercionEnabled = False } + , so_co_opts = OptCoercionOpts { optCoercionEnabled = False } + , so_eta_red = False } simpleOptExpr :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr @@ -180,13 +181,10 @@ simpleOptPgm opts this_mod binds rules = type SimpleClo = (SimpleOptEnv, InExpr) data SimpleOptEnv - = SOE { soe_co_opt_opts :: !OptCoercionOpts - -- ^ Options for the coercion optimiser + = SOE { soe_opts :: {-# UNPACK #-} !SimpleOpts + -- ^ Simplifier options - , soe_uf_opts :: !UnfoldingOpts - -- ^ Unfolding options - - , soe_inl :: IdEnv SimpleClo + , soe_inl :: IdEnv SimpleClo -- ^ Deals with preInlineUnconditionally; things -- that occur exactly once and are inlined -- without having first been simplified @@ -202,12 +200,9 @@ instance Outputable SimpleOptEnv where <+> text "}" emptyEnv :: SimpleOpts -> SimpleOptEnv -emptyEnv opts = SOE - { soe_inl = emptyVarEnv - , soe_subst = emptySubst - , soe_co_opt_opts = so_co_opts opts - , soe_uf_opts = so_uf_opts opts - } +emptyEnv opts = SOE { soe_inl = emptyVarEnv + , soe_subst = emptySubst + , soe_opts = opts } soeZapSubst :: SimpleOptEnv -> SimpleOptEnv soeZapSubst env@(SOE { soe_subst = subst }) @@ -280,7 +275,7 @@ simple_opt_expr env expr (env', b') = subst_opt_bndr env b ---------------------- - go_co co = optCoercion (soe_co_opt_opts env) (getTCvSubst subst) co + go_co co = optCoercion (so_co_opts (soe_opts env)) (getTCvSubst subst) co ---------------------- go_alt env (Alt con bndrs rhs) @@ -295,7 +290,8 @@ simple_opt_expr env expr where (env', b') = subst_opt_bndr env b go_lam env bs' e - | Just etad_e <- tryEtaReduce bs e' = etad_e + | so_eta_red (soe_opts env) + , Just etad_e <- tryEtaReduce bs e' = etad_e | otherwise = mkLams bs e' where bs = reverse bs' @@ -420,7 +416,7 @@ simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst }) (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing) | Coercion co <- in_rhs - , let out_co = optCoercion (soe_co_opt_opts env) (getTCvSubst (soe_subst rhs_env)) co + , let out_co = optCoercion (so_co_opts (soe_opts env)) (getTCvSubst (soe_subst rhs_env)) co = assert (isCoVar in_bndr) (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing) @@ -652,7 +648,7 @@ add_info env old_bndr top_level new_rhs new_bndr | otherwise = lazySetIdInfo new_bndr new_info where subst = soe_subst env - uf_opts = soe_uf_opts env + uf_opts = so_uf_opts (soe_opts env) old_info = idInfo old_bndr -- Add back in the rules and unfolding which were diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs index a4f5423be8..3d69917742 100644 --- a/compiler/GHC/Core/Unfold.hs +++ b/compiler/GHC/Core/Unfold.hs @@ -47,7 +47,7 @@ import GHC.Core.DataCon import GHC.Types.Literal import GHC.Builtin.PrimOps import GHC.Types.Id.Info -import GHC.Types.Basic ( Arity ) +import GHC.Types.Basic ( Arity, RecFlag(..) ) import GHC.Core.Type import GHC.Builtin.Names import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) @@ -998,7 +998,7 @@ nonTriv _ = True data CallCtxt = BoringCtxt - | RhsCtxt -- Rhs of a let-binding; see Note [RHS of lets] + | RhsCtxt RecFlag -- Rhs of a let-binding; see Note [RHS of lets] | DiscArgCtxt -- Argument of a function with non-zero arg discount | RuleArgCtxt -- We are somewhere in the argument of a function with rules @@ -1013,7 +1013,7 @@ instance Outputable CallCtxt where ppr CaseCtxt = text "CaseCtxt" ppr ValAppCtxt = text "ValAppCtxt" ppr BoringCtxt = text "BoringCtxt" - ppr RhsCtxt = text "RhsCtxt" + ppr (RhsCtxt ir)= text "RhsCtxt" <> parens (ppr ir) ppr DiscArgCtxt = text "DiscArgCtxt" ppr RuleArgCtxt = text "RuleArgCtxt" @@ -1241,7 +1241,8 @@ tryUnfolding logger opts !case_depth id lone_variable ValAppCtxt -> True -- Note [Cast then apply] RuleArgCtxt -> uf_arity > 0 -- See Note [Unfold info lazy contexts] DiscArgCtxt -> uf_arity > 0 -- Note [Inlining in ArgCtxt] - RhsCtxt -> uf_arity > 0 -- + RhsCtxt NonRecursive + -> uf_arity > 0 -- See Note [RHS of lets] _other -> False -- See Note [Nested functions] @@ -1249,7 +1250,7 @@ tryUnfolding logger opts !case_depth id lone_variable Note [Unfold into lazy contexts], Note [RHS of lets] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When the call is the argument of a function with a RULE, or the RHS of a let, -we are a little bit keener to inline. For example +we are a little bit keener to inline (in tryUnfolding). For example f y = (y,y,y) g y = let x = f y in ...(case x of (a,b,c) -> ...) ... We'd inline 'f' if the call was in a case context, and it kind-of-is, @@ -1258,7 +1259,10 @@ only we can't see it. Also could be expensive whereas x = case v of (a,b) -> a is patently cheap and may allow more eta expansion. -So we treat the RHS of a let as not-totally-boring. + +So we treat the RHS of a /non-recursive/ let as not-totally-boring. +A /recursive/ let isn't going be inlined so there is much less point. +Hence the RecFlag in RhsCtxt Note [Unsaturated applications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs index df2cdb37e4..ca5b47d336 100644 --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -37,9 +37,6 @@ module GHC.Core.Utils ( cheapEqExpr, cheapEqExpr', eqExpr, diffBinds, - -- * Lambdas and eta reduction - tryEtaReduce, zapLamBndrs, - -- * Manipulating data constructors and types exprToType, exprToCoercion_maybe, applyTypeToArgs, applyTypeToArg, @@ -68,11 +65,9 @@ import GHC.Platform import GHC.Core import GHC.Core.Ppr -import GHC.Core.FVs( exprFreeVars ) import GHC.Core.DataCon import GHC.Core.Type as Type import GHC.Core.FamInstEnv -import GHC.Core.Predicate import GHC.Core.TyCo.Rep( TyCoBinder(..), TyBinder ) import GHC.Core.Coercion import GHC.Core.Reduction @@ -92,8 +87,8 @@ import GHC.Types.Literal import GHC.Types.Tickish import GHC.Types.Id import GHC.Types.Id.Info +import GHC.Types.Basic( Arity ) import GHC.Types.Unique -import GHC.Types.Basic ( Arity, FullArgCount ) import GHC.Types.Unique.Set import GHC.Data.FastString @@ -2285,260 +2280,6 @@ locBind loc b1 b2 diffs = map addLoc diffs bindLoc | b1 == b2 = ppr b1 | otherwise = ppr b1 <> char '/' <> ppr b2 -{- -************************************************************************ -* * - Eta reduction -* * -************************************************************************ - -Note [Eta reduction conditions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We try for eta reduction here, but *only* if we get all the way to an -trivial expression. We don't want to remove extra lambdas unless we -are going to avoid allocating this thing altogether. - -There are some particularly delicate points here: - -* We want to eta-reduce if doing so leaves a trivial expression, - *including* a cast. For example - \x. f |> co --> f |> co - (provided co doesn't mention x) - -* Eta reduction is not valid in general: - \x. bot /= bot - This matters, partly for old-fashioned correctness reasons but, - worse, getting it wrong can yield a seg fault. Consider - f = \x.f x - h y = case (case y of { True -> f `seq` True; False -> False }) of - True -> ...; False -> ... - - If we (unsoundly) eta-reduce f to get f=f, the strictness analyser - says f=bottom, and replaces the (f `seq` True) with just - (f `cast` unsafe-co). BUT, as thing stand, 'f' got arity 1, and it - *keeps* arity 1 (perhaps also wrongly). So CorePrep eta-expands - the definition again, so that it does not terminate after all. - Result: seg-fault because the boolean case actually gets a function value. - See #1947. - - So it's important to do the right thing. - -* With linear types, eta-reduction can break type-checking: - f :: A ⊸ B - g :: A -> B - g = \x. f x - - The above is correct, but eta-reducing g would yield g=f, the linter will - complain that g and f don't have the same type. - -* Note [Arity care]: we need to be careful if we just look at f's - arity. Currently (Dec07), f's arity is visible in its own RHS (see - Note [Arity robustness] in GHC.Core.Opt.Simplify.Env) so we must *not* trust the - arity when checking that 'f' is a value. Otherwise we will - eta-reduce - f = \x. f x - to - f = f - Which might change a terminating program (think (f `seq` e)) to a - non-terminating one. So we check for being a loop breaker first. - - However for GlobalIds we can look at the arity; and for primops we - must, since they have no unfolding. - -* Regardless of whether 'f' is a value, we always want to - reduce (/\a -> f a) to f - This came up in a RULE: foldr (build (/\a -> g a)) - did not match foldr (build (/\b -> ...something complex...)) - The type checker can insert these eta-expanded versions, - with both type and dictionary lambdas; hence the slightly - ad-hoc isDictId - -* Never *reduce* arity. For example - f = \xy. g x y - Then if h has arity 1 we don't want to eta-reduce because then - f's arity would decrease, and that is bad - -These delicacies are why we don't use exprIsTrivial and exprIsHNF here. -Alas. - -Note [Eta reduction with casted arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - (\(x:t3). f (x |> g)) :: t3 -> t2 - where - f :: t1 -> t2 - g :: t3 ~ t1 -This should be eta-reduced to - - f |> (sym g -> t2) - -So we need to accumulate a coercion, pushing it inward (past -variable arguments only) thus: - f (x |> co_arg) |> co --> (f |> (sym co_arg -> co)) x - f (x:t) |> co --> (f |> (t -> co)) x - f @ a |> co --> (f |> (forall a.co)) @ a - f @ (g:t1~t2) |> co --> (f |> (t1~t2 => co)) @ (g:t1~t2) -These are the equations for ok_arg. - -Note [Eta reduction with casted function] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Since we are pushing a coercion inwards, it is easy to accommodate - (\xy. (f x |> g) y) - (\xy. (f x y) |> g) - -See the `(Cast e co)` equation for `go` in `tryEtaReduce`. The -eta-expander pushes those casts outwards, so you might think we won't -ever see a cast here, but if we have - \xy. (f x y |> g) -we will call tryEtaReduce [x,y] (f x y |> g), and we'd like that to -work. This happens in GHC.Core.Opt.Simplify.Utils.mkLam, where -eta-expansion may be turned off (by sm_eta_expand). --} - --- When updating this function, make sure to update --- CorePrep.tryEtaReducePrep as well! -tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr --- Return an expression equal to (\bndrs. body) -tryEtaReduce bndrs body - = go (reverse bndrs) body (mkRepReflCo (exprType body)) - where - incoming_arity = count isId bndrs - - go :: [Var] -- Binders, innermost first, types [a3,a2,a1] - -> CoreExpr -- Of type tr - -> Coercion -- Of type tr ~ ts - -> Maybe CoreExpr -- Of type a1 -> a2 -> a3 -> ts - -- See Note [Eta reduction with casted arguments] - -- for why we have an accumulating coercion - -- - -- Invariant: (go bs body co) returns an expression - -- equivalent to (\(reverse bs). body |> co) - go [] fun co - | ok_fun fun - , let used_vars = exprFreeVars fun `unionVarSet` tyCoVarsOfCo co - , not (any (`elemVarSet` used_vars) bndrs) - = Just (mkCast fun co) -- Check for any of the binders free in the result - -- including the accumulated coercion - - -- See Note [Eta reduction with casted function] - go bs (Cast e co1) co2 - = go bs e (co1 `mkTransCo` co2) - - go bs (Tick t e) co - | tickishFloatable t - = fmap (Tick t) $ go bs e co - -- Float app ticks: \x -> Tick t (e x) ==> Tick t e - - go (b : bs) (App fun arg) co - | Just (co', ticks) <- ok_arg b arg co (exprType fun) - = fmap (flip (foldr mkTick) ticks) $ go bs fun co' - -- Float arg ticks: \x -> e (Tick t x) ==> Tick t e - - go _ _ _ = Nothing -- Failure! - - --------------- - -- Note [Eta reduction conditions] - ok_fun (App fun (Type {})) = ok_fun fun - ok_fun (Cast fun _) = ok_fun fun - ok_fun (Tick _ expr) = ok_fun expr - ok_fun (Var fun_id) = ok_fun_id fun_id || all ok_lam bndrs - ok_fun _fun = False - - --------------- - ok_fun_id fun = -- There are arguments to reduce - fun_arity fun >= incoming_arity && - -- We always want args for join points so - -- we should never eta-reduce to a trivial expression. - -- See Note [Invariants on join points] in GHC.Core, and #20599 - not (isJoinId fun) - - --------------- - fun_arity fun -- See Note [Arity care] - | isLocalId fun - , isStrongLoopBreaker (idOccInfo fun) = 0 - | arity > 0 = arity - | isEvaldUnfolding (idUnfolding fun) = 1 - -- See Note [Eta reduction of an eval'd function] - | otherwise = 0 - where - arity = idArity fun - - --------------- - ok_lam v = isTyVar v || isEvVar v - - --------------- - ok_arg :: Var -- Of type bndr_t - -> CoreExpr -- Of type arg_t - -> Coercion -- Of kind (t1~t2) - -> Type -- Type (arg_t -> t1) of the function - -- to which the argument is supplied - -> Maybe (Coercion -- Of type (arg_t -> t1 ~ bndr_t -> t2) - -- (and similarly for tyvars, coercion args) - , [CoreTickish]) - -- See Note [Eta reduction with casted arguments] - ok_arg bndr (Type ty) co _ - | Just tv <- getTyVar_maybe ty - , bndr == tv = Just (mkHomoForAllCos [tv] co, []) - ok_arg bndr (Var v) co fun_ty - | bndr == v - , let mult = idMult bndr - , Just (fun_mult, _, _) <- splitFunTy_maybe fun_ty - , mult `eqType` fun_mult -- There is no change in multiplicity, otherwise we must abort - = Just (mkFunResCo Representational (idScaledType bndr) co, []) - ok_arg bndr (Cast e co_arg) co fun_ty - | (ticks, Var v) <- stripTicksTop tickishFloatable e - , Just (fun_mult, _, _) <- splitFunTy_maybe fun_ty - , bndr == v - , fun_mult `eqType` idMult bndr - = Just (mkFunCo Representational (multToCo fun_mult) (mkSymCo co_arg) co, ticks) - -- The simplifier combines multiple casts into one, - -- so we can have a simple-minded pattern match here - ok_arg bndr (Tick t arg) co fun_ty - | tickishFloatable t, Just (co', ticks) <- ok_arg bndr arg co fun_ty - = Just (co', t:ticks) - - ok_arg _ _ _ _ = Nothing - -{- -Note [Eta reduction of an eval'd function] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In Haskell it is not true that f = \x. f x -because f might be bottom, and 'seq' can distinguish them. - -But it *is* true that f = f `seq` \x. f x -and we'd like to simplify the latter to the former. This amounts -to the rule that - * when there is just *one* value argument, - * f is not bottom -we can eta-reduce \x. f x ===> f - -This turned up in #7542. --} - -{- ********************************************************************* -* * - Zapping lambda binders -* * -********************************************************************* -} - -zapLamBndrs :: FullArgCount -> [Var] -> [Var] --- If (\xyz. t) appears under-applied to only two arguments, --- we must zap the occ-info on x,y, because they appear under the \x --- See Note [Occurrence analysis for lambda binders] in GHc.Core.Opt.OccurAnal --- --- NB: both `arg_count` and `bndrs` include both type and value args/bndrs -zapLamBndrs arg_count bndrs - | no_need_to_zap = bndrs - | otherwise = zap_em arg_count bndrs - where - no_need_to_zap = all isOneShotBndr (drop arg_count bndrs) - - zap_em :: FullArgCount -> [Var] -> [Var] - zap_em 0 bs = bs - zap_em _ [] = [] - zap_em n (b:bs) | isTyVar b = b : zap_em (n-1) bs - | otherwise = zapLamIdInfo b : zap_em (n-1) bs - {- ********************************************************************* * * diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index e3932e835e..3cf7f1bbb1 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -35,7 +35,6 @@ import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) import GHC.Core.Utils import GHC.Core.Opt.Arity -import GHC.Core.FVs import GHC.Core.Opt.Monad ( CoreToDo(..) ) import GHC.Core.Lint ( endPassIO ) import GHC.Core @@ -63,7 +62,6 @@ import GHC.Utils.Trace import GHC.Types.Demand import GHC.Types.Var -import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Id import GHC.Types.Id.Info @@ -781,7 +779,7 @@ cpeRhsE env expr@(Lit (LitNumber nt i)) Just e -> cpeRhsE env e cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr) cpeRhsE env expr@(Var {}) = cpeApp env expr -cpeRhsE env expr@(App {}) = cpeApp env expr +cpeRhsE env expr@(App {}) = cpeApp env expr cpeRhsE env (Let bind body) = do { (env', bind_floats, maybe_bind') <- cpeBind NotTopLevel env bind @@ -915,9 +913,7 @@ rhsToBody (Cast e co) = do { (floats, e') <- rhsToBody e ; return (floats, Cast e' co) } -rhsToBody expr@(Lam {}) - | Just no_lam_result <- tryEtaReducePrep bndrs body - = return (emptyFloats, no_lam_result) +rhsToBody expr@(Lam {}) -- See Note [No eta reduction needed in rhsToBody] | all isTyVar bndrs -- Type lambdas are ok = return (emptyFloats, expr) | otherwise -- Some value lambdas @@ -926,11 +922,29 @@ rhsToBody expr@(Lam {}) ; let float = FloatLet (NonRec fn rhs) ; return (unitFloat float, Var fn) } where - (bndrs,body) = collectBinders expr + (bndrs,_) = collectBinders expr rhsToBody expr = return (emptyFloats, expr) +{- Note [No eta reduction needed in rhsToBody] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Historical note. In the olden days we used to have a Prep-specific +eta-reduction step in rhsToBody: + rhsToBody expr@(Lam {}) + | Just no_lam_result <- tryEtaReducePrep bndrs body + = return (emptyFloats, no_lam_result) + +The goal was to reduce + case x of { p -> \xs. map f xs } + ==> case x of { p -> map f } + +to avoid allocating a lambda. Of course, we'd allocate a PAP +instead, which is hardly better, but that's the way it was. + +Now we simply don't bother with this. It doesn't seem to be a win, +and it's extra work. +-} -- --------------------------------------------------------------------------- -- CpeApp: produces a result satisfying CpeApp @@ -1084,7 +1098,7 @@ cpeApp top_env expr case head of Just fn_id -> do { sat_app <- maybeSaturate fn_id app depth ; return (floats, sat_app) } - _other -> return (floats, app) + _other -> return (floats, app) -- Deconstruct and rebuild the application, floating any non-atomic -- arguments to the outside. We collect the type of the expression, @@ -1459,7 +1473,7 @@ the simplifier only when there at least one lambda already. NB1:we could refrain when the RHS is trivial (which can happen for exported things). This would reduce the amount of code - generated (a little) and make things a little words for + generated (a little) and make things a little worse for code compiled without -O. The case in point is data constructor wrappers. @@ -1493,57 +1507,6 @@ cpeEtaExpand arity expr | otherwise = etaExpand arity expr {- --- ----------------------------------------------------------------------------- --- Eta reduction --- ----------------------------------------------------------------------------- - -Why try eta reduction? Hasn't the simplifier already done eta? -But the simplifier only eta reduces if that leaves something -trivial (like f, or f Int). But for deLam it would be enough to -get to a partial application: - case x of { p -> \xs. map f xs } - ==> case x of { p -> map f } --} - --- When updating this function, make sure it lines up with --- GHC.Core.Utils.tryEtaReduce! -tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr -tryEtaReducePrep bndrs expr@(App _ _) - | ok_to_eta_reduce f - , n_remaining >= 0 - , and (zipWith ok bndrs last_args) - , not (any (`elemVarSet` fvs_remaining) bndrs) - , exprIsHNF remaining_expr -- Don't turn value into a non-value - -- else the behaviour with 'seq' changes - = Just remaining_expr - where - (f, args) = collectArgs expr - remaining_expr = mkApps f remaining_args - fvs_remaining = exprFreeVars remaining_expr - (remaining_args, last_args) = splitAt n_remaining args - n_remaining = length args - length bndrs - - ok bndr (Var arg) = bndr == arg - ok _ _ = False - - -- We can't eta reduce something which must be saturated. - ok_to_eta_reduce (Var f) = not (hasNoBinding f) && - not (isLinearType (idType f)) && -- Unsure why this is unsafe. - (not (isJoinId f) || idJoinArity f <= n_remaining) - -- Don't undersaturate join points. - -- See Note [Invariants on join points] in GHC.Core, and #20599 - - - ok_to_eta_reduce _ = False -- Safe. ToDo: generalise - - -tryEtaReducePrep bndrs (Tick tickish e) - | tickishFloatable tickish - = fmap (mkTick tickish) $ tryEtaReducePrep bndrs e - -tryEtaReducePrep _ _ = Nothing - -{- ************************************************************************ * * Floats diff --git a/compiler/GHC/Driver/Config.hs b/compiler/GHC/Driver/Config.hs index 2d4135a847..bd9790312b 100644 --- a/compiler/GHC/Driver/Config.hs +++ b/compiler/GHC/Driver/Config.hs @@ -29,6 +29,7 @@ initSimpleOpts :: DynFlags -> SimpleOpts initSimpleOpts dflags = SimpleOpts { so_uf_opts = unfoldingOpts dflags , so_co_opts = initOptCoercionOpts dflags + , so_eta_red = gopt Opt_DoEtaReduction dflags } -- | Extract BCO options from DynFlags diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index dd94b879ac..584c1037f0 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -1445,4 +1445,4 @@ mustExposeTyCon no_trim_types exports tc exported_con con = any (`elemNameSet` exports) (dataConName con : dataConFieldLabels con) -} ->>>>>>> Do arity trimming at bindings, rather than in exprArity + diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs index 7d89b71309..6b6a802490 100644 --- a/compiler/GHC/StgToCmm/Bind.hs +++ b/compiler/GHC/StgToCmm/Bind.hs @@ -18,6 +18,7 @@ import GHC.Prelude hiding ((<*>)) import GHC.Driver.Session import GHC.Core ( AltCon(..) ) +import GHC.Core.Opt.Arity( isOneShotBndr ) import GHC.Runtime.Heap.Layout import GHC.Unit.Module diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs index d9f78a3bcf..9ee1a1cc3c 100644 --- a/compiler/GHC/Types/Id.hs +++ b/compiler/GHC/Types/Id.hs @@ -86,10 +86,8 @@ module GHC.Types.Id ( idInlineActivation, setInlineActivation, idRuleMatchInfo, -- ** One-shot lambdas - isOneShotBndr, isProbablyOneShotLambda, setOneShotLambda, clearOneShotLambda, updOneShotInfo, setIdOneShotInfo, - isStateHackType, stateHackOneShot, typeOneShot, -- ** Reading 'IdInfo' fields idArity, @@ -97,7 +95,7 @@ module GHC.Types.Id ( idUnfolding, realIdUnfolding, idSpecialisation, idCoreRules, idHasRules, idCafInfo, idLFInfo_maybe, - idOneShotInfo, idStateHackOneShotInfo, + idOneShotInfo, idOccInfo, isNeverRepPolyId, @@ -140,7 +138,6 @@ import qualified GHC.Types.Var as Var import GHC.Core.Type import GHC.Types.RepType -import GHC.Builtin.Types.Prim import GHC.Core.DataCon import GHC.Types.Demand import GHC.Types.Cpr @@ -161,7 +158,6 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Utils.GlobalVars import GHC.Utils.Trace -- infixl so you can say (id `set` a `set` b) @@ -806,64 +802,6 @@ isConLikeId id = isConLike (idRuleMatchInfo id) idOneShotInfo :: Id -> OneShotInfo idOneShotInfo id = oneShotInfo (idInfo id) --- | Like 'idOneShotInfo', but taking the Horrible State Hack in to account --- See Note [The state-transformer hack] in "GHC.Core.Opt.Arity" -idStateHackOneShotInfo :: Id -> OneShotInfo -idStateHackOneShotInfo id - | isStateHackType (idType id) = stateHackOneShot - | otherwise = idOneShotInfo id - --- | Returns whether the lambda associated with the 'Id' is certainly applied at most once --- This one is the "business end", called externally. --- It works on type variables as well as Ids, returning True --- Its main purpose is to encapsulate the Horrible State Hack --- See Note [The state-transformer hack] in "GHC.Core.Opt.Arity" -isOneShotBndr :: Var -> Bool -isOneShotBndr var - | isTyVar var = True - | OneShotLam <- idStateHackOneShotInfo var = True - | otherwise = False - --- | Should we apply the state hack to values of this 'Type'? -stateHackOneShot :: OneShotInfo -stateHackOneShot = OneShotLam - -typeOneShot :: Type -> OneShotInfo -typeOneShot ty - | isStateHackType ty = stateHackOneShot - | otherwise = NoOneShotInfo - -isStateHackType :: Type -> Bool -isStateHackType ty - | unsafeHasNoStateHack - = False - | otherwise - = case tyConAppTyCon_maybe ty of - Just tycon -> tycon == statePrimTyCon - _ -> False - -- This is a gross hack. It claims that - -- every function over realWorldStatePrimTy is a one-shot - -- function. This is pretty true in practice, and makes a big - -- difference. For example, consider - -- a `thenST` \ r -> ...E... - -- The early full laziness pass, if it doesn't know that r is one-shot - -- will pull out E (let's say it doesn't mention r) to give - -- let lvl = E in a `thenST` \ r -> ...lvl... - -- When `thenST` gets inlined, we end up with - -- let lvl = E in \s -> case a s of (r, s') -> ...lvl... - -- and we don't re-inline E. - -- - -- It would be better to spot that r was one-shot to start with, but - -- I don't want to rely on that. - -- - -- Another good example is in fill_in in PrelPack.hs. We should be able to - -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet. - -isProbablyOneShotLambda :: Id -> Bool -isProbablyOneShotLambda id = case idStateHackOneShotInfo id of - OneShotLam -> True - NoOneShotInfo -> False - setOneShotLambda :: Id -> Id setOneShotLambda id = modifyIdInfo (`setOneShotInfo` OneShotLam) id diff --git a/compiler/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs index dc23932a51..50945bf4df 100644 --- a/compiler/GHC/Types/Id/Info.hs +++ b/compiler/GHC/Types/Id/Info.hs @@ -162,6 +162,7 @@ data IdDetails | PrimOpId PrimOp Bool -- ^ The 'Id' is for a primitive operator -- True <=> is representation-polymorphic, -- and hence has no binding + -- This lev-poly flag is used only in GHC.Types.Id.hasNoBinding | FCallId ForeignCall -- ^ The 'Id' is for a foreign call. -- Type will be simple: no type families, newtypes, etc diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs index 94a2f7af06..f8e8968884 100644 --- a/compiler/GHC/Types/Id/Make.hs +++ b/compiler/GHC/Types/Id/Make.hs @@ -43,6 +43,7 @@ import GHC.Prelude import GHC.Builtin.Types.Prim import GHC.Builtin.Types import GHC.Core.Opt.ConstantFold +import GHC.Core.Opt.Arity( typeOneShot ) import GHC.Core.Type import GHC.Core.Multiplicity import GHC.Core.TyCo.Rep @@ -86,7 +87,7 @@ import GHC.Data.List.SetOps import GHC.Types.Var (VarBndr(Bndr)) import qualified GHC.LanguageExtensions as LangExt -import Data.Maybe ( isJust, maybeToList ) +import Data.Maybe ( maybeToList ) {- ************************************************************************ @@ -1802,10 +1803,12 @@ inlined. -} realWorldPrimId :: Id -- :: State# RealWorld -realWorldPrimId = pcMiscPrelId realWorldName realWorldStatePrimTy +realWorldPrimId = pcMiscPrelId realWorldName id_ty (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] - `setOneShotInfo` stateHackOneShot - `setNeverRepPoly` realWorldStatePrimTy) + `setOneShotInfo` typeOneShot id_ty + `setNeverRepPoly` id_ty) + where + id_ty = realWorldStatePrimTy voidPrimId :: Id -- Global constant :: Void# -- The type Void# is now the same as (# #) (ticket #18441), diff --git a/testsuite/tests/arityanal/should_compile/Arity03.stderr b/testsuite/tests/arityanal/should_compile/Arity03.stderr index e5e3e754dd..652fcde173 100644 --- a/testsuite/tests/arityanal/should_compile/Arity03.stderr +++ b/testsuite/tests/arityanal/should_compile/Arity03.stderr @@ -18,20 +18,15 @@ end Rec } fac [InlPrag=[2]] :: Int -> Int [GblId, Arity=1, - Str=<1P(1L)>, - Cpr=m1, + Str=<1!P(1L)>, + Cpr=1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) - Tmpl= \ (w [Occ=Once1!] :: Int) -> case w of { GHC.Types.I# ww1 [Occ=Once1] -> case F3.$wfac ww1 of ww2 [Occ=Once1] { __DEFAULT -> GHC.Types.I# ww2 } }}] -fac = \ (w :: Int) -> case w of { GHC.Types.I# ww1 -> case F3.$wfac ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 } } + Tmpl= \ (x [Occ=Once1!] :: Int) -> case x of { GHC.Types.I# ww [Occ=Once1] -> case F3.$wfac ww of ww1 [Occ=Once1] { __DEFAULT -> GHC.Types.I# ww1 } }}] +fac = \ (x :: Int) -> case x of { GHC.Types.I# ww -> case F3.$wfac ww of ww1 { __DEFAULT -> GHC.Types.I# ww1 } } -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} f3 :: Int -> Int -[GblId, - Arity=1, - Str=<1P(1L)>, - Cpr=m1, - Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=True) - Tmpl= fac}] +[GblId, Arity=1, Str=<1!P(1L)>, Cpr=1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}] f3 = fac diff --git a/testsuite/tests/arityanal/should_compile/Arity11.stderr b/testsuite/tests/arityanal/should_compile/Arity11.stderr index 48b37a13db..84e8c40deb 100644 --- a/testsuite/tests/arityanal/should_compile/Arity11.stderr +++ b/testsuite/tests/arityanal/should_compile/Arity11.stderr @@ -124,4 +124,7 @@ f11 :: (Integer, Integer) f11 = (F11.f4, F11.f1) +------ Local rules for imported ids -------- +"SPEC fib @Integer @Integer" forall ($dEq :: Eq Integer) ($dNum :: Num Integer) ($dNum1 :: Num Integer). fib @Integer @Integer $dEq $dNum $dNum1 = F11.f11_fib + diff --git a/testsuite/tests/codeGen/should_compile/debug.stdout b/testsuite/tests/codeGen/should_compile/debug.stdout index 3dca62a419..25df0c258f 100644 --- a/testsuite/tests/codeGen/should_compile/debug.stdout +++ b/testsuite/tests/codeGen/should_compile/debug.stdout @@ -18,6 +18,7 @@ src<debug.hs:4:9> src<debug.hs:5:21-29> src<debug.hs:5:9-29> src<debug.hs:6:1-21> +src<debug.hs:6:16-21> == CBE == src<debug.hs:4:9> 89 diff --git a/testsuite/tests/deSugar/should_compile/T19969.hs b/testsuite/tests/deSugar/should_compile/T19969.hs index ad9546c84a..c6a8ac9c05 100644 --- a/testsuite/tests/deSugar/should_compile/T19969.hs +++ b/testsuite/tests/deSugar/should_compile/T19969.hs @@ -5,10 +5,10 @@ module T19969 where -- Three mutually recursive functions -- We want to inline g, h, keeping f as the loop breaker +f [] = [] f x = reverse (g (x:: [Int])) :: [Int] {-# INLINE g #-} - g x = reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (h x)))))))))))) {-# INLINE h #-} diff --git a/testsuite/tests/deSugar/should_compile/T19969.stderr b/testsuite/tests/deSugar/should_compile/T19969.stderr index 5e23785472..3c70f95163 100644 --- a/testsuite/tests/deSugar/should_compile/T19969.stderr +++ b/testsuite/tests/deSugar/should_compile/T19969.stderr @@ -1,38 +1,425 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 12, types: 18, coercions: 0, joins: 0/0} + = {terms: 196, types: 204, coercions: 0, joins: 0/0} Rec { --- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0} -f [Occ=LoopBreaker] :: [Int] -> [Int] -[GblId, Arity=1, Str=<B>b, Cpr=b, Unf=OtherCon []] -f = \ (x :: [Int]) -> f x +-- RHS size: {terms: 55, types: 53, coercions: 0, joins: 0/0} +T19969.f_$sf [Occ=LoopBreaker] :: Int -> [Int] -> [Int] +[GblId, Arity=2, Str=<B><B>b, Unf=OtherCon []] +T19969.f_$sf + = \ (sc :: Int) (sc1 :: [Int]) -> + GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (T19969.f_$sf + sc sc1) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int) end Rec } --- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0} -g [InlPrag=INLINE (sat-args=1)] :: [Int] -> [Int] +-- RHS size: {terms: 59, types: 58, coercions: 0, joins: 0/0} +f :: [Int] -> [Int] +[GblId, Arity=1, Str=<1L>, Unf=OtherCon []] +f = \ (ds :: [Int]) -> + case ds of { + [] -> GHC.Types.[] @Int; + : ipv ipv1 -> + GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (T19969.f_$sf + ipv ipv1) + (GHC.Types.[] + @Int)) + (GHC.Types.[] + @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int) + } + +-- RHS size: {terms: 27, types: 26, coercions: 0, joins: 0/0} +h [InlPrag=INLINE (sat-args=1)] :: [Int] -> [Int] [GblId, Arity=1, - Str=<B>b, - Cpr=b, + Str=<1L>, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=True) - Tmpl= \ (x [Occ=Once1] :: [Int]) -> f x}] -g = \ (x :: [Int]) -> f x + Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=False) + Tmpl= \ (x [Occ=Once1] :: [Int]) -> + GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 @Int (f x) (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)}] +h = \ (x :: [Int]) -> + GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 @Int (f x) (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int) --- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0} -h [InlPrag=INLINE (sat-args=1)] :: [Int] -> [Int] +-- RHS size: {terms: 51, types: 50, coercions: 0, joins: 0/0} +g [InlPrag=INLINE (sat-args=1)] :: [Int] -> [Int] [GblId, Arity=1, - Str=<B>b, - Cpr=b, + Str=<1L>, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=True) - Tmpl= \ (x [Occ=Once1] :: [Int]) -> f x}] -h = \ (x :: [Int]) -> f x + Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=False) + Tmpl= \ (x [Occ=Once1] :: [Int]) -> + GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (f x) + (GHC.Types.[] + @Int)) + (GHC.Types.[] + @Int)) + (GHC.Types.[] + @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)}] +g = \ (x :: [Int]) -> + GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (f x) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int) + +------ Local rules for imported ids -------- +"SC:f0" + forall (sc :: Int) (sc1 :: [Int]). + f (GHC.Types.: @Int sc sc1) + = T19969.f_$sf sc sc1 diff --git a/testsuite/tests/driver/inline-check.stderr b/testsuite/tests/driver/inline-check.stderr index 40b5b59d19..a65d39ea6f 100644 --- a/testsuite/tests/driver/inline-check.stderr +++ b/testsuite/tests/driver/inline-check.stderr @@ -1,6 +1,6 @@ Considering inlining: foo arg infos [ValueArg] - interesting continuation RhsCtxt + interesting continuation RhsCtxt(NonRecursive) some_benefit True is exp: True is work-free: True @@ -19,7 +19,7 @@ Inactive unfolding: foo1 Inactive unfolding: foo1 Considering inlining: foo arg infos [] - interesting continuation RhsCtxt + interesting continuation RhsCtxt(NonRecursive) some_benefit False is exp: True is work-free: True diff --git a/testsuite/tests/numeric/should_compile/T19641.stderr b/testsuite/tests/numeric/should_compile/T19641.stderr index b79d0217ee..ec7e19c946 100644 --- a/testsuite/tests/numeric/should_compile/T19641.stderr +++ b/testsuite/tests/numeric/should_compile/T19641.stderr @@ -4,15 +4,15 @@ Result size of Tidy Core = {terms: 22, types: 20, coercions: 0, joins: 0/0} natural_to_word - = \ x -> - case x of { + = \ eta -> + case eta of { NS x1 -> Just (W# x1); NB ds -> Nothing } integer_to_int - = \ x -> - case x of { + = \ eta -> + case eta of { IS ipv -> Just (I# ipv); IP x1 -> Nothing; IN ds -> Nothing diff --git a/testsuite/tests/simplCore/should_compile/Makefile b/testsuite/tests/simplCore/should_compile/Makefile index 42993eb11d..14e97664be 100644 --- a/testsuite/tests/simplCore/should_compile/Makefile +++ b/testsuite/tests/simplCore/should_compile/Makefile @@ -165,12 +165,12 @@ T5298: .PHONY: T5327 T5327: $(RM) -f T5327.hi T5327.o - '$(TEST_HC)' $(TEST_HC_OPTS) -c T5327.hs -O -ddump-simpl | grep -c '># 34# ' + '$(TEST_HC)' $(TEST_HC_OPTS) -c T5327.hs -O -ddump-simpl | grep -c '34#' .PHONY: T16254 T16254: $(RM) -f T16254.hi T16254.o - '$(TEST_HC)' $(TEST_HC_OPTS) -c T16254.hs -O -ddump-simpl | grep -c '># 34# ' + '$(TEST_HC)' $(TEST_HC_OPTS) -c T16254.hs -O -ddump-simpl | grep -c '34#' .PHONY: T5623 T5623: diff --git a/testsuite/tests/simplCore/should_compile/T16254.hs b/testsuite/tests/simplCore/should_compile/T16254.hs index 3c1490c17c..a877eee6ab 100644 --- a/testsuite/tests/simplCore/should_compile/T16254.hs +++ b/testsuite/tests/simplCore/should_compile/T16254.hs @@ -8,7 +8,12 @@ newtype Size a b where {-# INLINABLE val2 #-} val2 = Size 17 --- In the core, we should see a comparison against 34#, i.e. constant --- folding should have happened. We actually see it twice: Once in f's --- definition, and once in its unfolding. +-- In the core, we should see 34#, i.e. constant folding +-- should have happened. +-- +-- We actually get eta-reduction thus: +-- tmp = I# 34# +-- f = gtInt tmp +-- beucase gtInt is marked INLINE with two parameters. +-- But that's ok f n = case val2 of Size s -> s + s > n diff --git a/testsuite/tests/simplCore/should_compile/T5327.hs b/testsuite/tests/simplCore/should_compile/T5327.hs index a2d9c018ae..a533a2fe32 100644 --- a/testsuite/tests/simplCore/should_compile/T5327.hs +++ b/testsuite/tests/simplCore/should_compile/T5327.hs @@ -5,8 +5,13 @@ newtype Size = Size Int {-# INLINABLE val2 #-} val2 = Size 17 --- In the core, we should see a comparison against 34#, i.e. constant --- folding should have happened. We actually see it twice: Once in f's --- definition, and once in its unfolding. +-- In the core, we should see 34#, i.e. constant folding +-- should have happened. +-- +-- We actually get eta-reduction thus: +-- tmp = I# 34# +-- f = gtInt tmp +-- beucase gtInt is marked INLINE with two parameters. +-- But that's ok f n = case val2 of Size s -> s + s > n diff --git a/testsuite/tests/simplCore/should_compile/T7785.stderr b/testsuite/tests/simplCore/should_compile/T7785.stderr index f0187fe958..53efb3bab4 100644 --- a/testsuite/tests/simplCore/should_compile/T7785.stderr +++ b/testsuite/tests/simplCore/should_compile/T7785.stderr @@ -1,8 +1,335 @@ -==================== Tidy Core rules ==================== -"SPEC shared @[]" - forall ($dMyFunctor :: MyFunctor []) (irred :: Domain [] Int). - shared @[] $dMyFunctor irred - = bar_$sshared +==================== Common sub-expression ==================== +Result size of Common sub-expression + = {terms: 181, types: 89, coercions: 5, joins: 0/1} + +-- RHS size: {terms: 5, types: 10, coercions: 0, joins: 0/0} +$cmyfmap_aG7 + :: forall a b. (Domain [] a, Domain [] b) => (a -> b) -> [a] -> [b] +[LclId, + Arity=4, + Str=<A><A><U><SU>, + Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=True) + Tmpl= \ (@a_aGa) + (@b_aGb) + _ [Occ=Dead] + _ [Occ=Dead] + (eta_B0 [Occ=Once1, OS=OneShot] :: a_aGa -> b_aGb) + (eta_B1 [Occ=Once1, OS=OneShot] :: [a_aGa]) -> + GHC.Base.build + @b_aGb + (\ (@b1_aHe) + (c_aHf [Occ=Once1, OS=OneShot] :: b_aGb -> b1_aHe -> b1_aHe) + (n_aHg [Occ=Once1, OS=OneShot] :: b1_aHe) -> + GHC.Base.foldr + @a_aGa + @b1_aHe + (GHC.Base.mapFB @b_aGb @b1_aHe @a_aGa c_aHf eta_B0) + n_aHg + eta_B1)}] +$cmyfmap_aG7 + = \ (@a_aGa) + (@b_aGb) + _ [Occ=Dead, Dmd=A] + _ [Occ=Dead, Dmd=A, OS=OneShot] -> + map @a_aGa @b_aGb + +-- RHS size: {terms: 1, types: 0, coercions: 3, joins: 0/0} +Foo.$fMyFunctor[] [InlPrag=INLINE (sat-args=0)] :: MyFunctor [] +[LclIdX[DFunId(nt)], + Arity=4, + Str=<A><A><U><SU>, + Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=False,boring_ok=True) + Tmpl= $cmyfmap_aG7 + `cast` (Sym (Foo.N:MyFunctor[0] <[]>_N) + :: (forall a b. + (Domain [] a, Domain [] b) => + (a -> b) -> [a] -> [b]) + ~R# MyFunctor [])}] +Foo.$fMyFunctor[] + = $cmyfmap_aG7 + `cast` (Sym (Foo.N:MyFunctor[0] <[]>_N) + :: (forall a b. + (Domain [] a, Domain [] b) => + (a -> b) -> [a] -> [b]) + ~R# MyFunctor []) + +-- RHS size: {terms: 2, types: 2, coercions: 0, joins: 0/0} +$sshared_sHD :: [Int] -> [Int] +[LclId, + Arity=1, + Str=<SU>, + Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False) + Tmpl= map @Int @Int GHC.Num.$fNumInt_$cnegate}] +$sshared_sHD = map @Int @Int GHC.Num.$fNumInt_$cnegate + +-- RHS size: {terms: 115, types: 15, coercions: 2, joins: 0/1} +shared + :: forall (f :: * -> *). + (MyFunctor f, Domain f Int) => + f Int -> f Int +[LclIdX, + Arity=2, + Str=<UC1(CS(CS(U)))><U>, + RULES: "SPEC shared @[]" + forall ($dMyFunctor_sHz :: MyFunctor []) + (irred_sHA :: Domain [] Int). + shared @[] $dMyFunctor_sHz irred_sHA + = $sshared_sHD] +shared + = \ (@(f_ayh :: * -> *)) + ($dMyFunctor_ayi [Dmd=UC1(CS(CS(U)))] :: MyFunctor f_ayh) + (irred_ayj :: Domain f_ayh Int) -> + let { + f_sHy :: f_ayh Int -> f_ayh Int + [LclId] + f_sHy + = ($dMyFunctor_ayi + `cast` (Foo.N:MyFunctor[0] <f_ayh>_N + :: MyFunctor f_ayh + ~R# (forall a b. + (Domain f_ayh a, Domain f_ayh b) => + (a -> b) -> f_ayh a -> f_ayh b))) + @Int @Int irred_ayj irred_ayj GHC.Num.$fNumInt_$cnegate } in + \ (x_X4N :: f_ayh Int) -> + f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + x_X4N)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +lvl_sHI :: Int +[LclId] +lvl_sHI = GHC.Types.I# 0# + +-- RHS size: {terms: 6, types: 5, coercions: 0, joins: 0/0} +foo :: [Int] -> [Int] +[LclIdX, + Arity=1, + Str=<U>, + Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) + Tmpl= \ (xs_awV [Occ=Once1] :: [Int]) -> + GHC.Base.build + @Int + (\ (@b1_aHe) + (c_aHf [Occ=Once1, OS=OneShot] :: Int -> b1_aHe -> b1_aHe) + (n_aHg [Occ=Once1, OS=OneShot] :: b1_aHe) -> + GHC.Base.foldr + @Int + @b1_aHe + (GHC.Base.mapFB @Int @b1_aHe @Int c_aHf GHC.Num.$fNumInt_$cnegate) + n_aHg + (GHC.Types.: @Int lvl_sHI xs_awV))}] +foo + = \ (xs_awV :: [Int]) -> + map + @Int + @Int + GHC.Num.$fNumInt_$cnegate + (GHC.Types.: @Int lvl_sHI xs_awV) + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +lvl_sHJ :: Int +[LclId] +lvl_sHJ = lvl_sHI + +-- RHS size: {terms: 6, types: 5, coercions: 0, joins: 0/0} +bar :: [Int] -> [Int] +[LclIdX, + Arity=1, + Str=<1U>, + Cpr=m2, + Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) + Tmpl= \ (xs_awW [Occ=Once1] :: [Int]) -> + GHC.Types.: + @Int + lvl_sHI + (GHC.Base.build + @Int + (\ (@b1_aHe) + (c_aHf [Occ=Once1, OS=OneShot] :: Int -> b1_aHe -> b1_aHe) + (n_aHg [Occ=Once1, OS=OneShot] :: b1_aHe) -> + GHC.Base.foldr + @Int + @b1_aHe + (GHC.Base.mapFB @Int @b1_aHe @Int c_aHf GHC.Num.$fNumInt_$cnegate) + n_aHg + xs_awW))}] +bar + = \ (xs_awW :: [Int]) -> + GHC.Types.: + @Int lvl_sHI (map @Int @Int GHC.Num.$fNumInt_$cnegate xs_awW) + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +$trModule_sHr :: GHC.Prim.Addr# +[LclId] +$trModule_sHr = "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +$trModule_sHs :: GHC.Types.TrName +[LclId] +$trModule_sHs = GHC.Types.TrNameS $trModule_sHr + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +$trModule_sHt :: GHC.Prim.Addr# +[LclId] +$trModule_sHt = "Foo"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +$trModule_sHu :: GHC.Types.TrName +[LclId] +$trModule_sHu = GHC.Types.TrNameS $trModule_sHt + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +Foo.$trModule :: GHC.Types.Module +[LclIdX] +Foo.$trModule = GHC.Types.Module $trModule_sHs $trModule_sHu + +-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} +$krep_aGF [InlPrag=[~]] :: GHC.Types.KindRep +[LclId] +$krep_aGF + = GHC.Types.KindRepTyConApp + GHC.Types.$tcConstraint (GHC.Types.[] @GHC.Types.KindRep) + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep_aGE [InlPrag=[~]] :: GHC.Types.KindRep +[LclId] +$krep_aGE = GHC.Types.KindRepFun GHC.Types.krep$*Arr* $krep_aGF + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +$tcMyFunctor_sHv :: GHC.Prim.Addr# +[LclId] +$tcMyFunctor_sHv = "MyFunctor"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +$tcMyFunctor_sHw :: GHC.Types.TrName +[LclId] +$tcMyFunctor_sHw = GHC.Types.TrNameS $tcMyFunctor_sHv + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +Foo.$tcMyFunctor :: GHC.Types.TyCon +[LclIdX] +Foo.$tcMyFunctor + = GHC.Types.TyCon + 12837160846121910345## + 787075802864859973## + Foo.$trModule + $tcMyFunctor_sHw + 0# + $krep_aGE + diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index 7285b91c45..3a86c3a326 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -136,7 +136,14 @@ test('T5366', test('T7796', [], makefile_test, ['T7796']) test('T5550', omit_ways(prof_ways), compile, ['']) test('T7865', normal, makefile_test, ['T7865']) -test('T7785', only_ways(['optasm']), compile, ['-ddump-rules']) + +# T7785: we want to check that we specialise 'shared'. But Tidy discards the +# rule (see Note [Trimming auto-rules] in GHC.Iface.Tidy) +# So, rather arbitrarily, we dump the output of CSE and grep for SPEC +test('T7785', [ only_ways(['optasm']), + grep_errmsg(r'SPEC') ], + compile, ['-ddump-cse']) + test('T7702', [extra_files(['T7702plugin']), only_ways([config.ghc_plugin_way]), diff --git a/testsuite/tests/simplCore/should_run/T18012.hs b/testsuite/tests/simplCore/should_run/T18012.hs index 9118b75ff4..9ce1f1fb9d 100644 --- a/testsuite/tests/simplCore/should_run/T18012.hs +++ b/testsuite/tests/simplCore/should_run/T18012.hs @@ -32,10 +32,10 @@ notRule x = x {-# INLINE [0] notRule #-} {-# RULES "notRule/False" [~0] notRule False = True #-} -f :: T -> () -> Bool -f (D a) () = notRule a +f :: () -> T -> Bool +f () (D a) = notRule a {-# INLINE [100] f #-} -- so it isn’t inlined before FloatOut g :: () -> Bool -g x = f (D False) x +g x = f x (D False) {-# NOINLINE g #-} diff --git a/testsuite/tests/stranal/should_compile/T18894b.hs b/testsuite/tests/stranal/should_compile/T18894b.hs index e90f34e3fd..99a4bf954d 100644 --- a/testsuite/tests/stranal/should_compile/T18894b.hs +++ b/testsuite/tests/stranal/should_compile/T18894b.hs @@ -17,4 +17,14 @@ f :: Int -> Int f 1 = 0 f m | odd m = eta m 2 - | otherwise = eta 2 m + | otherwise = eta m m + +{- +An earlier version of this test had (eta 2 m) in the otherwise case. +But then (eta 2) could be floated out; and indeed if 'f' is applied +many times, then sharing (eta 2) might be good. And if we inlined +eta, we certainly would share (expensive 2). + +So I made the test more robust at testing what we actually want here, +by changing to (eta m m). +-} diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs index c13447e527..7b89376fd3 100644 --- a/utils/genprimopcode/Main.hs +++ b/utils/genprimopcode/Main.hs @@ -612,18 +612,40 @@ gen_latex_doc (Info defaults entries) latex_encode ('\\':cs) = "$\\backslash$" ++ (latex_encode cs) latex_encode (c:cs) = c:(latex_encode cs) +{- Note [OPTIONS_GHC in GHC.PrimopWrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In PrimopWrappers we set some crucial GHC options + +* Eta reduction: -fno-do-eta-reduction + In PrimopWrappers we builds a wrapper for each primop, thus + plusInt# = \a b. plusInt# a b + That's a pretty odd definition, becaues it looks recursive. What + actually happens is that it makes a curried, top-level bindings for + `plusInt#`. When we compile PrimopWrappers, the code generator spots + (plusInt# a b) and generates an add instruction. + + Its very important that we don't eta-reduce this to + plusInt# = plusInt# + because then the special rule in the code generator doesn't fire. + +* Worker-wrapper: performing WW on this module is harmful even, two reasons: + 1. Inferred strictness signatures are all bottom (because of the apparent + recursion), which is a lie + 2. Doing the worker/wrapper split based on that information will + introduce references to absentError, which isn't available at + this point. + + We prevent strictness analyis and w/w by simply doing -O0. It's + a very simple module and there is no optimisation to be done +-} + gen_wrappers :: Info -> String gen_wrappers (Info _ entries) = "{-# LANGUAGE MagicHash, NoImplicitPrelude, UnboxedTuples #-}\n" -- Dependencies on Prelude must be explicit in libraries/base, but we -- don't need the Prelude here so we add NoImplicitPrelude. - ++ "{-# OPTIONS_GHC -Wno-deprecations -O0 #-}\n" - -- No point in optimising this at all. - -- Performing WW on this module is harmful even, two reasons: - -- 1. Inferred strictness signatures are all bottom, which is a lie - -- 2. Doing the worker/wrapper split based on that information will - -- introduce references to absentError, - -- which isn't available at this point. + ++ "{-# OPTIONS_GHC -Wno-deprecations -O0 -fno-do-eta-reduction #-}\n" + -- Very important OPTIONS_GHC! See Note [OPTIONS_GHC in GHC.PrimopWrappers] ++ "module GHC.PrimopWrappers where\n" ++ "import qualified GHC.Prim\n" ++ "import GHC.Tuple ()\n" |