[Git][ghc/ghc][wip/T13253] This patch addresses the exponential blow-up in the simplifier.
Simon Peyton Jones
gitlab at gitlab.haskell.org
Mon Jun 22 23:20:04 UTC 2020
Simon Peyton Jones pushed to branch wip/T13253 at Glasgow Haskell Compiler / GHC
Commits:
a6247763 by Simon Peyton Jones at 2020-06-23T00:19:31+01:00
This patch addresses the exponential blow-up in the simplifier.
Specifically:
#13253 exponential inlining
#10421 ditto
#18140 strict constructors
#18282 another nested-function call case
This patch makes two significant changes:
1. For Ids that are used at most once in each branch of a case,
make the occurrence analyser record the total number of
syntactic occurrences. Then in postInlineUnconditionally
use that info to avoid inling something many many times.
Actual changes:
* See the occ_n_br field of OneOcc.
* postInlineUnconditionally
See Note [Suppress exponential blowup] in GHC.Core.Opt.Simplify.Utils
2. Change the way that mkDupableCont handles StrictArg.
The details are explained in GHC.Core.Opt.Simplify
Note [Duplicating StrictArg]
Current nofib run
Program Size Allocs Runtime Elapsed TotalMem
--------------------------------------------------------------------------------
VS -0.3% +115.9% +12.1% +11.2% 0.0%
boyer2 -0.3% +10.0% +3.5% +4.0% 0.0%
cryptarithm2 -0.3% +39.0% +16.6% +16.1% 0.0%
gamteb -0.3% +4.1% -0.0% +0.4% 0.0%
last-piece -0.3% +1.4% -1.1% -0.4% 0.0%
mate -0.4% -11.1% -8.5% -9.0% 0.0%
multiplier -0.3% -2.2% -1.5% -1.5% 0.0%
transform -0.3% +3.4% +0.5% +0.8% 0.0%
--------------------------------------------------------------------------------
Min -0.8% -11.1% -8.5% -9.0% 0.0%
Max -0.3% +115.9% +30.1% +26.4% 0.0%
Geometric Mean -0.3% +1.0% +1.0% +1.0% -0.0%
Should investigate these numbers.
But the tickets are indeed cured, I think.
- - - - -
14 changed files:
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Core/Opt/Simplify.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Types/Basic.hs
- compiler/GHC/Types/Id/Info.hs
- + testsuite/tests/perf/compiler/T10421.hs
- + testsuite/tests/perf/compiler/T10421_Form.hs
- + testsuite/tests/perf/compiler/T10421_Y.hs
- + testsuite/tests/perf/compiler/T13253-spj.hs
- + testsuite/tests/perf/compiler/T13253.hs
- + testsuite/tests/perf/compiler/T18140.hs
- testsuite/tests/perf/compiler/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -832,7 +832,7 @@ occAnalNonRecBind env lvl imp_rule_edges bndr rhs body_usage
certainly_inline -- See Note [Cascading inlines]
= case occ of
- OneOcc { occ_in_lam = NotInsideLam, occ_one_br = InOneBranch }
+ OneOcc { occ_in_lam = NotInsideLam, occ_n_br = 1 }
-> active && not_stable
_ -> False
@@ -2563,7 +2563,7 @@ mkOneOcc id int_cxt arity
= emptyDetails
where
occ_info = OneOcc { occ_in_lam = NotInsideLam
- , occ_one_br = InOneBranch
+ , occ_n_br = oneBranch
, occ_int_cxt = int_cxt
, occ_tail = AlwaysTailCalled arity }
@@ -2967,11 +2967,15 @@ addOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )
-- (orOccInfo orig new) is used
-- when combining occurrence info from branches of a case
-orOccInfo (OneOcc { occ_in_lam = in_lam1, occ_int_cxt = int_cxt1
- , occ_tail = tail1 })
- (OneOcc { occ_in_lam = in_lam2, occ_int_cxt = int_cxt2
- , occ_tail = tail2 })
- = OneOcc { occ_one_br = MultipleBranches -- because it occurs in both branches
+orOccInfo (OneOcc { occ_in_lam = in_lam1
+ , occ_n_br = nbr1
+ , occ_int_cxt = int_cxt1
+ , occ_tail = tail1 })
+ (OneOcc { occ_in_lam = in_lam2
+ , occ_n_br = nbr2
+ , occ_int_cxt = int_cxt2
+ , occ_tail = tail2 })
+ = OneOcc { occ_n_br = nbr1 + nbr2
, occ_in_lam = in_lam1 `mappend` in_lam2
, occ_int_cxt = int_cxt1 `mappend` int_cxt2
, occ_tail = tail1 `andTailCallInfo` tail2 }
=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -658,8 +658,8 @@ lvlMFE env strict_ctxt e@(_, AnnCase {})
lvlMFE env strict_ctxt ann_expr
| floatTopLvlOnly env && not (isTopLvl dest_lvl)
-- Only floating to the top level is allowed.
- || anyDVarSet isJoinId fvs -- If there is a free join, don't float
- -- See Note [Free join points]
+ || hasFreeJoin env fvs -- If there is a free join, don't float
+ -- See Note [Free join points]
|| isExprLevPoly expr
-- We can't let-bind levity polymorphic expressions
-- See Note [Levity polymorphism invariants] in GHC.Core
@@ -755,6 +755,14 @@ lvlMFE env strict_ctxt ann_expr
&& floatConsts env
&& (not strict_ctxt || is_bot || exprIsHNF expr)
+hasFreeJoin :: LevelEnv -> DVarSet -> Bool
+-- Has a free join point which is not being floated to top level.
+-- (In the latter case it won't be a join point any more.)
+-- Not treating top-level ones specially had a massive effect
+-- on nofib/minimax/Prog.prog
+hasFreeJoin env fvs
+ = not (maxFvLevel isJoinId env fvs == tOP_LEVEL)
+
isBottomThunk :: Maybe (Arity, s) -> Bool
-- See Note [Bottoming floats] (2)
isBottomThunk (Just (0, _)) = True -- Zero arity
=====================================
compiler/GHC/Core/Opt/Simplify.hs
=====================================
@@ -664,13 +664,6 @@ prepareRhs mode top_lvl occ rhs0
go _ other
= return (False, emptyLetFloats, other)
-makeTrivialArg :: SimplMode -> ArgSpec -> SimplM (LetFloats, ArgSpec)
-makeTrivialArg mode arg@(ValArg { as_arg = e })
- = do { (floats, e') <- makeTrivial mode NotTopLevel (fsLit "arg") e
- ; return (floats, arg { as_arg = e' }) }
-makeTrivialArg _ arg
- = return (emptyLetFloats, arg) -- CastBy, TyArg
-
makeTrivial :: SimplMode -> TopLevelFlag
-> FastString -- ^ A "friendly name" to build the new binder from
-> OutExpr -- ^ This expression satisfies the let/app invariant
@@ -3323,9 +3316,11 @@ mkDupableCont env (TickIt t cont)
mkDupableCont env (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs
, sc_body = body, sc_env = se, sc_cont = cont})
- -- See Note [Duplicating StrictBind]
+-- See Note [Duplicating StrictBind]
+-- K[ let x = <> in b ] --> join j x = K[ b ]
+-- j <>
= do { let sb_env = se `setInScopeFromE` env
- ; (sb_env1, bndr') <- simplBinder sb_env bndr
+ ; (sb_env1, bndr') <- simplBinder sb_env bndr
; (floats1, join_inner) <- simplLam sb_env1 bndrs body cont
-- No need to use mkDupableCont before simplLam; we
-- use cont once here, and then share the result if necessary
@@ -3333,37 +3328,21 @@ mkDupableCont env (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs
; let join_body = wrapFloats floats1 join_inner
res_ty = contResultType cont
- ; (floats2, body2)
- <- if exprIsDupable (targetPlatform (seDynFlags env)) join_body
- then return (emptyFloats env, join_body)
- else do { join_bndr <- newJoinId [bndr'] res_ty
- ; let join_call = App (Var join_bndr) (Var bndr')
- join_rhs = Lam (setOneShotLambda bndr') join_body
- join_bind = NonRec join_bndr join_rhs
- floats = emptyFloats env `extendFloats` join_bind
- ; return (floats, join_call) }
- ; return ( floats2
- , StrictBind { sc_bndr = bndr', sc_bndrs = []
- , sc_body = body2
- , sc_env = zapSubstEnv se `setInScopeFromF` floats2
- -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils
- , sc_dup = OkToDup
- , sc_cont = mkBoringStop res_ty } ) }
-
-mkDupableCont env (StrictArg { sc_fun = info, sc_cci = cci
- , sc_cont = cont, sc_fun_ty = fun_ty, sc_mult = m })
- -- See Note [Duplicating StrictArg]
- -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
- = do { (floats1, cont') <- mkDupableCont env cont
- ; (floats_s, args') <- mapAndUnzipM (makeTrivialArg (getMode env))
- (ai_args info)
- ; return ( foldl' addLetFloats floats1 floats_s
- , StrictArg { sc_fun = info { ai_args = args' }
- , sc_cont = cont'
- , sc_cci = cci
- , sc_fun_ty = fun_ty
- , sc_mult = m
- , sc_dup = OkToDup} ) }
+ ; mkDupableStrictBind env RhsCtxt bndr' join_body res_ty }
+
+mkDupableCont env (StrictArg { sc_fun = fun, sc_cci = cci
+ , sc_cont = cont, sc_fun_ty = fun_ty
+ , sc_mult = m })
+-- See Note [Duplicating StrictArg]
+-- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
+-- K[ f a b <> ] --> join j x = K[ f a b x ]
+-- j <>
+ = do { let arg_ty = funArgTy fun_ty
+ rhs_ty = contResultType cont
+ ; arg_bndr <- newId (fsLit "arg") m arg_ty -- ToDo: check this linearity argument
+ ; let env' = env `addNewInScopeIds` [arg_bndr]
+ ; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (m, Var arg_bndr) fun_ty) cont
+ ; mkDupableStrictBind env' cci arg_bndr (wrapFloats floats join_rhs) rhs_ty }
mkDupableCont env (ApplyToTy { sc_cont = cont
, sc_arg_ty = arg_ty, sc_hole_ty = hole_ty })
@@ -3437,6 +3416,34 @@ mkDupableCont env (Select { sc_bndr = case_bndr, sc_alts = alts
-- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils
, sc_cont = mkBoringStop (contResultType cont) } ) }
+mkDupableStrictBind :: SimplEnv -> CallCtxt -> OutId -> OutExpr -> OutType
+ -> SimplM (SimplFloats, SimplCont)
+mkDupableStrictBind env cci arg_bndr join_rhs res_ty
+ | exprIsDupable (targetPlatform (seDynFlags env)) join_rhs
+ = return (emptyFloats env
+ , StrictBind { sc_bndr = arg_bndr, sc_bndrs = []
+ , sc_body = join_rhs
+ , sc_env = zapSubstEnv env
+ -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils
+ , sc_dup = OkToDup
+ , sc_cont = mkBoringStop res_ty } )
+ | otherwise
+ = do { join_bndr <- newJoinId [arg_bndr] res_ty
+ ; let arg_info = ArgInfo { ai_fun = join_bndr
+ , ai_rules = Nothing, ai_args = []
+ , ai_encl = False, ai_strs = repeat False
+ , ai_discs = repeat 0 }
+ ; return ( addJoinFloats (emptyFloats env) $
+ unitJoinFloat $
+ NonRec join_bndr $
+ Lam (setOneShotLambda arg_bndr) join_rhs
+ , StrictArg { sc_dup = OkToDup
+ , sc_fun = arg_info
+ , sc_fun_ty = idType join_bndr
+ , sc_cont = mkBoringStop res_ty
+ , sc_mult = Many -- ToDo: check this!
+ , sc_cci = cci } ) }
+
mkDupableAlt :: Platform -> OutId
-> JoinFloats -> OutAlt
-> SimplM (JoinFloats, OutAlt)
@@ -3610,56 +3617,75 @@ type variables as well as term variables.
Note [Duplicating StrictArg]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We make a StrictArg duplicable simply by making all its
-stored-up arguments (in sc_fun) trivial, by let-binding
-them. Thus:
- f E [..hole..]
- ==> let a = E
- in f a [..hole..]
-Now if the thing in the hole is a case expression (which is when
-we'll call mkDupableCont), we'll push the function call into the
-branches, which is what we want. Now RULES for f may fire, and
-call-pattern specialisation. Here's an example from #3116
+What code do we want for this?
+
+ f (case x1 of { T -> F; F -> T })
+ (case x2 of { T -> F; F -> T })
+ ...etc...
+
+when f is strict in all its arguments. (It might, for example, be a
+strict data constructor whose wrapper has not yet been inlined.)
+
+Morally, we want to evaluate each argument in turn, and then call f.
+Eavluating each argument has a case-split, so we'll get a diamond
+pattern of join points, like this, assuming we evaluate the args
+left-to-right:
+
+ join {
+ j1 a1 = join {
+ j2 a2 = .....
+ } in case x2 of { T -> j2 F; j2 T }
+ } in case x1 of { T -> j1 F; F -> j1 T }
+
+So when we want to duplicate a StrictArg continuation, we
+want to use this transformation
+ K[ f a b <> ] --> join j x = K[ f a b x ]
+ in j <>
+
+-- Downsides --
+
+This plan has some downsides, because now the call to 'f' can't
+"see" the actual argument 'x' which might be important for RULES
+or call-pattern specialisation. Here's an example from #3116
+
go (n+1) (case l of
1 -> bs'
_ -> Chunk p fpc (o+1) (l-1) bs')
-If we can push the call for 'go' inside the case, we get
+
+If we pushed the entire call for 'go' inside the case, we get
call-pattern specialisation for 'go', which is *crucial* for
this program.
-Here is the (&&) example:
- && E (case x of { T -> F; F -> T })
- ==> let a = E in
- case x of { T -> && a F; F -> && a T }
-Much better!
-
-Notice that
- * Arguments to f *after* the strict one are handled by
- the ApplyToVal case of mkDupableCont. Eg
- f [..hole..] E
-
- * We can only do the let-binding of E because the function
- part of a StrictArg continuation is an explicit syntax
- tree. In earlier versions we represented it as a function
- (CoreExpr -> CoreEpxr) which we couldn't take apart.
-
-Historical aide: previously we did this (where E is a
-big argument:
- f E [..hole..]
- ==> let $j = \a -> f E a
- in $j [..hole..]
-
-But this is terrible! Here's an example:
+Here is another example. With our current approach we see
&& E (case x of { T -> F; F -> T })
-Now, && is strict so we end up simplifying the case with
-an ArgOf continuation. If we let-bind it, we get
- let $j = \v -> && E v
- in simplExpr (case x of { T -> F; F -> T })
- (ArgOf (\r -> $j r)
-And after simplifying more we get
+ ==>
let $j = \v -> && E v
in case x of { T -> $j F; F -> $j T }
-Which is a Very Bad Thing
+
+But we'd prefer to get
+ let a = E
+ in case x of { T -> && a F; F -> && a T }
+
+Pushing the whole call inwards in this way is precisely the change
+that was made in #3116, but /un-done/ by my fix to #13253. Why?
+Because pushing the whole call inwards works very badly in some cases.
+
+ f (case x1 of { T->F; F->T }) (case x2..) ...
+
+==> GHC 8.10 duplicate StrictArg
+ (case x1 of { T -> f F, F -> f T })
+ (case x2 ...)
+ (case x3 ...)
+==> duplicate ApplyToVal
+ let a2 = case x2 of ...
+ a3 = case x3 of ...
+ in case x1 of { T -> f F a2 a3 ... ; F -> f T a2 a3 ... }
+
+Now there is an Awful Danger than we'll postInlineUnconditionally a2
+and a3, and repeat the whole exercise, leading to exponential code
+size. Moreover, if we don't, those ai lets are really strict; so not
+or later they will be dealt with via Note [Duplicating StrictBind].
+StrictArg and StrictBind should be handled the same.
Note [Duplicating StrictBind]
@@ -3669,9 +3695,10 @@ that for case expressions. After all,
let x* = e in b is similar to case e of x -> b
So we potentially make a join-point for the body, thus:
- let x = [] in b ==> join j x = b
- in let x = [] in j x
+ let x = <> in b ==> join j x = b
+ in j <>
+Just like StrictArg in fact -- and indeed they share code.
Note [Join point abstraction] Historical note
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -1200,9 +1200,9 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env
extend_subst_with inl_rhs = extendIdSubst env bndr (mkContEx rhs_env inl_rhs)
one_occ IAmDead = True -- Happens in ((\x.1) v)
- one_occ OneOcc{ occ_one_br = InOneBranch
+ one_occ OneOcc{ occ_n_br = 1
, occ_in_lam = NotInsideLam } = isNotTopLevel top_lvl || early_phase
- one_occ OneOcc{ occ_one_br = InOneBranch
+ one_occ OneOcc{ occ_n_br = 1
, occ_in_lam = IsInsideLam
, occ_int_cxt = IsInteresting } = canInlineInLam rhs
one_occ _ = False
@@ -1328,12 +1328,17 @@ postInlineUnconditionally env top_lvl bndr occ_info rhs
-- False -> case x of ...
-- This is very important in practice; e.g. wheel-seive1 doubles
-- in allocation if you miss this out
- OneOcc { occ_in_lam = in_lam, occ_int_cxt = int_cxt }
- -- OneOcc => no code-duplication issue
- -> smallEnoughToInline dflags unfolding -- Small enough to dup
+
+ OneOcc { occ_in_lam = in_lam, occ_int_cxt = int_cxt, occ_n_br = n_br }
+ -> -- See Note [Suppress exponential blowup]
+ n_br < (case int_cxt of
+ IsInteresting -> 16
+ NotInteresting -> 4)
+
+ && smallEnoughToInline dflags unfolding -- Small enough to dup
-- ToDo: consider discount on smallEnoughToInline if int_cxt is true
--
- -- NB: Do NOT inline arbitrarily big things, even if one_br is True
+ -- NB: Do NOT inline arbitrarily big things, even if occ_n_br=1
-- Reason: doing so risks exponential behaviour. We simplify a big
-- expression, inline it, and simplify it again. But if the
-- very same thing happens in the big expression, we get
@@ -1380,7 +1385,35 @@ postInlineUnconditionally env top_lvl bndr occ_info rhs
active = isActive (sm_phase (getMode env)) (idInlineActivation bndr)
-- See Note [pre/postInlineUnconditionally in gentle mode]
-{-
+{- Note [Suppress exponential blowup]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In #13253, and a raft of related tickets, we got an exponential blowup
+in code size from postInlineUnconditionally. The trouble comes when
+we have
+ let j1a = case f y of { True -> p; False -> q }
+ j1b = case f y of { True -> q; False -> p }
+ j2a = case f (y+1) of { True -> j1a; False -> j1b }
+ j2b = case f (y+1) of { True -> j1b; False -> j1a }
+ ...
+ in case f (y+10) of { True -> j10a; False -> j10b }
+
+when there are many branches. In pass 1, postInlineUnconditionally
+inlines j10a and j10b (they are both small). Now we have two calls
+to j9a and two to j9b. In pass 2, postInlineUnconditionally inlines
+all four of these calls, leaving four calls to j8a and j8b. Etc.
+Yikes! This is exponential!
+
+Moreover, this structure can and does arise easily, as the
+tickets show: it's just a sequence of diamond control flow blocks.
+
+Solution: stop doing postInlineUnconditionally for some fixed,
+smallish number of branches, say 4.
+
+This still leaves the nasty possiblity that /ordinary/ inlining (not
+postInlineUnconditionally) might inline these join points, each of
+which is individually quiet small. I'm still not sure what to do
+about this (see #15488). But let's kill off one problem anyway.
+
Note [Top level and postInlineUnconditionally]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We don't do postInlineUnconditionally for top-level things (even for
=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -427,7 +427,7 @@ simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst })
safe_to_inline IAmALoopBreaker{} = False
safe_to_inline IAmDead = True
safe_to_inline OneOcc{ occ_in_lam = NotInsideLam
- , occ_one_br = InOneBranch } = True
+ , occ_n_br = 1 } = True
safe_to_inline OneOcc{} = False
safe_to_inline ManyOccs{} = False
=====================================
compiler/GHC/Types/Basic.hs
=====================================
@@ -68,7 +68,7 @@ module GHC.Types.Basic (
isNoOccInfo, strongLoopBreaker, weakLoopBreaker,
InsideLam(..),
- OneBranch(..),
+ BranchCount, oneBranch,
InterestingCxt(..),
TailCallInfo(..), tailCallInfo, zapOccTailCallInfo,
isAlwaysTailCalled,
@@ -978,7 +978,7 @@ data OccInfo
-- lambda and case-bound variables.
| OneOcc { occ_in_lam :: !InsideLam
- , occ_one_br :: !OneBranch
+ , occ_n_br :: {-# UNPACK #-} !BranchCount
, occ_int_cxt :: !InterestingCxt
, occ_tail :: !TailCallInfo }
-- ^ Occurs exactly once (per branch), not inside a rule
@@ -992,6 +992,11 @@ data OccInfo
type RulesOnly = Bool
+type BranchCount = Int -- For OneOcc, says how many syntactic occurrences there are
+
+oneBranch :: BranchCount
+oneBranch = 1
+
{-
Note [LoopBreaker OccInfo]
~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1057,14 +1062,6 @@ instance Monoid InsideLam where
mempty = NotInsideLam
mappend = (Semi.<>)
------------------
-data OneBranch
- = InOneBranch
- -- ^ One syntactic occurrence: Occurs in only one case branch
- -- so no code-duplication issue to worry about
- | MultipleBranches
- deriving (Eq)
-
-----------------
data TailCallInfo = AlwaysTailCalled JoinArity -- See Note [TailCallInfo]
| NoTailCallInfo
@@ -1124,12 +1121,10 @@ instance Outputable OccInfo where
pp_ro | rule_only = char '!'
| otherwise = empty
ppr (OneOcc inside_lam one_branch int_cxt tail_info)
- = text "Once" <> pp_lam inside_lam <> pp_br one_branch <> pp_args int_cxt <> pp_tail
+ = text "Once" <> pp_lam inside_lam <> ppr one_branch <> pp_args int_cxt <> pp_tail
where
pp_lam IsInsideLam = char 'L'
pp_lam NotInsideLam = empty
- pp_br MultipleBranches = char '*'
- pp_br InOneBranch = empty
pp_args IsInteresting = char '!'
pp_args NotInteresting = empty
pp_tail = pprShortTailCallInfo tail_info
@@ -1156,7 +1151,7 @@ AlwaysTailCalled.
Note that there is a 'TailCallInfo' on a 'ManyOccs' value. One might expect that
being tail-called would mean that the variable could only appear once per branch
-(thus getting a `OneOcc { occ_one_br = True }` occurrence info), but a join
+(thus getting a `OneOcc { }` occurrence info), but a join
point can also be invoked from other join points, not just from case branches:
let j1 x = ...
@@ -1167,7 +1162,7 @@ point can also be invoked from other join points, not just from case branches:
C -> j2 q
Here both 'j1' and 'j2' will get marked AlwaysTailCalled, but j1 will get
-ManyOccs and j2 will get `OneOcc { occ_one_br = True }`.
+ManyOccs and j2 will get `OneOcc { occ_n_br = 2 }`.
************************************************************************
* *
=====================================
compiler/GHC/Types/Id/Info.hs
=====================================
@@ -58,7 +58,7 @@ module GHC.Types.Id.Info (
isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker,
occInfo, setOccInfo,
- InsideLam(..), OneBranch(..),
+ InsideLam(..), BranchCount,
TailCallInfo(..),
tailCallInfo, isAlwaysTailCalled,
=====================================
testsuite/tests/perf/compiler/T10421.hs
=====================================
@@ -0,0 +1,51 @@
+-- Exponential with GHC 8.10
+
+module RegBig where
+
+import Prelude
+
+import Control.Applicative
+import T10421_Form
+import T10421_Y
+
+data Register
+ = Register String
+ String
+ String
+ String
+ String
+ String
+ String
+ String
+ String
+ String
+ String
+ String
+
+registerForm :: a -> IO (FormResult Register)
+registerForm _ = do
+ (a1, _) <- mreq textField "" Nothing
+ (a2, _) <- mreq textField "" Nothing
+ (a3, _) <- mreq textField "" Nothing
+ (a4, _) <- mreq textField "" Nothing
+ (a5, _) <- mreq textField "" Nothing
+ (a6, _) <- mreq textField "" Nothing
+ (a7, _) <- mreq textField "" Nothing
+ (a8, _) <- mreq textField "" Nothing
+ (a9, _) <- mreq textField "" Nothing
+ (a10, _) <- mreq textField "" Nothing
+ (a11, _) <- mreq textField "" Nothing
+ (a12, _) <- mreq textField "" Nothing
+ return (Register <$> a1
+ <*> a2
+ <*> a3
+ <*> a4
+ <*> a5
+ <*> a6
+ <*> a7
+ <*> a8
+ <*> a9
+ <*> a10
+ <*> a11
+ <*> a12
+ )
=====================================
testsuite/tests/perf/compiler/T10421_Form.hs
=====================================
@@ -0,0 +1,19 @@
+-- Form.hs
+module T10421_Form where
+
+import Control.Applicative
+
+data FormResult a = FormMissing
+ | FormFailure [String]
+ | FormSuccess a
+instance Functor FormResult where
+ fmap _ FormMissing = FormMissing
+ fmap _ (FormFailure errs) = FormFailure errs
+ fmap f (FormSuccess a) = FormSuccess $ f a
+instance Applicative FormResult where
+ pure = FormSuccess
+ (FormSuccess f) <*> (FormSuccess g) = FormSuccess $ f g
+ (FormFailure x) <*> (FormFailure y) = FormFailure $ x ++ y
+ (FormFailure x) <*> _ = FormFailure x
+ _ <*> (FormFailure y) = FormFailure y
+ _ <*> _ = FormMissing
=====================================
testsuite/tests/perf/compiler/T10421_Y.hs
=====================================
@@ -0,0 +1,17 @@
+-- Y.hs
+{-# OPTIONS_GHC -fomit-interface-pragmas #-}
+-- Imagine the values defined in this module are complicated
+-- and there is no useful inlining/strictness/etc. information
+
+module T10421_Y where
+
+import T10421_Form
+
+mreq :: a -> b -> c -> IO (FormResult d, ())
+mreq = undefined
+
+mopt :: a -> b -> c -> IO (FormResult d, ())
+mopt = undefined
+
+textField = undefined
+checkBoxField = undefined
=====================================
testsuite/tests/perf/compiler/T13253-spj.hs
=====================================
@@ -0,0 +1,20 @@
+-- Exponential with GHC 8.10
+
+module T13253 where
+
+f :: Int -> Bool -> Bool
+{-# INLINE f #-}
+f y x = case x of { True -> y>0 ; False -> y<0 }
+
+foo y x = f (y+1) $
+ f (y+2) $
+ f (y+3) $
+ f (y+4) $
+ f (y+5) $
+ f (y+6) $
+ f (y+7) $
+ f (y+8) $
+ f (y+9) $
+ f (y+10) $
+ f (y+11) $
+ f y x
=====================================
testsuite/tests/perf/compiler/T13253.hs
=====================================
@@ -0,0 +1,122 @@
+-- Exponential with GHC 8.10
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module T13253 where
+
+import Control.Monad (liftM)
+import Control.Monad.Trans.RWS.Lazy -- check how strict behaves
+import Control.Monad.Trans.Reader (ReaderT)
+import Control.Monad.IO.Class (MonadIO (..))
+import Control.Monad.Trans.Class (MonadTrans (..))
+import Data.ByteString (ByteString)
+import Data.Monoid (Any (..))
+import Data.Semigroup (Semigroup (..))
+import Data.String (IsString (..))
+import System.Environment (getEnv)
+
+type Handler = ReaderT () IO
+type MForm = RWST (Maybe ([(String, Text)], ()), (), ()) Any [Int]
+type Text = ByteString -- close enough
+
+data HugeStruct = HugeStruct
+ !Text
+ !Text
+ !Text
+ !Text
+ !Text
+ !Text
+ !Text
+ !Text
+ !Text -- 9th
+ !Text
+ !Text
+
+data FormResult a = FormMissing
+ | FormFailure [Text]
+ | FormSuccess a
+ deriving Show
+instance Functor FormResult where
+ fmap _ FormMissing = FormMissing
+ fmap _ (FormFailure errs) = FormFailure errs
+ fmap f (FormSuccess a) = FormSuccess $ f a
+instance Applicative FormResult where
+ pure = FormSuccess
+ (FormSuccess f) <*> (FormSuccess g) = FormSuccess $ f g
+ (FormFailure x) <*> (FormFailure y) = FormFailure $ x ++ y
+ (FormFailure x) <*> _ = FormFailure x
+ _ <*> (FormFailure y) = FormFailure y
+ _ <*> _ = FormMissing
+instance Monoid m => Monoid (FormResult m) where
+ mempty = pure mempty
+ mappend x y = mappend <$> x <*> y
+instance Semigroup m => Semigroup (FormResult m) where
+ x <> y = (<>) <$> x <*> y
+
+mreq :: MonadIO m => String -> MForm m (FormResult Text, ())
+-- fast
+--mreq v = pure (FormFailure [], ())
+-- slow
+mreq v = mhelper v (\m l -> FormFailure ["fail"]) FormSuccess
+
+askParams :: Monad m => MForm m (Maybe [(String, Text)])
+askParams = do
+ (x, _, _) <- ask
+ return $ liftM fst x
+
+mhelper
+ :: MonadIO m
+ => String
+ -> (() -> () -> FormResult b) -- on missing
+ -> (Text -> FormResult b) -- on success
+ -> MForm m (FormResult b, ())
+mhelper v onMissing onFound = do
+ -- without tell, also faster
+ tell (Any True)
+ -- with different "askParams": faster.
+ -- mp <- liftIO $ read <$> readFile v
+ mp <- askParams
+ (res, x) <- case mp of
+ Nothing -> return (FormMissing, ())
+ Just p -> do
+ return $ case lookup v p of
+ Nothing -> (onMissing () (), ())
+ Just t -> (onFound t, ())
+ return (res, x)
+
+-- not inlining, also faster:
+-- {-# NOINLINE mhelper #-}
+
+sampleForm2 :: MForm Handler (FormResult HugeStruct)
+sampleForm2 = do
+ (x01, _) <- mreq "UNUSED"
+ (x02, _) <- mreq "UNUSED"
+ (x03, _) <- mreq "UNUSED"
+ (x04, _) <- mreq "UNUSED"
+ (x05, _) <- mreq "UNUSED"
+ (x06, _) <- mreq "UNUSED"
+ (x07, _) <- mreq "UNUSED"
+ (x08, _) <- mreq "UNUSED"
+ (x09, _) <- mreq "UNUSED"
+ (x10, _) <- mreq "UNUSED"
+ (x11, _) <- mreq "UNUSED"
+
+ let hugeStructRes = HugeStruct
+ <$> x01
+ <*> x02
+ <*> x03
+ <*> x04
+ <*> x05
+ <*> x06
+ <*> x07
+ <*> x08
+ <*> x09
+ <*> x10
+ <*> x11
+
+ pure hugeStructRes
+
+
+main :: IO ()
+main = pure ()
=====================================
testsuite/tests/perf/compiler/T18140.hs
=====================================
@@ -0,0 +1,57 @@
+-- Exponential with GHC 8.10
+
+{-# LANGUAGE BangPatterns #-}
+module T18140 where
+
+
+data D = D
+ !(Maybe Bool)
+ !(Maybe Bool)
+ !(Maybe Bool)
+ !(Maybe Bool)
+ !(Maybe Bool)
+ !(Maybe Bool)
+ !(Maybe Bool)
+ !(Maybe Bool)
+ !(Maybe Bool)
+ !(Maybe Bool)
+ !(Maybe Bool)
+ !(Maybe Bool)
+ !(Maybe Bool)
+ !(Maybe Bool)
+ !(Maybe Bool)
+ !(Maybe Bool)
+ !(Maybe Bool)
+ !(Maybe Bool)
+
+maMB :: Maybe Bool -> Maybe Bool -> Maybe Bool
+maMB Nothing y = y
+maMB x Nothing = x
+maMB (Just x) (Just y) = Just (maB x y)
+
+maB :: Bool -> Bool -> Bool
+maB _ y = y
+
+maD :: D -> D -> D
+maD (D x'1 x'2 x'3 x'4 x'5 x'6 x'7 x'8 x'9 x'10 x'11 x'12 x'13 x'14 x'15 x'16 x'17 x'18)
+ (D y'1 y'2 y'3 y'4 y'5 y'6 y'7 y'8 y'9 y'10 y'11 y'12 y'13 y'14 y'15 y'16 y'17 y'18)
+ = D
+ (maMB x'1 y'1)
+ (maMB x'2 y'2)
+ (maMB x'3 y'3)
+ (maMB x'4 y'4)
+ (maMB x'5 y'5)
+ (maMB x'6 y'6)
+ (maMB x'7 y'7)
+ (maMB x'8 y'8)
+ (maMB x'9 y'9)
+ (maMB x'10 y'10)
+ (maMB x'11 y'11)
+ (maMB x'12 y'12)
+ (maMB x'13 y'13)
+ (maMB x'14 y'14)
+ (maMB x'15 y'15)
+ (maMB x'16 y'16)
+ (maMB x'17 y'17)
+ (maMB x'18 y'18)
+
=====================================
testsuite/tests/perf/compiler/all.T
=====================================
@@ -375,3 +375,24 @@ test ('T18282',
],
compile,
['-v0 -O'])
+test ('T18140',
+ [ collect_compiler_stats('bytes allocated',2)
+ ],
+ compile,
+ ['-v0 -O'])
+test('T10421',
+ [ only_ways(['normal']),
+ collect_compiler_stats('bytes allocated', 1)
+ ],
+ multimod_compile,
+ ['T10421', '-v0 -O'])
+test ('T13253',
+ [ collect_compiler_stats('bytes allocated',2)
+ ],
+ compile,
+ ['-v0 -O'])
+test ('T13253-spj',
+ [ collect_compiler_stats('bytes allocated',2)
+ ],
+ compile,
+ ['-v0 -O'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a6247763a9d3b41b4d62a9701fadcd5891b9e21c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a6247763a9d3b41b4d62a9701fadcd5891b9e21c
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/3ac97222/attachment-0001.html>
More information about the ghc-commits
mailing list