From cfd682902da6546362a48fbeedf03e414d0fd6db Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones <simon.peytonjones@gmail.com> Date: Mon, 22 Jan 2024 13:02:34 +0000 Subject: [PATCH] Stop dropping a case whose binder is demanded This MR fixes #24251. See Note [Case-to-let for strictly-used binders] in GHC.Core.Opt.Simplify.Iteration, plus #24251, for lots of discussion. Final Nofib changes over 0.1%: +----------------------------------------- | imaginary/digits-of-e2 -2.16% | imaginary/rfib -0.15% | real/fluid -0.10% | real/gamteb -1.47% | real/gg -0.20% | real/maillist +0.19% | real/pic -0.23% | real/scs -0.43% | shootout/n-body -0.41% | shootout/spectral-norm -0.12% +======================================== | geom mean -0.05% Pleasingly, overall executable size is down by just over 1%. Compile times (in perf/compiler) wobble around a bit +/- 0.5%, but the geometric mean is -0.1% which seems good. --- compiler/GHC/Core/Opt/Simplify/Iteration.hs | 94 ++++++++++---- compiler/GHC/Core/Opt/Simplify/Utils.hs | 119 ++++++++++++++---- .../numeric/should_compile/T19641.stderr | 4 +- .../tests/simplCore/should_compile/T15631.hs | 4 +- .../simplCore/should_compile/T15631.stdout | 3 +- .../simplCore/should_compile/T20103.stderr | 66 +++++----- .../simplCore/should_compile/T22428.stderr | 30 ++--- .../simplCore/should_compile/T22611.stderr | 52 +++++--- .../simplCore/should_compile/T7360.stderr | 114 ++++++++++------- .../tests/simplCore/should_compile/all.T | 4 +- 10 files changed, 323 insertions(+), 167 deletions(-) diff --git a/compiler/GHC/Core/Opt/Simplify/Iteration.hs b/compiler/GHC/Core/Opt/Simplify/Iteration.hs index db0b07765c21..40f7f9d12a5c 100644 --- a/compiler/GHC/Core/Opt/Simplify/Iteration.hs +++ b/compiler/GHC/Core/Opt/Simplify/Iteration.hs @@ -2827,30 +2827,73 @@ Note [Case-to-let for strictly-used binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we have this: case <scrut> of r { _ -> ..r.. } - -where 'r' is used strictly in (..r..), we can safely transform to +where 'r' is used strictly in (..r..), we /could/ safely transform to let r = <scrut> in ...r... - -This is a Good Thing, because 'r' might be dead (if the body just -calls error), or might be used just once (in which case it can be -inlined); or we might be able to float the let-binding up or down. -E.g. #15631 has an example. - -Note that this can change the error behaviour. For example, we might -transform - case x of { _ -> error "bad" } - --> error "bad" -which is might be puzzling if 'x' currently lambda-bound, but later gets -let-bound to (error "good"). - -Nevertheless, the paper "A semantics for imprecise exceptions" allows -this transformation. If you want to fix the evaluation order, use -'pseq'. See #8900 for an example where the loss of this -transformation bit us in practice. - -See also Note [Empty case alternatives] in GHC.Core. - -Historical notes +As a special case, we have a plain `seq` like + case r of r1 { _ -> ...r1... } +where `r` is used strictly, we /could/ simply drop the `case` to get + ...r.... + +HOWEVER, there are some serious downsides to this transformation, so +GHC doesn't do it any longer (#24251): + +* Suppose the Simplifier sees + case x of y* { __DEFAULT -> + let z = case y of { __DEFAULT -> expr } in + z+1 } + The "y*" means "y is used strictly in its scope. Now we may: + - Eliminate the inner case because `y` is evaluated. + Now the demand-info on `y` is not right, because `y` is no longer used + strictly in its scope. But it is hard to spot that without doing a new + demand analysis. So there is a danger that we will subsequently: + - Eliminate the outer case because `y` is used strictly + Yikes! We can't eliminate both! + +* It introduces space leaks (#24251). Consider + go 0 where go x = x `seq` go (x + 1) + It is an infinite loop, true, but it should not leak space. Yet if we drop + the `seq`, it will. Another great example is #21741. + +* Dropping the outer `case can change the error behaviour. For example, + we might transform + case x of { _ -> error "bad" } --> error "bad" + which is might be puzzling if 'x' currently lambda-bound, but later gets + let-bound to (error "good"). Tht is OK accoring to the paper "A semantics for + imprecise exceptions", but see #8900 for an example where the loss of this + transformation bit us in practice. + +* If we have (case e of x -> f x), where `f` is strict, then it looks as if `x` + is strictly used, and we could soundly transform to + let x = e in f x + But if f's strictness info got worse (which can happen in in obscure cases; + see #21392) then we might have turned a non-thunk into a thunk! Bad. + +Lacking this "drop-strictly-used-seq" transformation means we can end up with +some redundant-looking evals. For example, consider + f x y = case x of DEFAULT -> -- A redundant-looking eval + case y of + True -> case x of { Nothing -> False; Just z -> z } + False -> case x of { Nothing -> True; Just z -> z } +That outer eval will be retained right through to code generation. But, +perhaps surprisingly, that is probably a /good/ thing: + + Key point: those inner (case x) expressions will be compiled a simple 'if', + because the code generator can see that `x` is, at those points, evaluated + and properly tagged. + +If we dropped the outer eval, both the inner (case x) expressions would need to +do a proper eval, pushing a return address, with an info table. See the example +in #15631 where, in the Description, the (case ys) will be a simple multi-way +jump. + +In fact (#24251), when I stopped GHC implementing the drop-strictly-used-seqs +transformation, binary sizes fell by 1%, and a few programs actually allocated +less and ran faster. A case in point is nofib/imaginary/digits-of-e2. (I'm not +sure exactly why it improves so much, though.) + +Slightly related: Note [Empty case alternatives] in GHC.Core. + +Historical notes: There have been various earlier versions of this patch: @@ -3124,8 +3167,9 @@ doCaseToLet scrut case_bndr | otherwise -- Scrut has a lifted type = exprIsHNF scrut - || isStrUsedDmd (idDemandInfo case_bndr) - -- See Note [Case-to-let for strictly-used binders] + -- || isStrUsedDmd (idDemandInfo case_bndr) + -- We no longer look at the demand on the case binder + -- See Note [Case-to-let for strictly-used binders] -------------------------------------------------- -- 3. Catch-all case diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs index ecbaa15cc5e2..1660559ca6ea 100644 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -74,6 +74,7 @@ import GHC.Types.Demand import GHC.Types.Var.Set import GHC.Types.Basic +import GHC.Data.Maybe ( orElse ) import GHC.Data.OrdList ( isNilOL ) import GHC.Data.FastString ( fsLit ) @@ -2358,6 +2359,44 @@ the outer case scrutinises the same variable as the outer case. This transformation is called Case Merging. It avoids that the same variable is scrutinised multiple times. +Wrinkles + +(MC1) `tryCaseMerge` "looks though" an inner single-alternative case-on-variable. + For example + case x of { + ...outer-alts... + DEFAULT -> case y of (a,b) -> + case x of { A -> rhs1; B -> rhs2 } + ===> + case x of + ...outer-alts... + a -> case y of (a,b) -> rhs1 + B -> case y of (a,b) -> rhs2 + + This duplicates the `case y` but it removes the case x; so it is a win + in terms of execution time (combining the cases on x) at the cost of + perhaps duplicating the `case y`. A case in point is integerEq, which + is defined thus + integerEq :: Integer -> Integer -> Bool + integerEq !x !y = isTrue# (integerEq# x y) + which becomes + integerEq + = \ (x :: Integer) (y_aAL :: Integer) -> + case x of x1 { __DEFAULT -> + case y of y1 { __DEFAULT -> + case x1 of { + IS x2 -> case y1 of { + __DEFAULT -> GHC.Types.False; + IS y2 -> tagToEnum# @Bool (==# x2 y2) }; + IP x2 -> ... + IN x2 -> ... + We want to merge the outer `case x` with the inner `case x1`. + + This story is not fully robust; it will be defeated by a let-binding, + whih we don't want to duplicate. But accounting for single-alternative + case-on-variable is easy to do, and seems useful in common cases so + `tryMergeCase` does it. + Note [Eliminate Identity Case] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ case e of ===> e @@ -2537,24 +2576,25 @@ mkCase, mkCase1, mkCase2, mkCase3 -- 1. Merge Nested Cases -------------------------------------------------- -mkCase mode scrut outer_bndr alts_ty (Alt DEFAULT _ deflt_rhs : outer_alts) +mkCase mode scrut outer_bndr alts_ty alts | sm_case_merge mode - , (ticks, Case (Var inner_scrut_var) inner_bndr _ inner_alts) - <- stripTicksTop tickishFloatable deflt_rhs - , inner_scrut_var == outer_bndr + , Just alts' <- tryMergeCase outer_bndr alts = do { tick (CaseMerge outer_bndr) - - ; let wrap_alt (Alt con args rhs) = assert (outer_bndr `notElem` args) - (Alt con args (wrap_rhs rhs)) - -- Simplifier's no-shadowing invariant should ensure - -- that outer_bndr is not shadowed by the inner patterns - wrap_rhs rhs = Let (NonRec inner_bndr (Var outer_bndr)) rhs - -- The let is OK even for unboxed binders, - - wrapped_alts | isDeadBinder inner_bndr = inner_alts - | otherwise = map wrap_alt inner_alts - - merged_alts = mergeAlts outer_alts wrapped_alts + ; mkCase1 mode scrut outer_bndr alts_ty alts' } + -- Warning: don't call mkCase recursively! + -- Firstly, there's no point, because inner alts have already had + -- mkCase applied to them, so they won't have a case in their default + -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr + -- in munge_rhs may put a case into the DEFAULT branch! + | otherwise + = mkCase1 mode scrut outer_bndr alts_ty alts + +tryMergeCase :: OutId -> [OutAlt] -> Maybe [OutAlt] +-- See Note [Merge Nested Cases] +tryMergeCase outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts) + = case go 5 (\e -> e) emptyVarSet deflt_rhs of + Nothing -> Nothing + Just inner_alts -> Just (mergeAlts outer_alts inner_alts) -- NB: mergeAlts gives priority to the left -- case x of -- A -> e1 @@ -2563,17 +2603,42 @@ mkCase mode scrut outer_bndr alts_ty (Alt DEFAULT _ deflt_rhs : outer_alts) -- B -> e3 -- When we merge, we must ensure that e1 takes -- precedence over e2 as the value for A! - - ; fmap (mkTicks ticks) $ - mkCase1 mode scrut outer_bndr alts_ty merged_alts - } - -- Warning: don't call mkCase recursively! - -- Firstly, there's no point, because inner alts have already had - -- mkCase applied to them, so they won't have a case in their default - -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr - -- in munge_rhs may put a case into the DEFAULT branch! - -mkCase mode scrut bndr alts_ty alts = mkCase1 mode scrut bndr alts_ty alts + where + go :: Int -> (OutExpr -> OutExpr) -> VarSet -> OutExpr -> Maybe [OutAlt] + -- In the call (go wrap free_bndrs rhs), the `wrap` function has free `free_bndrs`; + -- so do not push `wrap` under any binders that would shadow `free_bndrs` + -- + -- The 'n' is just a depth-bound to avoid pathalogical quadratic behaviour with + -- case x1 of DEFAULT -> case x2 of DEFAULT -> case x3 of DEFAULT -> ... + -- when for each `case` we'll look down the whole chain to see if there is + -- another `case` on that same variable. Also all of these (case xi) evals + -- get duplicated in each branch of the outer case, so 'n' controls how much + -- duplication we are prepared to put up with. + go 0 _ _ _ = Nothing + + go n wrap free_bndrs (Tick t rhs) + = go n (wrap . Tick t) free_bndrs rhs + go _ wrap free_bndrs (Case (Var inner_scrut_var) inner_bndr _ inner_alts) + | inner_scrut_var == outer_bndr + , let wrap_let rhs' | isDeadBinder inner_bndr = rhs' + | otherwise = Let (NonRec inner_bndr (Var outer_bndr)) rhs' + -- The let is OK even for unboxed binders, + free_bndrs' = extendVarSet free_bndrs outer_bndr + = Just [ assert (not (any (`elemVarSet` free_bndrs') bndrs)) $ + Alt con bndrs (wrap (wrap_let rhs)) + | Alt con bndrs rhs <- inner_alts ] + go n wrap free_bndrs (Case (Var inner_scrut) inner_bndr ty inner_alts) + | [Alt con bndrs rhs] <- inner_alts -- Wrinkle (MC1) + , let wrap_case rhs' = Case (Var inner_scrut) inner_bndr ty $ + tryMergeCase inner_bndr alts `orElse` alts + where + alts = [Alt con bndrs rhs'] + = assert (not (outer_bndr `elem` (inner_bndr : bndrs))) $ + go (n-1) (wrap . wrap_case) (free_bndrs `extendVarSet` inner_scrut) rhs + + go _ _ _ _ = Nothing + +tryMergeCase _ _ = Nothing -------------------------------------------------- -- 2. Eliminate Identity Case diff --git a/testsuite/tests/numeric/should_compile/T19641.stderr b/testsuite/tests/numeric/should_compile/T19641.stderr index ec7e19c946bc..010dbbffa0f1 100644 --- a/testsuite/tests/numeric/should_compile/T19641.stderr +++ b/testsuite/tests/numeric/should_compile/T19641.stderr @@ -6,7 +6,7 @@ Result size of Tidy Core natural_to_word = \ eta -> case eta of { - NS x1 -> Just (W# x1); + NS x2 -> Just (W# x2); NB ds -> Nothing } @@ -14,7 +14,7 @@ integer_to_int = \ eta -> case eta of { IS ipv -> Just (I# ipv); - IP x1 -> Nothing; + IP x2 -> Nothing; IN ds -> Nothing } diff --git a/testsuite/tests/simplCore/should_compile/T15631.hs b/testsuite/tests/simplCore/should_compile/T15631.hs index 55f67583cfc7..f8c2739a2af0 100644 --- a/testsuite/tests/simplCore/should_compile/T15631.hs +++ b/testsuite/tests/simplCore/should_compile/T15631.hs @@ -7,5 +7,5 @@ f xs = let ys = reverse xs let w = length xs in w + length (reverse (case ys of { a:as -> as; [] -> [] })) - - +-- Feb 24: because of #24251 we now expect ys to be +-- evaluated early, and then case-analysed later diff --git a/testsuite/tests/simplCore/should_compile/T15631.stdout b/testsuite/tests/simplCore/should_compile/T15631.stdout index 6c528debc158..e9fa8ef9018e 100644 --- a/testsuite/tests/simplCore/should_compile/T15631.stdout +++ b/testsuite/tests/simplCore/should_compile/T15631.stdout @@ -1,6 +1,7 @@ case GHC.List.$wlenAcc @a (Foo.f2 @a) 0# of v { __DEFAULT -> + case reverse @a xs of ys { __DEFAULT -> case GHC.List.$wlenAcc @a xs 0# of ww1 { __DEFAULT -> - case GHC.List.reverse1 @a xs (GHC.Types.[] @a) of { + case ys of { [] -> case Foo.f1 @a of { GHC.Types.I# v1 -> GHC.Prim.+# ww1 v1 }; case GHC.List.$wlenAcc case Foo.$wf @a xs of ww [Occ=Once1] { __DEFAULT -> diff --git a/testsuite/tests/simplCore/should_compile/T20103.stderr b/testsuite/tests/simplCore/should_compile/T20103.stderr index c0f04a0ead36..6f52d8ada22a 100644 --- a/testsuite/tests/simplCore/should_compile/T20103.stderr +++ b/testsuite/tests/simplCore/should_compile/T20103.stderr @@ -1,7 +1,12 @@ +T20103.hs:7:24: warning: [GHC-63394] [-Wx-partial (in -Wextended-warnings)] + In the use of ‘head’ + (imported from Prelude, but defined in GHC.List): + "This is a partial function, it throws an error on empty lists. Use pattern matching, 'Data.List.uncons' or 'Data.Maybe.listToMaybe' instead. Consider refactoring to use "Data.List.NonEmpty"." + ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 136, types: 88, coercions: 25, joins: 0/0} + = {terms: 139, types: 89, coercions: 22, joins: 0/0} -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} lvl :: Int @@ -31,8 +36,9 @@ lvl4 = GHC.CString.unpackCString# lvl3 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T20103.$trModule2 :: GHC.Prim.Addr# [GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 30 0}] T20103.$trModule2 = "T20103"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} @@ -43,8 +49,9 @@ lvl5 = GHC.CString.unpackCString# T20103.$trModule2 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T20103.$trModule4 :: GHC.Prim.Addr# [GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 20 0}] T20103.$trModule4 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} @@ -110,10 +117,10 @@ lvl16 :: CallStack ~R# (?callStack::CallStack))) Rec { --- RHS size: {terms: 44, types: 41, coercions: 21, joins: 0/0} +-- RHS size: {terms: 47, types: 42, coercions: 18, joins: 0/0} T20103.$wfoo [InlPrag=[2], Occ=LoopBreaker] :: HasCallStack => GHC.Prim.Int# -> GHC.Prim.Int# -[GblId[StrictWorker([!])], Arity=2, Str=<SL><1L>, Unf=OtherCon []] +[GblId[StrictWorker([!])], Arity=2, Str=<1L><1L>, Unf=OtherCon []] T20103.$wfoo = \ ($dIP :: HasCallStack) (ww :: GHC.Prim.Int#) -> case ww of ds { @@ -136,28 +143,26 @@ T20103.$wfoo (GHC.Prim.-# ds 1#) }; 0# -> - case getCallStack - ($dIP - `cast` (GHC.Classes.N:IP[0] <"callStack">_N <CallStack>_N - :: (?callStack::CallStack) ~R# CallStack)) - of { + case $dIP + `cast` (GHC.Classes.N:IP[0] <"callStack">_N <CallStack>_N + :: (?callStack::CallStack) ~R# CallStack) + of wild1 + { __DEFAULT -> + case getCallStack wild1 of { [] -> - case $dIP - `cast` (GHC.Classes.N:IP[0] <"callStack">_N <CallStack>_N - :: (?callStack::CallStack) ~R# CallStack) - of wild1 { - __DEFAULT -> case lvl16 wild1 of wild2 { }; + case wild1 of wild2 { + __DEFAULT -> case lvl16 wild2 of {}; GHC.Stack.Types.FreezeCallStack ds1 -> case GHC.List.head1 @([Char], SrcLoc) - (wild1 + (wild2 `cast` (Sym (GHC.Classes.N:IP[0] <"callStack">_N <CallStack>_N) :: CallStack ~R# (?callStack::CallStack))) - of wild2 { - } + of {} }; : x ds1 -> case x of { (x1, ds2) -> GHC.List.$wlenAcc @Char x1 0# } } + } } end Rec } @@ -165,10 +170,10 @@ end Rec } foo [InlPrag=[2]] :: HasCallStack => Int -> Int [GblId, Arity=2, - Str=<SL><1!P(1L)>, + Str=<1L><1!P(1L)>, Cpr=1, - Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False) Tmpl= \ ($dIP [Occ=Once1] :: HasCallStack) (eta [Occ=Once1!] :: Int) -> @@ -186,22 +191,25 @@ foo -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T20103.$trModule3 :: GHC.Types.TrName [GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] T20103.$trModule3 = GHC.Types.TrNameS T20103.$trModule4 -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T20103.$trModule1 :: GHC.Types.TrName [GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] T20103.$trModule1 = GHC.Types.TrNameS T20103.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} T20103.$trModule :: GHC.Types.Module [GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] T20103.$trModule = GHC.Types.Module T20103.$trModule3 T20103.$trModule1 diff --git a/testsuite/tests/simplCore/should_compile/T22428.stderr b/testsuite/tests/simplCore/should_compile/T22428.stderr index 48ea278ae0c4..7f06ea3279f2 100644 --- a/testsuite/tests/simplCore/should_compile/T22428.stderr +++ b/testsuite/tests/simplCore/should_compile/T22428.stderr @@ -6,8 +6,9 @@ Result size of Tidy Core -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T22428.f1 :: Integer [GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] T22428.f1 = GHC.Num.Integer.IS 1# -- RHS size: {terms: 28, types: 10, coercions: 0, joins: 1/1} @@ -15,8 +16,9 @@ f :: Integer -> Integer -> Integer [GblId, Arity=2, Str=<SL><1L>, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [0 0] 156 0}] + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [0 0] 156 0}] f = \ (x :: Integer) (y :: Integer) -> joinrec { go [InlPrag=INLINE (sat-args=1), Occ=LoopBreaker, Dmd=SC(S,L)] @@ -24,20 +26,20 @@ f = \ (x :: Integer) (y :: Integer) -> [LclId[JoinId(1)(Just [!])], Arity=1, Str=<1L>, - Unf=Unf{Src=StableUser, TopLvl=False, Value=True, ConLike=True, - WorkFree=True, Expandable=True, + Unf=Unf{Src=StableUser, TopLvl=False, + Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=False)}] go (ds :: Integer) - = case ds of wild { - GHC.Num.Integer.IS x1 -> - case x1 of { - __DEFAULT -> jump go (GHC.Num.Integer.integerSub wild T22428.f1); + = case ds of x1 { + GHC.Num.Integer.IS x2 -> + case x2 of { + __DEFAULT -> jump go (GHC.Num.Integer.integerSub x1 T22428.f1); 0# -> x }; - GHC.Num.Integer.IP x1 -> - jump go (GHC.Num.Integer.integerSub wild T22428.f1); - GHC.Num.Integer.IN x1 -> - jump go (GHC.Num.Integer.integerSub wild T22428.f1) + GHC.Num.Integer.IP x2 -> + jump go (GHC.Num.Integer.integerSub x1 T22428.f1); + GHC.Num.Integer.IN x2 -> + jump go (GHC.Num.Integer.integerSub x1 T22428.f1) }; } in jump go y diff --git a/testsuite/tests/simplCore/should_compile/T22611.stderr b/testsuite/tests/simplCore/should_compile/T22611.stderr index 709751732d70..0ee510b13d2b 100644 --- a/testsuite/tests/simplCore/should_compile/T22611.stderr +++ b/testsuite/tests/simplCore/should_compile/T22611.stderr @@ -1,7 +1,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 544, types: 486, coercions: 0, joins: 0/7} + = {terms: 562, types: 505, coercions: 0, joins: 0/10} $WFound = \ @a @m conrep conrep1 -> @@ -54,13 +54,14 @@ $w$sgo15 __DEFAULT -> let { hi1 = or# (uncheckedShiftRL# ww 1#) 9223372036854775808## } in - let { zeros = word2Int# (ctz# ds3) } in - (# Just ipv4, uncheckedShiftRL# hi1 zeros, + let { zeros = ctz# ds3 } in + let { zeros1 = word2Int# zeros } in + (# Just ipv4, uncheckedShiftRL# hi1 zeros1, or# (uncheckedShiftRL# (or# (uncheckedShiftRL# ds3 1#) (uncheckedShiftL# ww 63#)) - zeros) - (uncheckedShiftL# hi1 (-# 64# zeros)) #); + zeros1) + (uncheckedShiftL# hi1 (-# 64# zeros1)) #); 0## -> (# Just ipv4, 0##, uncheckedShiftRL# @@ -116,12 +117,13 @@ $w$sgo15 __DEFAULT -> let { hi1 = or# (uncheckedShiftRL# ww 1#) 9223372036854775808## } in - let { zeros = word2Int# (ctz# ds3) } in - (# Just ipv4, uncheckedShiftRL# hi1 zeros, + let { zeros = ctz# ds3 } in + let { zeros1 = word2Int# zeros } in + (# Just ipv4, uncheckedShiftRL# hi1 zeros1, or# (uncheckedShiftRL# - (or# (uncheckedShiftRL# ds3 1#) (uncheckedShiftL# ww 63#)) zeros) - (uncheckedShiftL# hi1 (-# 64# zeros)) #); + (or# (uncheckedShiftRL# ds3 1#) (uncheckedShiftL# ww 63#)) zeros1) + (uncheckedShiftL# hi1 (-# 64# zeros1)) #); 0## -> (# Just ipv4, 0##, uncheckedShiftRL# @@ -138,12 +140,13 @@ $w$sgo15 __DEFAULT -> let { hi1 = or# (uncheckedShiftRL# ww 1#) 9223372036854775808## } in - let { zeros = word2Int# (ctz# ds3) } in - (# Nothing, uncheckedShiftRL# hi1 zeros, + let { zeros = ctz# ds3 } in + let { zeros1 = word2Int# zeros } in + (# Nothing, uncheckedShiftRL# hi1 zeros1, or# (uncheckedShiftRL# - (or# (uncheckedShiftRL# ds3 1#) (uncheckedShiftL# ww 63#)) zeros) - (uncheckedShiftL# hi1 (-# 64# zeros)) #); + (or# (uncheckedShiftRL# ds3 1#) (uncheckedShiftL# ww 63#)) zeros1) + (uncheckedShiftL# hi1 (-# 64# zeros1)) #); 0## -> (# Nothing, 0##, uncheckedShiftRL# @@ -156,7 +159,8 @@ end Rec } $salterF = \ @v @a f1 k1 m -> - case $w$sgo15 9223372036854775808## 0## k1 m of + case k1 of k2 { __DEFAULT -> + case $w$sgo15 9223372036854775808## 0## k2 m of { (# ww, ww1, ww2 #) -> case f1 ww of { NotFound -> NotFound; @@ -167,18 +171,22 @@ $salterF Nothing -> case ww of { Nothing -> m; - Just old -> case $wbogus (##) of { __DEFAULT -> $wgo ww1 ww2 m } + Just old -> + case m of m1 { __DEFAULT -> + case $wbogus (##) of { __DEFAULT -> $wgo ww1 ww2 m1 } + } }; Just new -> case new of new1 { __DEFAULT -> case ww of { - Nothing -> $winsertAlong ww1 ww2 k1 new1 m; + Nothing -> $winsertAlong ww1 ww2 k2 new1 m; Just ds -> $wreplaceAlong ww1 ww2 new1 m } } }) } } + } lvl = \ @v ds -> @@ -190,10 +198,12 @@ lvl Rec { $wfoo = \ @v x subst -> - case $salterF lvl x subst of { + case x of x1 { __DEFAULT -> + case subst of subst1 { __DEFAULT -> + case $salterF lvl x1 subst1 of { NotFound -> - case x of wild1 { - Left x1 -> $wfoo wild1 subst; + case x1 of wild1 { + Left x2 -> $wfoo wild1 subst1; Right y -> $wfoo (Right @@ -204,10 +214,12 @@ $wfoo 1# -> C# (chr# i#) } })) - subst + subst1 }; Found p q -> (# p, q #) } + } + } end Rec } foo diff --git a/testsuite/tests/simplCore/should_compile/T7360.stderr b/testsuite/tests/simplCore/should_compile/T7360.stderr index f97a63873656..dbbadd9f2a00 100644 --- a/testsuite/tests/simplCore/should_compile/T7360.stderr +++ b/testsuite/tests/simplCore/should_compile/T7360.stderr @@ -1,15 +1,15 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 116, types: 50, coercions: 0, joins: 0/0} + = {terms: 119, types: 52, coercions: 0, joins: 0/0} -- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0} T7360.$WFoo3 [InlPrag=INLINE[final] CONLIKE] :: Int %1 -> Foo [GblId[DataConWrapper], Arity=1, Str=<SL>, - Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) Tmpl= \ (conrep [Occ=Once1!] :: Int) -> case conrep of { GHC.Types.I# unbx [Occ=Once1] -> @@ -31,8 +31,8 @@ fun1 [InlPrag=NOINLINE[final]] :: Foo -> () Arity=1, Str=<1A>, Cpr=1, - Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) Tmpl= \ (x [Occ=Once1] :: Foo) -> case T7360.$wfun1 x of { (# #) -> GHC.Tuple.Prim.() }}] @@ -43,65 +43,75 @@ fun1 -- RHS size: {terms: 5, types: 1, coercions: 0, joins: 0/0} T7360.fun4 :: () [GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False, - WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 30 10}] + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=False, ConLike=False, WorkFree=False, Expandable=False, + Guidance=IF_ARGS [] 30 10}] T7360.fun4 = case T7360.$wfun1 T7360.Foo1 of { (# #) -> GHC.Tuple.Prim.() } --- RHS size: {terms: 11, types: 7, coercions: 0, joins: 0/0} +-- RHS size: {terms: 14, types: 9, coercions: 0, joins: 0/0} fun2 :: forall {a}. [a] -> ((), Int) [GblId, Arity=1, Str=<ML>, Cpr=1, - Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) Tmpl= \ (@a) (x [Occ=Once1] :: [a]) -> (T7360.fun4, - case GHC.List.$wlenAcc @a x 0# of ww1 [Occ=Once1] { __DEFAULT -> + case x of wild [Occ=Once1] { __DEFAULT -> + case GHC.List.$wlenAcc @a wild 0# of ww1 [Occ=Once1] { __DEFAULT -> GHC.Types.I# ww1 + } })}] fun2 = \ (@a) (x :: [a]) -> (T7360.fun4, - case GHC.List.$wlenAcc @a x 0# of ww1 { __DEFAULT -> + case x of wild { __DEFAULT -> + case GHC.List.$wlenAcc @a wild 0# of ww1 { __DEFAULT -> GHC.Types.I# ww1 + } }) -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T7360.$trModule4 :: GHC.Prim.Addr# [GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 20 0}] T7360.$trModule4 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T7360.$trModule3 :: GHC.Types.TrName [GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] T7360.$trModule3 = GHC.Types.TrNameS T7360.$trModule4 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T7360.$trModule2 :: GHC.Prim.Addr# [GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 30 0}] T7360.$trModule2 = "T7360"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T7360.$trModule1 :: GHC.Types.TrName [GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] T7360.$trModule1 = GHC.Types.TrNameS T7360.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} T7360.$trModule :: GHC.Types.Module [GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] T7360.$trModule = GHC.Types.Module T7360.$trModule3 T7360.$trModule1 @@ -115,22 +125,25 @@ $krep -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T7360.$tcFoo2 :: GHC.Prim.Addr# [GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 20 0}] T7360.$tcFoo2 = "Foo"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T7360.$tcFoo1 :: GHC.Types.TrName [GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] T7360.$tcFoo1 = GHC.Types.TrNameS T7360.$tcFoo2 -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} T7360.$tcFoo :: GHC.Types.TyCon [GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] T7360.$tcFoo = GHC.Types.TyCon 1581370841583180512#Word64 @@ -150,22 +163,25 @@ T7360.$tc'Foo4 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T7360.$tc'Foo6 :: GHC.Prim.Addr# [GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 30 0}] T7360.$tc'Foo6 = "'Foo1"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T7360.$tc'Foo5 :: GHC.Types.TrName [GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] T7360.$tc'Foo5 = GHC.Types.TrNameS T7360.$tc'Foo6 -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} T7360.$tc'Foo1 :: GHC.Types.TyCon [GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] T7360.$tc'Foo1 = GHC.Types.TyCon 3986951253261644518#Word64 @@ -178,22 +194,25 @@ T7360.$tc'Foo1 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T7360.$tc'Foo8 :: GHC.Prim.Addr# [GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 30 0}] T7360.$tc'Foo8 = "'Foo2"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T7360.$tc'Foo7 :: GHC.Types.TrName [GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] T7360.$tc'Foo7 = GHC.Types.TrNameS T7360.$tc'Foo8 -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} T7360.$tc'Foo2 :: GHC.Types.TyCon [GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] T7360.$tc'Foo2 = GHC.Types.TyCon 17325079864060690428#Word64 @@ -211,22 +230,25 @@ T7360.$tc'Foo9 = GHC.Types.KindRepFun $krep T7360.$tc'Foo4 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T7360.$tc'Foo11 :: GHC.Prim.Addr# [GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 30 0}] T7360.$tc'Foo11 = "'Foo3"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T7360.$tc'Foo10 :: GHC.Types.TrName [GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] T7360.$tc'Foo10 = GHC.Types.TrNameS T7360.$tc'Foo11 -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} T7360.$tc'Foo3 :: GHC.Types.TyCon [GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] T7360.$tc'Foo3 = GHC.Types.TyCon 3674231676522181654#Word64 diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index ae23fcd3620e..ae9c75853225 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -417,8 +417,10 @@ test('T21391', normal, compile, ['-O -dcore-lint']) # T22112: Simply test that dumping the Core doesn't loop becuse of the unfolding and ignore the dump output test('T22112', [ grep_errmsg('never matches') ], compile, ['-O -dsuppress-uniques -dno-typeable-binds -fexpose-all-unfoldings -ddump-simpl']) test('T21391a', normal, compile, ['-O -dcore-lint']) + # We don't want to see a thunk allocation for the insertBy expression after CorePrep. -test('T21392', [ grep_errmsg(r'sat.* :: \[\(.*Unique, .*Int\)\]'), expect_broken(21392) ], compile, ['-O -ddump-prep -dno-typeable-binds -dsuppress-uniques']) +test('T21392', [ grep_errmsg(r'sat.* :: \[\(.*Unique, .*Int\)\]') ], compile, ['-O -ddump-prep -dno-typeable-binds -dsuppress-uniques']) + test('T21689', [extra_files(['T21689a.hs'])], multimod_compile, ['T21689', '-v0 -O']) test('T21801', normal, compile, ['-O -dcore-lint']) test('T21848', [grep_errmsg(r'SPEC wombat') ], compile, ['-O -ddump-spec']) -- GitLab