[Git][ghc/ghc][wip/T24251] 2 commits: Stop dropping a case whose binder is demanded
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Thu Feb 1 09:34:55 UTC 2024
Simon Peyton Jones pushed to branch wip/T24251 at Glasgow Haskell Compiler / GHC
Commits:
3b7be722 by Simon Peyton Jones at 2024-02-01T09:34:39+00:00
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.
- - - - -
a2a12054 by Simon Peyton Jones at 2024-02-01T09:34:39+00:00
Remove redunant bangs in GHC.Num.Integer
There seems to be no good rationale for these bangs.
- - - - -
10 changed files:
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- libraries/ghc-bignum/src/GHC/Num/Integer.hs
- testsuite/tests/numeric/should_compile/T19641.stderr
- testsuite/tests/simplCore/should_compile/T15631.hs
- testsuite/tests/simplCore/should_compile/T15631.stdout
- testsuite/tests/simplCore/should_compile/T20103.stderr
- testsuite/tests/simplCore/should_compile/T22611.stderr
- testsuite/tests/simplCore/should_compile/T7360.stderr
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
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
=====================================
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
=====================================
libraries/ghc-bignum/src/GHC/Num/Integer.hs
=====================================
@@ -382,27 +382,27 @@ integerIsOne _ = False
-- | Not-equal predicate.
integerNe :: Integer -> Integer -> Bool
-integerNe !x !y = isTrue# (integerNe# x y)
+integerNe x y = isTrue# (integerNe# x y)
-- | Equal predicate.
integerEq :: Integer -> Integer -> Bool
-integerEq !x !y = isTrue# (integerEq# x y)
+integerEq x y = isTrue# (integerEq# x y)
-- | Lower-or-equal predicate.
integerLe :: Integer -> Integer -> Bool
-integerLe !x !y = isTrue# (integerLe# x y)
+integerLe x y = isTrue# (integerLe# x y)
-- | Lower predicate.
integerLt :: Integer -> Integer -> Bool
-integerLt !x !y = isTrue# (integerLt# x y)
+integerLt x y = isTrue# (integerLt# x y)
-- | Greater predicate.
integerGt :: Integer -> Integer -> Bool
-integerGt !x !y = isTrue# (integerGt# x y)
+integerGt x y = isTrue# (integerGt# x y)
-- | Greater-or-equal predicate.
integerGe :: Integer -> Integer -> Bool
-integerGe !x !y = isTrue# (integerGe# x y)
+integerGe x y = isTrue# (integerGe# x y)
-- | Equal predicate.
integerEq# :: Integer -> Integer -> Bool#
=====================================
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,8 +14,8 @@ integer_to_int
= \ eta ->
case eta of {
IS ipv -> Just (I# ipv);
- IP x1 -> Nothing;
- IN ds -> Nothing
+ IP x -> Nothing;
+ IN ds2 -> Nothing
}
=====================================
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
=====================================
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 ->
=====================================
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
=====================================
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
=====================================
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
=====================================
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'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2ed26e0bf273516a33cea934976f20009e05c63e...a2a12054bb0aaaa9a78f71bf08e3a7ae3c0bde5a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2ed26e0bf273516a33cea934976f20009e05c63e...a2a12054bb0aaaa9a78f71bf08e3a7ae3c0bde5a
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/20240201/2c19456c/attachment-0001.html>
More information about the ghc-commits
mailing list