[Git][ghc/ghc][wip/T18328] 3 commits: Improve eta-expansion using ArityType
Simon Peyton Jones
gitlab at gitlab.haskell.org
Mon Jun 22 23:17:09 UTC 2020
Simon Peyton Jones pushed to branch wip/T18328 at Glasgow Haskell Compiler / GHC
Commits:
64804dd0 by Simon Peyton Jones at 2020-06-23T00:16:59+01:00
Improve eta-expansion using ArityType
As #18355 shows, we were failing to preserve one-shot info when
eta-expanding. It's rather easy to fix, by using ArityType more,
rather than just Arity.
This patch is important to suport the one-shot monad trick;
see #18202.
- - - - -
ca1ec1f5 by Simon Peyton Jones at 2020-06-23T00:16:59+01:00
Use dumpStyle when printing inlinings
This just makes debug-printing consistent,
and more informative.
- - - - -
5294c839 by Simon Peyton Jones at 2020-06-23T00:16:59+01:00
Comments only
- - - - -
7 changed files:
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/Simplify.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Tc/Solver/Flatten.hs
- + testsuite/tests/simplCore/should_compile/T18355.hs
- + testsuite/tests/simplCore/should_compile/T18355.stderr
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -13,9 +13,12 @@
-- | Arity and eta expansion
module GHC.Core.Opt.Arity
( manifestArity, joinRhsArity, exprArity, typeArity
- , exprEtaExpandArity, findRhsArity, etaExpand
+ , exprEtaExpandArity, findRhsArity
+ , etaExpand, etaExpandAT
, etaExpandToJoinPoint, etaExpandToJoinPointRule
, exprBotStrictness_maybe
+ , ArityType(..), expandableArityType, arityTypeArity
+ , maxWithArity, isBotArityType, idArityType
)
where
@@ -42,7 +45,7 @@ import GHC.Types.Unique
import GHC.Driver.Session ( DynFlags, GeneralFlag(..), gopt )
import GHC.Utils.Outputable
import GHC.Data.FastString
-import GHC.Utils.Misc ( debugIsOn )
+import GHC.Utils.Misc ( lengthAtLeast )
{-
************************************************************************
@@ -486,8 +489,11 @@ Then f :: AT [False,False] ATop
-------------------- Main arity code ----------------------------
-}
--- See Note [ArityType]
-data ArityType = ATop [OneShotInfo] | ABot Arity
+
+data ArityType -- See Note [ArityType]
+ = ATop [OneShotInfo]
+ | ABot Arity
+ deriving( Eq )
-- There is always an explicit lambda
-- to justify the [OneShot], or the Arity
@@ -495,18 +501,45 @@ instance Outputable ArityType where
ppr (ATop os) = text "ATop" <> parens (ppr (length os))
ppr (ABot n) = text "ABot" <> parens (ppr n)
+arityTypeArity :: ArityType -> Arity
+-- The number of value args for the arity type
+arityTypeArity (ATop oss) = length oss
+arityTypeArity (ABot ar) = ar
+
+expandableArityType :: ArityType -> Bool
+-- True <=> eta-expansion will add at least one lambda
+expandableArityType (ATop oss) = not (null oss)
+expandableArityType (ABot ar) = ar /= 0
+
+isBotArityType :: ArityType -> Bool
+isBotArityType (ABot {}) = True
+isBotArityType (ATop {}) = False
+
+arityTypeOneShots :: ArityType -> [OneShotInfo]
+arityTypeOneShots (ATop oss) = oss
+arityTypeOneShots (ABot ar) = replicate ar OneShotLam
+ -- If we are diveging or throwing an exception anyway
+ -- it's fine to push redexes inside the lambdas
+
+botArityType :: ArityType
+botArityType = ABot 0 -- Unit for andArityType
+
+maxWithArity :: ArityType -> Arity -> ArityType
+maxWithArity at@(ABot {}) _ = at
+maxWithArity at@(ATop oss) ar
+ | oss `lengthAtLeast` ar = at
+ | otherwise = ATop (take ar (oss ++ repeat NoOneShotInfo))
+
vanillaArityType :: ArityType
vanillaArityType = ATop [] -- Totally uninformative
-- ^ The Arity returned is the number of value args the
-- expression can be applied to without doing much work
-exprEtaExpandArity :: DynFlags -> CoreExpr -> Arity
+exprEtaExpandArity :: DynFlags -> CoreExpr -> ArityType
-- exprEtaExpandArity is used when eta expanding
-- e ==> \xy -> e x y
exprEtaExpandArity dflags e
- = case (arityType env e) of
- ATop oss -> length oss
- ABot n -> n
+ = arityType env e
where
env = AE { ae_cheap_fn = mk_cheap_fn dflags isCheapApp
, ae_ped_bot = gopt Opt_PedanticBottoms dflags
@@ -529,7 +562,7 @@ mk_cheap_fn dflags cheap_app
----------------------
-findRhsArity :: DynFlags -> Id -> CoreExpr -> Arity -> (Arity, Bool)
+findRhsArity :: DynFlags -> Id -> CoreExpr -> Arity -> ArityType
-- This implements the fixpoint loop for arity analysis
-- See Note [Arity analysis]
-- If findRhsArity e = (n, is_bot) then
@@ -543,44 +576,34 @@ findRhsArity dflags bndr rhs old_arity
-- we stop right away (since arities should not decrease)
-- Result: the common case is that there is just one iteration
where
- is_lam = has_lam rhs
-
- has_lam (Tick _ e) = has_lam e
- has_lam (Lam b e) = isId b || has_lam e
- has_lam _ = False
-
init_cheap_app :: CheapAppFun
init_cheap_app fn n_val_args
| fn == bndr = True -- On the first pass, this binder gets infinite arity
| otherwise = isCheapApp fn n_val_args
- go :: (Arity, Bool) -> (Arity, Bool)
- go cur_info@(cur_arity, _)
- | cur_arity <= old_arity = cur_info
- | new_arity == cur_arity = cur_info
- | otherwise = ASSERT( new_arity < cur_arity )
+ go :: ArityType -> ArityType
+ go cur_atype
+ | cur_arity <= old_arity = cur_atype
+ | new_atype == cur_atype = cur_atype
+ | otherwise =
#if defined(DEBUG)
pprTrace "Exciting arity"
- (vcat [ ppr bndr <+> ppr cur_arity <+> ppr new_arity
+ (vcat [ ppr bndr <+> ppr cur_atype <+> ppr new_atype
, ppr rhs])
#endif
- go new_info
+ go new_atype
where
- new_info@(new_arity, _) = get_arity cheap_app
+ new_atype = get_arity cheap_app
+ cur_arity = arityTypeArity cur_atype
cheap_app :: CheapAppFun
cheap_app fn n_val_args
| fn == bndr = n_val_args < cur_arity
| otherwise = isCheapApp fn n_val_args
- get_arity :: CheapAppFun -> (Arity, Bool)
- get_arity cheap_app
- = case (arityType env rhs) of
- ABot n -> (n, True)
- ATop (os:oss) | isOneShotInfo os || is_lam
- -> (1 + length oss, False) -- Don't expand PAPs/thunks
- ATop _ -> (0, False) -- Note [Eta expanding thunks]
- where
+ get_arity :: CheapAppFun -> ArityType
+ get_arity cheap_app = arityType env rhs
+ where
env = AE { ae_cheap_fn = mk_cheap_fn dflags cheap_app
, ae_ped_bot = gopt Opt_PedanticBottoms dflags
, ae_joins = emptyVarSet }
@@ -613,7 +636,6 @@ write the analysis loop.
The analysis is cheap-and-cheerful because it doesn't deal with
mutual recursion. But the self-recursive case is the important one.
-
Note [Eta expanding through dictionaries]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If the experimental -fdicts-cheap flag is on, we eta-expand through
@@ -632,24 +654,6 @@ The (foo DInt) is floated out, and makes ineffective a RULE
One could go further and make exprIsCheap reply True to any
dictionary-typed expression, but that's more work.
-
-Note [Eta expanding thunks]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We don't eta-expand
- * Trivial RHSs x = y
- * PAPs x = map g
- * Thunks f = case y of p -> \x -> blah
-
-When we see
- f = case y of p -> \x -> blah
-should we eta-expand it? Well, if 'x' is a one-shot state token
-then 'yes' because 'f' will only be applied once. But otherwise
-we (conservatively) say no. My main reason is to avoid expanding
-PAPSs
- f = g d ==> f = \x. g d x
-because that might in turn make g inline (if it has an inline pragma),
-which we might not want. After all, INLINE pragmas say "inline only
-when saturated" so we don't want to be too gung-ho about saturating!
-}
arityLam :: Id -> ArityType -> ArityType
@@ -673,6 +677,7 @@ arityApp (ATop []) _ = ATop []
arityApp (ATop (_:as)) cheap = floatIn cheap (ATop as)
andArityType :: ArityType -> ArityType -> ArityType -- Used for branches of a 'case'
+-- This is least upper bound in the ArityType lattice
andArityType (ABot n1) (ABot n2) = ABot (n1 `max` n2) -- Note [ABot branches: use max]
andArityType (ATop as) (ABot _) = ATop as
andArityType (ABot _) (ATop bs) = ATop bs
@@ -754,8 +759,7 @@ arityType :: ArityEnv -> CoreExpr -> ArityType
arityType env (Cast e co)
= case arityType env e of
- ATop os -> ATop (take co_arity os)
- -- See Note [Arity trimming]
+ ATop os -> ATop (take co_arity os) -- See Note [Arity trimming]
ABot n | co_arity < n -> ATop (replicate co_arity noOneShotInfo)
| otherwise -> ABot n
where
@@ -769,19 +773,9 @@ arityType env (Cast e co)
arityType env (Var v)
| v `elemVarSet` ae_joins env
- = ABot 0 -- See Note [Eta-expansion and join points]
-
- | strict_sig <- idStrictness v
- , not $ isTopSig strict_sig
- , (ds, res) <- splitStrictSig strict_sig
- , let arity = length ds
- = if isDeadEndDiv res then ABot arity
- else ATop (take arity one_shots)
+ = botArityType -- See Note [Eta-expansion and join points]
| otherwise
- = ATop (take (idArity v) one_shots)
- where
- one_shots :: [OneShotInfo] -- One-shot-ness derived from the type
- one_shots = typeArity (idType v)
+ = idArityType v
-- Lambdas; increase arity
arityType env (Lam x e)
@@ -804,13 +798,13 @@ arityType env (App fun arg )
--
arityType env (Case scrut _ _ alts)
| exprIsDeadEnd scrut || null alts
- = ABot 0 -- Do not eta expand
- -- See Note [Dealing with bottom (1)]
+ = botArityType -- Do not eta expand
+ -- See Note [Dealing with bottom (1)]
| otherwise
= case alts_type of
- ABot n | n>0 -> ATop [] -- Don't eta expand
- | otherwise -> ABot 0 -- if RHS is bottomming
- -- See Note [Dealing with bottom (2)]
+ ABot n | n>0 -> ATop [] -- Don't eta expand
+ | otherwise -> botArityType -- if RHS is bottomming
+ -- See Note [Dealing with bottom (2)]
ATop as | not (ae_ped_bot env) -- See Note [Dealing with bottom (3)]
, ae_cheap_fn env scrut Nothing -> ATop as
@@ -886,7 +880,8 @@ So we do this:
body of the let.
* Dually, when we come to a /call/ of a join point, just no-op
- by returning (ABot 0), the neutral element of ArityType.
+ by returning botArityType, the bottom element of ArityType,
+ which so that: bot `andArityType` x = x
* This works if the join point is bound in the expression we are
taking the arityType of. But if it's bound further out, it makes
@@ -905,6 +900,20 @@ An alternative (roughly equivalent) idea would be to carry an
environment mapping let-bound Ids to their ArityType.
-}
+idArityType :: Id -> ArityType
+idArityType v
+ | strict_sig <- idStrictness v
+ , not $ isTopSig strict_sig
+ , (ds, res) <- splitStrictSig strict_sig
+ , let arity = length ds
+ = if isDeadEndDiv res then ABot arity
+ else ATop (take arity one_shots)
+ | otherwise
+ = ATop (take (idArity v) one_shots)
+ where
+ one_shots :: [OneShotInfo] -- One-shot-ness derived from the type
+ one_shots = typeArity (idType v)
+
{-
%************************************************************************
%* *
@@ -1001,6 +1010,25 @@ which we want to lead to code like
This means that we need to look through type applications and be ready
to re-add floats on the top.
+Note [Eta expansion with ArityType]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The etaExpandAT function takes an ArityType (not just an Arity) to
+guide eta-expansion. Why? Because we want to preserve one-shot info.
+Consider
+ foo = \x. case x of
+ True -> (\s{os}. blah) |> co
+ False -> wubble
+We'll get an ArityType for foo of (ATop [NoOneShot,OneShot]).
+
+Then we want to eta-expand to
+ 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{osf}. By expanding with the
+ArityType gotten from analysing the RHS, we achieve this neatly.
+
+This makes a big difference to the one-shot monad trick;
+see Note [The one-shot state monad trick] in GHC.Core.Unify.
-}
-- | @etaExpand n e@ returns an expression with
@@ -1013,11 +1041,16 @@ to re-add floats on the top.
-- We should have that:
--
-- > ty = exprType e = exprType e'
-etaExpand :: Arity -- ^ Result should have this number of value args
- -> CoreExpr -- ^ Expression to expand
- -> CoreExpr
+etaExpand :: Arity -> CoreExpr -> CoreExpr
+etaExpandAT :: ArityType -> CoreExpr -> CoreExpr
+
+etaExpand n orig_expr = eta_expand (replicate n NoOneShotInfo) orig_expr
+etaExpandAT at orig_expr = eta_expand (arityTypeOneShots at) orig_expr
+ -- See Note [Eta expansion with ArityType]
+
-- etaExpand arity e = res
-- Then 'res' has at least 'arity' lambdas at the top
+-- See Note [Eta expansion with ArityType]
--
-- etaExpand deals with for-alls. For example:
-- etaExpand 1 E
@@ -1028,21 +1061,23 @@ etaExpand :: Arity -- ^ Result should have this number of value arg
-- It deals with coerces too, though they are now rare
-- so perhaps the extra code isn't worth it
-etaExpand n orig_expr
- = go n orig_expr
+eta_expand :: [OneShotInfo] -> CoreExpr -> CoreExpr
+eta_expand one_shots orig_expr
+ = go one_shots orig_expr
where
-- Strip off existing lambdas and casts before handing off to mkEtaWW
-- Note [Eta expansion and SCCs]
- go 0 expr = expr
- go n (Lam v body) | isTyVar v = Lam v (go n body)
- | otherwise = Lam v (go (n-1) body)
- go n (Cast expr co) = Cast (go n expr) co
- go n expr
+ go [] expr = expr
+ go oss@(_:oss1) (Lam v body) | isTyVar v = Lam v (go oss body)
+ | otherwise = Lam v (go oss1 body)
+ go oss (Cast expr co) = Cast (go oss expr) co
+
+ go oss expr
= -- pprTrace "ee" (vcat [ppr orig_expr, ppr expr, ppr etas]) $
retick $ etaInfoAbs etas (etaInfoApp subst' sexpr etas)
where
in_scope = mkInScopeSet (exprFreeVars expr)
- (in_scope', etas) = mkEtaWW n (ppr orig_expr) in_scope (exprType expr)
+ (in_scope', etas) = mkEtaWW oss (ppr orig_expr) in_scope (exprType expr)
subst' = mkEmptySubst in_scope'
-- Find ticks behind type apps.
@@ -1141,7 +1176,7 @@ etaInfoAppTy _ (EtaCo co : eis) = etaInfoAppTy (coercionRKind co) eis
-- semantically-irrelevant source annotations, so call sites must take care to
-- preserve that info. See Note [Eta expansion and SCCs].
mkEtaWW
- :: Arity
+ :: [OneShotInfo]
-- ^ How many value arguments to eta-expand
-> SDoc
-- ^ The pretty-printed original expression, for warnings.
@@ -1153,36 +1188,29 @@ mkEtaWW
-- The outgoing 'InScopeSet' extends the incoming 'InScopeSet' with the
-- fresh variables in 'EtaInfo'.
-mkEtaWW orig_n ppr_orig_expr in_scope orig_ty
- = go orig_n empty_subst orig_ty []
+mkEtaWW orig_oss ppr_orig_expr in_scope orig_ty
+ = go 0 orig_oss empty_subst orig_ty []
where
empty_subst = mkEmptyTCvSubst in_scope
- go :: Arity -- Number of value args to expand to
+ go :: Int -- For fresh names
+ -> [OneShotInfo] -- Number of value args to expand to
-> TCvSubst -> Type -- We are really looking at subst(ty)
-> [EtaInfo] -- Accumulating parameter
-> (InScopeSet, [EtaInfo])
- go n subst ty eis -- See Note [exprArity invariant]
-
+ go _ [] subst _ eis -- See Note [exprArity invariant]
----------- Done! No more expansion needed
- | n == 0
= (getTCvInScope subst, reverse eis)
+ go n oss@(one_shot:oss1) subst ty eis -- See Note [exprArity invariant]
----------- Forall types (forall a. ty)
| Just (tcv,ty') <- splitForAllTy_maybe ty
- , let (subst', tcv') = Type.substVarBndr subst tcv
- = let ((n_subst, n_tcv), n_n)
- -- We want to have at least 'n' lambdas at the top.
- -- If tcv is a tyvar, it corresponds to one Lambda (/\).
- -- And we won't reduce n.
- -- If tcv is a covar, we could eta-expand the expr with one
- -- lambda \co:ty. e co. In this case we generate a new variable
- -- of the coercion type, update the scope, and reduce n by 1.
- | isTyVar tcv = ((subst', tcv'), n)
- -- covar case:
- | otherwise = (freshEtaId n subst' (unrestricted (varType tcv')), n-1)
- -- Avoid free vars of the original expression
- in go n_n n_subst ty' (EtaVar n_tcv : eis)
+ , (subst', tcv') <- Type.substVarBndr subst tcv
+ , let oss' | isTyVar tcv = oss
+ | otherwise = oss1
+ -- A forall can bind a CoVar, in which case
+ -- we consume one of the [OneShotInfo]
+ = go n oss' subst' ty' (EtaVar tcv' : eis)
----------- Function types (t1 -> t2)
| Just (mult, arg_ty, res_ty) <- splitFunTy_maybe ty
@@ -1190,9 +1218,11 @@ mkEtaWW orig_n ppr_orig_expr in_scope orig_ty
-- See Note [Levity polymorphism invariants] in GHC.Core
-- See also test case typecheck/should_run/EtaExpandLevPoly
- , let (subst', eta_id') = freshEtaId n subst (Scaled mult arg_ty)
- -- Avoid free vars of the original expression
- = go (n-1) subst' res_ty (EtaVar eta_id' : eis)
+ , (subst', eta_id) <- freshEtaId n subst (Scaled mult arg_ty)
+ -- Avoid free vars of the original expression
+
+ , let eta_id' = eta_id `setIdOneShotInfo` one_shot
+ = go (n+1) oss1 subst' res_ty (EtaVar eta_id' : eis)
----------- Newtypes
-- Given this:
@@ -1206,12 +1236,12 @@ mkEtaWW orig_n ppr_orig_expr in_scope orig_ty
-- Remember to apply the substitution to co (#16979)
-- (or we could have applied to ty, but then
-- we'd have had to zap it for the recursive call)
- = go n subst ty' (pushCoercion co' eis)
+ = go n oss subst ty' (pushCoercion co' eis)
| otherwise -- We have an expression of arity > 0,
-- but its type isn't a function, or a binder
-- is levity-polymorphic
- = WARN( True, (ppr orig_n <+> ppr orig_ty) $$ ppr_orig_expr )
+ = WARN( True, (ppr orig_oss <+> ppr orig_ty) $$ ppr_orig_expr )
(getTCvInScope subst, reverse eis)
-- This *can* legitimately happen:
-- e.g. coerce Int (\x. x) Essentially the programmer is
=====================================
compiler/GHC/Core/Opt/Simplify.hs
=====================================
@@ -46,7 +46,8 @@ import GHC.Core.Ppr ( pprCoreExpr )
import GHC.Types.Unique ( hasKey )
import GHC.Core.Unfold
import GHC.Core.Utils
-import GHC.Core.Opt.Arity ( etaExpand )
+import GHC.Core.Opt.Arity ( ArityType(..), arityTypeArity, isBotArityType
+ , idArityType, etaExpandAT )
import GHC.Core.SimpleOpt ( pushCoTyArg, pushCoValArg
, joinPointBinding_maybe, joinPointBindings_maybe )
import GHC.Core.FVs ( mkRuleInfo )
@@ -706,10 +707,10 @@ makeTrivialBinding mode top_lvl occ_fs info expr expr_ty
-- Now something very like completeBind,
-- but without the postInlineUnconditionally part
- ; (arity, is_bot, expr2) <- tryEtaExpandRhs mode var expr1
+ ; (arity_type, expr2) <- tryEtaExpandRhs mode var expr1
; unf <- mkLetUnfolding (sm_dflags mode) top_lvl InlineRhs var expr2
- ; let final_id = addLetBndrInfo var arity is_bot unf
+ ; let final_id = addLetBndrInfo var arity_type unf
bind = NonRec final_id expr2
; return ( floats `addLetFlts` unitLetFloat bind, final_id ) }
@@ -799,14 +800,13 @@ completeBind env top_lvl mb_cont old_bndr new_bndr new_rhs
-- Do eta-expansion on the RHS of the binding
-- See Note [Eta-expanding at let bindings] in GHC.Core.Opt.Simplify.Utils
- ; (new_arity, is_bot, final_rhs) <- tryEtaExpandRhs (getMode env)
- new_bndr new_rhs
+ ; (new_arity, final_rhs) <- tryEtaExpandRhs (getMode env) new_bndr new_rhs
-- Simplify the unfolding
; new_unfolding <- simplLetUnfolding env top_lvl mb_cont old_bndr
final_rhs (idType new_bndr) new_arity old_unf
- ; let final_bndr = addLetBndrInfo new_bndr new_arity is_bot new_unfolding
+ ; let final_bndr = addLetBndrInfo new_bndr new_arity new_unfolding
-- See Note [In-scope set as a substitution]
; if postInlineUnconditionally env top_lvl final_bndr occ_info final_rhs
@@ -823,10 +823,13 @@ completeBind env top_lvl mb_cont old_bndr new_bndr new_rhs
-- pprTrace "Binding" (ppr final_bndr <+> ppr new_unfolding) $
return (mkFloatBind env (NonRec final_bndr final_rhs)) }
-addLetBndrInfo :: OutId -> Arity -> Bool -> Unfolding -> OutId
-addLetBndrInfo new_bndr new_arity is_bot new_unf
+addLetBndrInfo :: OutId -> ArityType -> Unfolding -> OutId
+addLetBndrInfo new_bndr new_arity_type new_unf
= new_bndr `setIdInfo` info5
where
+ new_arity = arityTypeArity new_arity_type
+ is_bot = isBotArityType new_arity_type
+
info1 = idInfo new_bndr `setArityInfo` new_arity
-- Unfolding info: Note [Setting the new unfolding]
@@ -844,12 +847,13 @@ addLetBndrInfo new_bndr new_arity is_bot new_unf
= info2
-- Bottoming bindings: see Note [Bottoming bindings]
- info4 | is_bot = info3
- `setStrictnessInfo`
- mkClosedStrictSig (replicate new_arity topDmd) botDiv
- `setCprInfo` mkCprSig new_arity botCpr
+ info4 | is_bot = info3 `setStrictnessInfo` bot_sig
+ `setCprInfo` bot_cpr
| otherwise = info3
+ bot_sig = mkClosedStrictSig (replicate new_arity topDmd) botDiv
+ bot_cpr = mkCprSig new_arity botCpr
+
-- Zap call arity info. We have used it by now (via
-- `tryEtaExpandRhs`), and the simplifier can invalidate this
-- information, leading to broken code later (e.g. #13479)
@@ -860,9 +864,9 @@ addLetBndrInfo new_bndr new_arity is_bot new_unf
~~~~~~~~~~~~~~~~~~~~~~~~
Generally speaking the arity of a binding should not decrease. But it *can*
legitimately happen because of RULES. Eg
- f = g Int
+ f = g @Int
where g has arity 2, will have arity 2. But if there's a rewrite rule
- g Int --> h
+ g @Int --> h
where h has arity 1, then f's arity will decrease. Here's a real-life example,
which is in the output of Specialise:
@@ -892,7 +896,7 @@ Then we'd like to drop the dead <alts> immediately. So it's good to
propagate the info that x's RHS is bottom to x's IdInfo as rapidly as
possible.
-We use tryEtaExpandRhs on every binding, and it turns ou that the
+We use tryEtaExpandRhs on every binding, and it turns out that the
arity computation it performs (via GHC.Core.Opt.Arity.findRhsArity) already
does a simple bottoming-expression analysis. So all we need to do
is propagate that info to the binder's IdInfo.
@@ -1550,7 +1554,7 @@ simplLamBndr env bndr
| isId bndr && hasCoreUnfolding old_unf -- Special case
= do { (env1, bndr1) <- simplBinder env bndr
; unf' <- simplStableUnfolding env1 NotTopLevel Nothing bndr
- (idType bndr1) (idArity bndr1) old_unf
+ (idType bndr1) (idArityType bndr1) old_unf
; let bndr2 = bndr1 `setIdUnfolding` unf'
; return (modifyInScope env1 bndr2, bndr2) }
@@ -1928,7 +1932,7 @@ completeCall env var cont
log_inlining doc
= liftIO $ dumpAction dflags
- (mkUserStyle alwaysQualify AllTheWay)
+ (mkDumpStyle alwaysQualify)
(dumpOptionsFromFlag Opt_D_dump_inlinings)
"" FormatText doc
@@ -3734,7 +3738,7 @@ because we don't know its usage in each RHS separately
simplLetUnfolding :: SimplEnv-> TopLevelFlag
-> MaybeJoinCont
-> InId
- -> OutExpr -> OutType -> Arity
+ -> OutExpr -> OutType -> ArityType
-> Unfolding -> SimplM Unfolding
simplLetUnfolding env top_lvl cont_mb id new_rhs rhs_ty arity unf
| isStableUnfolding unf
@@ -3764,7 +3768,9 @@ mkLetUnfolding dflags top_lvl src id new_rhs
simplStableUnfolding :: SimplEnv -> TopLevelFlag
-> MaybeJoinCont -- Just k => a join point with continuation k
-> InId
- -> OutType -> Arity -> Unfolding
+ -> OutType
+ -> ArityType -- Used to eta expand, but only for non-join-points
+ -> Unfolding
->SimplM Unfolding
-- Note [Setting the new unfolding]
simplStableUnfolding env top_lvl mb_cont id rhs_ty id_arity unf
@@ -3827,7 +3833,7 @@ simplStableUnfolding env top_lvl mb_cont id rhs_ty id_arity unf
eta_expand expr
| not eta_on = expr
| exprIsTrivial expr = expr
- | otherwise = etaExpand id_arity expr
+ | otherwise = etaExpandAT id_arity expr
eta_on = sm_eta_expand (getMode env)
{- Note [Eta-expand stable unfoldings]
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -1478,9 +1478,9 @@ mkLam env bndrs body cont
, sm_eta_expand (getMode env)
, any isRuntimeVar bndrs
, let body_arity = exprEtaExpandArity dflags body
- , body_arity > 0
+ , expandableArityType body_arity
= do { tick (EtaExpansion (head bndrs))
- ; let res = mkLams bndrs (etaExpand body_arity body)
+ ; let res = mkLams bndrs (etaExpandAT body_arity body)
; traceSmpl "eta expand" (vcat [text "before" <+> ppr (mkLams bndrs body)
, text "after" <+> ppr res])
; return res }
@@ -1550,7 +1550,7 @@ because the latter is not well-kinded.
-}
tryEtaExpandRhs :: SimplMode -> OutId -> OutExpr
- -> SimplM (Arity, Bool, OutExpr)
+ -> SimplM (ArityType, OutExpr)
-- See Note [Eta-expanding at let bindings]
-- If tryEtaExpandRhs rhs = (n, is_bot, rhs') then
-- (a) rhs' has manifest arity n
@@ -1558,40 +1558,46 @@ tryEtaExpandRhs :: SimplMode -> OutId -> OutExpr
tryEtaExpandRhs mode bndr rhs
| Just join_arity <- isJoinId_maybe bndr
= do { let (join_bndrs, join_body) = collectNBinders join_arity rhs
- ; return (count isId join_bndrs, exprIsDeadEnd join_body, rhs) }
+ oss = [idOneShotInfo id | id <- join_bndrs, isId id]
+ arity_type | exprIsDeadEnd join_body = ABot (length oss)
+ | otherwise = ATop oss
+ ; return (arity_type, rhs) }
-- Note [Do not eta-expand join points]
-- But do return the correct arity and bottom-ness, because
-- these are used to set the bndr's IdInfo (#15517)
-- Note [Invariants on join points] invariant 2b, in GHC.Core
+ | sm_eta_expand mode -- Provided eta-expansion is on
+ , new_arity > old_arity -- And the current manifest arity isn't enough
+ , want_eta rhs
+ = do { tick (EtaExpansion bndr)
+ ; return (arity_type, etaExpandAT arity_type rhs) }
+
| otherwise
- = do { (new_arity, is_bot, new_rhs) <- try_expand
+ = return (arity_type, rhs)
- ; WARN( new_arity < old_id_arity,
- (text "Arity decrease:" <+> (ppr bndr <+> ppr old_id_arity
- <+> ppr old_arity <+> ppr new_arity) $$ ppr new_rhs) )
- -- Note [Arity decrease] in GHC.Core.Opt.Simplify
- return (new_arity, is_bot, new_rhs) }
where
- try_expand
- | exprIsTrivial rhs -- See Note [Do not eta-expand trivial expressions]
- = return (exprArity rhs, False, rhs)
-
- | sm_eta_expand mode -- Provided eta-expansion is on
- , new_arity > old_arity -- And the current manifest arity isn't enough
- = do { tick (EtaExpansion bndr)
- ; return (new_arity, is_bot, etaExpand new_arity rhs) }
-
- | otherwise
- = return (old_arity, is_bot && new_arity == old_arity, rhs)
-
- dflags = sm_dflags mode
- old_arity = exprArity rhs -- See Note [Do not expand eta-expand PAPs]
- old_id_arity = idArity bndr
-
- (new_arity1, is_bot) = findRhsArity dflags bndr rhs old_arity
- new_arity2 = idCallArity bndr
- new_arity = max new_arity1 new_arity2
+ dflags = sm_dflags mode
+ old_arity = exprArity rhs
+
+ arity_type = findRhsArity dflags bndr rhs old_arity
+ `maxWithArity` idCallArity bndr
+ 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
+-}
{-
Note [Eta-expanding at let bindings]
@@ -1618,14 +1624,53 @@ because then 'genMap' will inline, and it really shouldn't: at least
as far as the programmer is concerned, it's not applied to two
arguments!
-Note [Do not eta-expand trivial expressions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Do not eta-expand a trivial RHS like
- f = g
-If we eta expand do
- f = \x. g x
-we'll just eta-reduce again, and so on; so the
-simplifier never terminates.
+Note [Which RHSs do we eta-expand?]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We don't eta-expand:
+
+* Trivial RHSs, e.g. f = g
+ If we eta expand do
+ f = \x. g x
+ we'll just eta-reduce again, and so on; so the
+ simplifier never terminates.
+
+* PAPs: see Note [Do not eta-expand PAPs]
+
+What about things like this?
+ f = case y of p -> \x -> blah
+
+Here we do eta-expand. This is a change (Jun 20), but if we have
+really decided that f has arity 1, then putting that lambda at the top
+seems like a Good idea.
+
+Note [Do not eta-expand PAPs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We used to have old_arity = manifestArity rhs, which meant that we
+would eta-expand even PAPs. But this gives no particular advantage,
+and can lead to a massive blow-up in code size, exhibited by #9020.
+Suppose we have a PAP
+ foo :: IO ()
+ foo = returnIO ()
+Then we can eta-expand do
+ foo = (\eta. (returnIO () |> sym g) eta) |> g
+where
+ g :: IO () ~ State# RealWorld -> (# State# RealWorld, () #)
+
+But there is really no point in doing this, and it generates masses of
+coercions and whatnot that eventually disappear again. For T9020, GHC
+allocated 6.6G before, and 0.8G afterwards; and residency dropped from
+1.8G to 45M.
+
+Moreover, if we eta expand
+ f = g d ==> f = \x. g d x
+that might in turn make g inline (if it has an inline pragma), which
+we might not want. After all, INLINE pragmas say "inline only when
+saturated" so we don't want to be too gung-ho about saturating!
+
+But note that this won't eta-expand, say
+ f = \g -> map g
+Does it matter not eta-expanding such functions? I'm not sure. Perhaps
+strictness analysis will have less to bite on?
Note [Do not eta-expand join points]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1666,29 +1711,6 @@ CorePrep comes around, the code is very likely to look more like this:
$j2 = if n > 0 then $j1
else (...) eta
-Note [Do not eta-expand PAPs]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We used to have old_arity = manifestArity rhs, which meant that we
-would eta-expand even PAPs. But this gives no particular advantage,
-and can lead to a massive blow-up in code size, exhibited by #9020.
-Suppose we have a PAP
- foo :: IO ()
- foo = returnIO ()
-Then we can eta-expand do
- foo = (\eta. (returnIO () |> sym g) eta) |> g
-where
- g :: IO () ~ State# RealWorld -> (# State# RealWorld, () #)
-
-But there is really no point in doing this, and it generates masses of
-coercions and whatnot that eventually disappear again. For T9020, GHC
-allocated 6.6G before, and 0.8G afterwards; and residency dropped from
-1.8G to 45M.
-
-But note that this won't eta-expand, say
- f = \g -> map g
-Does it matter not eta-expanding such functions? I'm not sure. Perhaps
-strictness analysis will have less to bite on?
-
************************************************************************
* *
=====================================
compiler/GHC/Tc/Solver/Flatten.hs
=====================================
@@ -954,8 +954,11 @@ faster. This doesn't seem quite worth it, yet.
Note [flatten_exact_fam_app_fully performance]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-The refactor of GRefl seems to cause performance trouble for T9872x: the allocation of flatten_exact_fam_app_fully_performance increased. See note [Generalized reflexive coercion] in GHC.Core.TyCo.Rep for more information about GRefl and #15192 for the current state.
+The refactor of GRefl seems to cause performance trouble for T9872x:
+the allocation of flatten_exact_fam_app_fully_performance
+increased. See note [Generalized reflexive coercion] in
+GHC.Core.TyCo.Rep for more information about GRefl and #15192 for the
+current state.
The explicit pattern match in homogenise_result helps with T9872a, b, c.
=====================================
testsuite/tests/simplCore/should_compile/T18355.hs
=====================================
@@ -0,0 +1,9 @@
+module T18355 where
+
+import GHC.Exts
+
+-- I expect the simplified Core to have an eta-expaned
+-- defn of f, with a OneShot on the final lambda-binder
+f x b = case b of
+ True -> oneShot (\y -> x+y)
+ False -> \y -> x-y
=====================================
testsuite/tests/simplCore/should_compile/T18355.stderr
=====================================
@@ -0,0 +1,70 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+ = {terms: 32, types: 23, coercions: 0, joins: 0/0}
+
+-- RHS size: {terms: 17, types: 10, coercions: 0, joins: 0/0}
+f :: forall {a}. Num a => a -> Bool -> a -> a
+[GblId,
+ Arity=4,
+ Str=<S,1*U(1*C1(C1(U)),1*C1(C1(U)),A,A,A,A,A)><L,U><S,1*U><L,U>,
+ Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True,
+ Guidance=ALWAYS_IF(arity=4,unsat_ok=True,boring_ok=False)
+ Tmpl= \ (@a)
+ ($dNum [Occ=Once*] :: Num a)
+ (x [Occ=Once*] :: a)
+ (b [Occ=Once!] :: Bool)
+ (eta [Occ=Once*, OS=OneShot] :: a) ->
+ case b of {
+ False -> - @a $dNum x eta;
+ True -> + @a $dNum x eta
+ }}]
+f = \ (@a)
+ ($dNum :: Num a)
+ (x :: a)
+ (b :: Bool)
+ (eta [OS=OneShot] :: a) ->
+ case b of {
+ False -> - @a $dNum x eta;
+ True -> + @a $dNum x eta
+ }
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T18355.$trModule4 :: Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+T18355.$trModule4 = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T18355.$trModule3 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+T18355.$trModule3 = GHC.Types.TrNameS T18355.$trModule4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T18355.$trModule2 :: Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+T18355.$trModule2 = "T18355"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T18355.$trModule1 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+T18355.$trModule1 = GHC.Types.TrNameS T18355.$trModule2
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T18355.$trModule :: GHC.Types.Module
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}]
+T18355.$trModule
+ = GHC.Types.Module T18355.$trModule3 T18355.$trModule1
+
+
+
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -329,3 +329,4 @@ test('T18231', [ only_ways(['optasm']), grep_errmsg(r'^[\w\.]+ ::.*->.*') ], com
test('T17673', [ only_ways(['optasm']), grep_errmsg(r'^\w+\.\$wf') ], compile, ['-ddump-simpl -dsuppress-uniques -dppr-cols=9999'])
test('T18078', [ only_ways(['optasm']), grep_errmsg(r'^\w+\.\$wf') ], compile, ['-ddump-simpl -dsuppress-uniques -dppr-cols=9999'])
test('T18328', [ only_ways(['optasm']), grep_errmsg(r'Arity=') ], compile, ['-ddump-simpl -dsuppress-uniques'])
+test('T18355', [ grep_errmsg(r'OneShot') ], compile, ['-O -ddump-simpl -dsuppress-uniques'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/82f1e3a4e47ce89c0887d0c3a46be77f5e9780de...5294c83960bd868d7e82114ca34bbf7d3b1a8153
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/82f1e3a4e47ce89c0887d0c3a46be77f5e9780de...5294c83960bd868d7e82114ca34bbf7d3b1a8153
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200622/e957e34b/attachment-0001.html>
More information about the ghc-commits
mailing list