diff options
| -rw-r--r-- | compiler/GHC/Core/Opt/OccurAnal.hs | 18 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/SetLevels.hs | 12 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/Simplify.hs | 193 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/Simplify/Utils.hs | 47 | ||||
| -rw-r--r-- | compiler/GHC/Core/SimpleOpt.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Types/Basic.hs | 25 | ||||
| -rw-r--r-- | compiler/GHC/Types/Id/Info.hs | 2 | ||||
| -rw-r--r-- | testsuite/tests/perf/compiler/T10421.hs | 51 | ||||
| -rw-r--r-- | testsuite/tests/perf/compiler/T10421_Form.hs | 19 | ||||
| -rw-r--r-- | testsuite/tests/perf/compiler/T10421_Y.hs | 17 | ||||
| -rw-r--r-- | testsuite/tests/perf/compiler/T13253-spj.hs | 20 | ||||
| -rw-r--r-- | testsuite/tests/perf/compiler/T13253.hs | 122 | ||||
| -rw-r--r-- | testsuite/tests/perf/compiler/T18140.hs | 57 | ||||
| -rw-r--r-- | testsuite/tests/perf/compiler/all.T | 21 |
14 files changed, 490 insertions, 116 deletions
diff --git a/compiler/GHC/Core/Opt/OccurAnal.hs b/compiler/GHC/Core/Opt/OccurAnal.hs index 9cc0953efd..8a48766627 100644 --- a/compiler/GHC/Core/Opt/OccurAnal.hs +++ b/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 } diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs index 91e9f6ec34..efcf96e6df 100644 --- a/compiler/GHC/Core/Opt/SetLevels.hs +++ b/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 diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index 355dd256c1..9c558f2053 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/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 @@ -3325,9 +3318,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 @@ -3335,37 +3330,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 }) @@ -3439,6 +3418,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) @@ -3612,56 +3619,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] @@ -3671,9 +3697,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 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs index e9ee16157f..cf56ac9c94 100644 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -1201,9 +1201,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 @@ -1329,12 +1329,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 @@ -1381,7 +1386,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 diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs index 8525fb292f..3735cded34 100644 --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -433,7 +433,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 diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs index cf373f76d5..4559a4c913 100644 --- a/compiler/GHC/Types/Basic.hs +++ b/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] ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1058,14 +1063,6 @@ instance Monoid InsideLam where 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 deriving (Eq) @@ -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 }`. ************************************************************************ * * diff --git a/compiler/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs index dfd6ef96ab..f67f581b74 100644 --- a/compiler/GHC/Types/Id/Info.hs +++ b/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, diff --git a/testsuite/tests/perf/compiler/T10421.hs b/testsuite/tests/perf/compiler/T10421.hs new file mode 100644 index 0000000000..226cc95fd2 --- /dev/null +++ b/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 + ) diff --git a/testsuite/tests/perf/compiler/T10421_Form.hs b/testsuite/tests/perf/compiler/T10421_Form.hs new file mode 100644 index 0000000000..0abf7ad9d5 --- /dev/null +++ b/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 diff --git a/testsuite/tests/perf/compiler/T10421_Y.hs b/testsuite/tests/perf/compiler/T10421_Y.hs new file mode 100644 index 0000000000..de28838e86 --- /dev/null +++ b/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 diff --git a/testsuite/tests/perf/compiler/T13253-spj.hs b/testsuite/tests/perf/compiler/T13253-spj.hs new file mode 100644 index 0000000000..9c8af39aca --- /dev/null +++ b/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 diff --git a/testsuite/tests/perf/compiler/T13253.hs b/testsuite/tests/perf/compiler/T13253.hs new file mode 100644 index 0000000000..3c99f2d622 --- /dev/null +++ b/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 () diff --git a/testsuite/tests/perf/compiler/T18140.hs b/testsuite/tests/perf/compiler/T18140.hs new file mode 100644 index 0000000000..9b75b98054 --- /dev/null +++ b/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) + diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T index 7421cb24df..bc7d1eef8f 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -383,3 +383,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']) |