diff options
-rw-r--r-- | compiler/GHC/Types/Demand.hs | 49 | ||||
-rw-r--r-- | testsuite/tests/arityanal/should_compile/Arity11.stderr | 42 | ||||
-rw-r--r-- | testsuite/tests/arityanal/should_compile/Arity14.stderr | 16 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/T4908.stderr | 4 | ||||
-rw-r--r-- | testsuite/tests/stranal/should_compile/T10694.stderr | 6 | ||||
-rw-r--r-- | testsuite/tests/stranal/sigs/T19407.hs | 21 | ||||
-rw-r--r-- | testsuite/tests/stranal/sigs/T19407.stderr | 39 | ||||
-rw-r--r-- | testsuite/tests/stranal/sigs/T5075.stderr | 4 | ||||
-rw-r--r-- | testsuite/tests/stranal/sigs/all.T | 1 |
9 files changed, 141 insertions, 41 deletions
diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs index c4e25a1a47..2dc89cb175 100644 --- a/compiler/GHC/Types/Demand.hs +++ b/compiler/GHC/Types/Demand.hs @@ -716,7 +716,7 @@ These two SubDemands: are semantically equivalent, but we do not turn the former into the latter, for a regrettable-subtle reason. Consider f p1@(x,y) = (y,x) - g h p2@(_,_) = h p + g h p2@(_,_) = h p2 We want to unbox @p1@ of @f@, but not @p2@ of @g@, because @g@ only uses @p2@ boxed and we'd have to rebox. So we give @p1@ demand LP(L,L) and @p2@ demand @L@ to inform 'GHC.Core.Opt.WorkWrap.Utils.wantToUnboxArg', which will @@ -729,7 +729,7 @@ little bit of boxity analysis. Not very nice. Note [L should win] ~~~~~~~~~~~~~~~~~~~ Both in 'lubSubDmd' and 'plusSubDmd' we want @L `plusSubDmd` LP(..))@ to be @L@. -Why? Because U carries the implication the whole thing is used, box and all, +Why? Because L carries the implication the whole thing is used, box and all, so we don't want to w/w it, cf. Note [Don't optimise LP(L,L,...) to L]. If we use it both boxed and unboxed, then we are definitely using the box, and so we are quite likely to pay a reboxing cost. So we make U win here. @@ -751,6 +751,31 @@ Compare with: (C) making L win for plus, but LP(..) win for lub Max +0.1% +1.0% +21.0% +21.0% +0.5% Geometric Mean +0.0% +0.0% -0.0% -0.1% -0.1% +Note [Turn LP(A) into LP(M) in signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider T19407: + + data Huge = Huge Bool () ... () -- think: DynFlags + data T = T { h :: Huge, n :: Int } + f t@(T h _) = g h t + g (H b _ ... _) t = if b then 1 else n t + +The body of `g` puts (approx.) demand `LP(A,1)` on `t`. But we better not put +that demand in `g`'s signature! If we do, then `f` puts demand +`SP(1P(1L,A,..),ML)` on `t` and we get + + f (T (H b _ ... _) n) = $wf b n + $wf b n = $wg b (T (H b x ... x) n) + $wg = ... + +Massive reboxing in `$wf`! Solution: The signature of `g` should better say +`LP(M,1)`, then `f`'s signature says `SP(1P(1L,M,..),ML)` and `h` will not be +reboxed because passing all fields of `h` to `$wf` would run beyond the arg +limit in W/W. Which in turn means that `f` will not be W/W'd *at all*! +So this solution is quite unsatisfying as then `f`'s signature lies, probably +incurring reboxing at its call sites... I can think of no fix other than a = +proper boxity analysis. + Note [Computing one-shot info] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider a call @@ -1436,11 +1461,25 @@ newtype DmdSig deriving Eq -- | Turns a 'DmdType' computed for the particular 'Arity' into a 'DmdSig' --- unleashable at that arity. See Note [Understanding DmdType and DmdSig] +-- unleashable at that arity. See Note [Understanding DmdType and DmdSig]. mkDmdSigForArity :: Arity -> DmdType -> DmdSig mkDmdSigForArity arity dmd_ty@(DmdType fvs args div) - | arity < dmdTypeDepth dmd_ty = DmdSig (DmdType fvs (take arity args) div) - | otherwise = DmdSig (etaExpandDmdType arity dmd_ty) + | arity < dmdTypeDepth dmd_ty = DmdSig dmd_ty' + | otherwise = DmdSig (etaExpandDmdType arity dmd_ty') + where + -- See Note [Turn LP(A) into LP(M) in signatures] + args' = map forgetAbsentInLazyProd args + !dmd_ty' = DmdType fvs (take arity args') div + +forgetAbsentInLazyProd :: Demand -> Demand +forgetAbsentInLazyProd (n :* Prod ds) + | isStrict n = n :* Prod (map forgetAbsentInLazyProd ds) + | otherwise = n :* Prod (map abs_to_once ds) + where + abs_to_once d@(n :* _) + | isAbs n = polyDmd C_01 + | otherwise = d +forgetAbsentInLazyProd d = d mkClosedDmdSig :: [Demand] -> Divergence -> DmdSig mkClosedDmdSig ds res = mkDmdSigForArity (length ds) (DmdType emptyDmdEnv ds res) diff --git a/testsuite/tests/arityanal/should_compile/Arity11.stderr b/testsuite/tests/arityanal/should_compile/Arity11.stderr index 92c7649dd2..6581192225 100644 --- a/testsuite/tests/arityanal/should_compile/Arity11.stderr +++ b/testsuite/tests/arityanal/should_compile/Arity11.stderr @@ -1,6 +1,6 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 129, types: 94, coercions: 0, joins: 0/5} +Result size of Tidy Core = {terms: 129, types: 98, coercions: 0, joins: 0/5} -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} F11.fib1 :: Integer @@ -33,50 +33,50 @@ F11.f11_fib } end Rec } --- RHS size: {terms: 52, types: 26, coercions: 0, joins: 0/5} -F11.$wfib [InlPrag=[2]] :: forall {a1} {a2}. (a1 -> a1 -> Bool) -> (Num a1, Num a2) => a1 -> a2 -[GblId, Arity=4, Str=<SCS(C1(L))><LP(A,LCL(C1(L)),A,A,A,A,L)><LP(LCL(C1(L)),A,A,A,A,A,MCM(L))><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [60 150 60 0] 460 0}] +-- RHS size: {terms: 52, types: 27, coercions: 0, joins: 0/5} +F11.$wfib [InlPrag=[2]] :: forall {t} {a}. (t -> t -> Bool) -> (Num t, Num a) => t -> a +[GblId, Arity=4, Str=<SCS(C1(L))><LP(M,LCL(C1(L)),M,M,M,M,L)><LP(LCL(C1(L)),M,M,M,M,M,MCM(L))><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [60 150 60 0] 460 0}] F11.$wfib - = \ (@a) (@a1) (ww :: a -> a -> Bool) (w :: Num a) (w1 :: Num a1) (w2 :: a) -> + = \ (@t) (@a) (ww :: t -> t -> Bool) (w :: Num t) (w1 :: Num a) (w2 :: t) -> let { - lvl :: a + lvl :: t [LclId] - lvl = fromInteger @a w F11.fib3 } in + lvl = fromInteger @t w F11.fib3 } in let { - lvl1 :: a + lvl1 :: t [LclId] - lvl1 = fromInteger @a w F11.fib2 } in + lvl1 = fromInteger @t w F11.fib2 } in let { - lvl2 :: a1 + lvl2 :: a [LclId] - lvl2 = fromInteger @a1 w1 F11.fib3 } in + lvl2 = fromInteger @a w1 F11.fib3 } in let { - lvl3 :: a + lvl3 :: t [LclId] - lvl3 = fromInteger @a w F11.fib1 } in + lvl3 = fromInteger @t w F11.fib1 } in letrec { - fib4 [Occ=LoopBreaker, Dmd=SCS(L)] :: a -> a1 + fib4 [Occ=LoopBreaker, Dmd=SCS(L)] :: t -> a [LclId, Arity=1, Str=<L>, Unf=OtherCon []] fib4 - = \ (ds :: a) -> + = \ (ds :: t) -> case ww ds lvl3 of { False -> case ww ds lvl of { - False -> + @a1 w1 (fib4 (- @a w ds lvl)) (fib4 (- @a w ds lvl1)); + False -> + @a w1 (fib4 (- @t w ds lvl)) (fib4 (- @t w ds lvl1)); True -> lvl2 }; True -> lvl2 }; } in fib4 w2 --- RHS size: {terms: 14, types: 19, coercions: 0, joins: 0/0} -fib [InlPrag=[2]] :: forall {a1} {a2}. (Eq a1, Num a1, Num a2) => a1 -> a2 +-- RHS size: {terms: 14, types: 20, coercions: 0, joins: 0/0} +fib [InlPrag=[2]] :: forall {t} {a}. (Eq t, Num t, Num a) => t -> a [GblId, Arity=4, - Str=<1P(SCS(C1(L)),A)><LP(A,LCL(C1(L)),A,A,A,A,L)><LP(LCL(C1(L)),A,A,A,A,A,L)><L>, + Str=<1P(SCS(C1(L)),A)><LP(L,LCL(C1(L)),L,L,L,L,L)><LP(LCL(C1(L)),L,L,L,L,L,L)><L>, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=4,unsat_ok=True,boring_ok=False) - Tmpl= \ (@a) (@a1) (w [Occ=Once1!] :: Eq a) (w1 [Occ=Once1] :: Num a) (w2 [Occ=Once1] :: Num a1) (w3 [Occ=Once1] :: a) -> case w of { GHC.Classes.C:Eq ww1 [Occ=Once1] _ [Occ=Dead] -> F11.$wfib @a @a1 ww1 w1 w2 w3 }}] -fib = \ (@a) (@a1) (w :: Eq a) (w1 :: Num a) (w2 :: Num a1) (w3 :: a) -> case w of { GHC.Classes.C:Eq ww1 ww2 -> F11.$wfib @a @a1 ww1 w1 w2 w3 } + Tmpl= \ (@t) (@a) (w [Occ=Once1!] :: Eq t) (w1 [Occ=Once1] :: Num t) (w2 [Occ=Once1] :: Num a) (w3 [Occ=Once1] :: t) -> case w of { GHC.Classes.C:Eq ww [Occ=Once1] _ [Occ=Dead] -> F11.$wfib @t @a ww w1 w2 w3 }}] +fib = \ (@t) (@a) (w :: Eq t) (w1 :: Num t) (w2 :: Num a) (w3 :: t) -> case w of { GHC.Classes.C:Eq ww ww1 -> F11.$wfib @t @a ww w1 w2 w3 } -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} F11.f3 :: Integer diff --git a/testsuite/tests/arityanal/should_compile/Arity14.stderr b/testsuite/tests/arityanal/should_compile/Arity14.stderr index d2a9716d04..5a395e1343 100644 --- a/testsuite/tests/arityanal/should_compile/Arity14.stderr +++ b/testsuite/tests/arityanal/should_compile/Arity14.stderr @@ -1,8 +1,8 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 56, types: 81, coercions: 0, joins: 0/3} +Result size of Tidy Core = {terms: 56, types: 87, coercions: 0, joins: 0/3} --- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0} +-- RHS size: {terms: 3, types: 3, coercions: 0, joins: 0/0} F14.f1 :: forall {t}. t -> t [GblId, Arity=1, @@ -16,9 +16,9 @@ F14.f2 :: Integer [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 100 0}] F14.f2 = 1 --- RHS size: {terms: 35, types: 23, coercions: 0, joins: 0/3} +-- RHS size: {terms: 35, types: 24, coercions: 0, joins: 0/3} F14.$wf14 [InlPrag=[2]] :: forall {t}. (t -> t -> Bool) -> Num t => t -> t -> t -> t -[GblId, Arity=4, Str=<SCS(C1(L))><LP(LCL(C1(L)),A,A,A,A,A,MCM(L))><L><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [60 90 0 0] 300 0}] +[GblId, Arity=4, Str=<SCS(C1(L))><LP(LCL(C1(L)),M,M,M,M,M,MCM(L))><L><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [60 90 0 0] 300 0}] F14.$wf14 = \ (@t) (ww :: t -> t -> Bool) (w :: Num t) (w1 :: t) (w2 :: t) -> let { @@ -41,14 +41,14 @@ F14.$wf14 }; } in f3 w1 w2 --- RHS size: {terms: 13, types: 33, coercions: 0, joins: 0/0} +-- RHS size: {terms: 13, types: 34, coercions: 0, joins: 0/0} f14 [InlPrag=[2]] :: forall {t}. (Ord t, Num t) => t -> t -> t -> t [GblId, Arity=4, - Str=<1P(A,A,SCS(C1(L)),A,A,A,A,A)><LP(LCL(C1(L)),A,A,A,A,A,L)><L><L>, + Str=<1P(A,A,SCS(C1(L)),A,A,A,A,A)><LP(LCL(C1(L)),L,L,L,L,L,L)><L><L>, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=4,unsat_ok=True,boring_ok=False) - Tmpl= \ (@t) (w [Occ=Once1!] :: Ord t) (w1 [Occ=Once1] :: Num t) (w2 [Occ=Once1] :: t) (w3 [Occ=Once1] :: t) -> case w of { GHC.Classes.C:Ord _ [Occ=Dead] _ [Occ=Dead] ww3 [Occ=Once1] _ [Occ=Dead] _ [Occ=Dead] _ [Occ=Dead] _ [Occ=Dead] _ [Occ=Dead] -> F14.$wf14 @t ww3 w1 w2 w3 }}] -f14 = \ (@t) (w :: Ord t) (w1 :: Num t) (w2 :: t) (w3 :: t) -> case w of { GHC.Classes.C:Ord ww1 ww2 ww3 ww4 ww5 ww6 ww7 ww8 -> F14.$wf14 @t ww3 w1 w2 w3 } + Tmpl= \ (@t) (w [Occ=Once1!] :: Ord t) (w1 [Occ=Once1] :: Num t) (w2 [Occ=Once1] :: t) (w3 [Occ=Once1] :: t) -> case w of { GHC.Classes.C:Ord _ [Occ=Dead] _ [Occ=Dead] ww2 [Occ=Once1] _ [Occ=Dead] _ [Occ=Dead] _ [Occ=Dead] _ [Occ=Dead] _ [Occ=Dead] -> F14.$wf14 @t ww2 w1 w2 w3 }}] +f14 = \ (@t) (w :: Ord t) (w1 :: Num t) (w2 :: t) (w3 :: t) -> case w of { GHC.Classes.C:Ord ww ww1 ww2 ww3 ww4 ww5 ww6 ww7 -> F14.$wf14 @t ww2 w1 w2 w3 } diff --git a/testsuite/tests/simplCore/should_compile/T4908.stderr b/testsuite/tests/simplCore/should_compile/T4908.stderr index f8f9107485..6002e010ac 100644 --- a/testsuite/tests/simplCore/should_compile/T4908.stderr +++ b/testsuite/tests/simplCore/should_compile/T4908.stderr @@ -59,7 +59,7 @@ end Rec } T4908.$wf [InlPrag=[2]] :: Int# -> (Int, Int) -> Bool [GblId, Arity=2, - Str=<1L><MP(A,MP(ML))>, + Str=<1L><MP(M,MP(ML))>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [30 20] 101 20}] T4908.$wf @@ -81,7 +81,7 @@ T4908.$wf f [InlPrag=[2]] :: Int -> (Int, Int) -> Bool [GblId, Arity=2, - Str=<1P(1L)><MP(A,MP(ML))>, + Str=<1P(1L)><MP(M,MP(ML))>, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False) diff --git a/testsuite/tests/stranal/should_compile/T10694.stderr b/testsuite/tests/stranal/should_compile/T10694.stderr index 481c350fc2..a0891f8100 100644 --- a/testsuite/tests/stranal/should_compile/T10694.stderr +++ b/testsuite/tests/stranal/should_compile/T10694.stderr @@ -34,8 +34,8 @@ pm [InlPrag=[final]] :: Int -> Int -> (Int, Int) Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False) Tmpl= \ (w [Occ=Once1] :: Int) (w1 [Occ=Once1] :: Int) -> - case T10694.$wpm w w1 of { (# ww1 [Occ=Once1], ww2 [Occ=Once1] #) -> (ww1, ww2) }}] -pm = \ (w :: Int) (w1 :: Int) -> case T10694.$wpm w w1 of { (# ww1, ww2 #) -> (ww1, ww2) } + case T10694.$wpm w w1 of { (# ww [Occ=Once1], ww1 [Occ=Once1] #) -> (ww, ww1) }}] +pm = \ (w :: Int) (w1 :: Int) -> case T10694.$wpm w w1 of { (# ww, ww1 #) -> (ww, ww1) } -- RHS size: {terms: 8, types: 9, coercions: 0, joins: 0/0} m :: Int -> Int -> Int @@ -45,7 +45,7 @@ m :: Int -> Int -> Int Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False) Tmpl= \ (x [Occ=Once1] :: Int) (y [Occ=Once1] :: Int) -> case pm x y of { (_ [Occ=Dead], mr [Occ=Once1]) -> mr }}] -m = \ (x :: Int) (y :: Int) -> case T10694.$wpm x y of { (# ww1, ww2 #) -> ww2 } +m = \ (x :: Int) (y :: Int) -> case T10694.$wpm x y of { (# ww, ww1 #) -> ww1 } -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T10694.$trModule4 :: GHC.Prim.Addr# diff --git a/testsuite/tests/stranal/sigs/T19407.hs b/testsuite/tests/stranal/sigs/T19407.hs new file mode 100644 index 0000000000..af5eca8616 --- /dev/null +++ b/testsuite/tests/stranal/sigs/T19407.hs @@ -0,0 +1,21 @@ +{-# OPTIONS_GHC -O2 -fforce-recomp #-} + +-- | The gist here: `f` is strict in `t::T` and its field `h::Huge`, but mustn't unbox it. +-- Otherwise, `$wf` has to rebox it for the call to `$wg` (which is lazy in `t`) and that +-- also means reconstructing `h`, although most fields are absent anyway. +-- +-- Solution: `g` is lazy in `t` and we can't unbox it. Thus, its signature +-- shouldn't say which parts of `t` are absent! +module T19407 where + +data Huge = Huge Bool () () () () () () () () () () () () () () () () () () () () () +data T = T { h :: Huge, n :: Int } + +f :: T -> Int -- like warnAboutOverflowedLit +f t = g (h t) t +{-# NOINLINE f #-} + +g :: Huge -> T -> Int -- like warnAboutOverflowedLiterals +g (Huge b _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) t = + if b then 0 else n t +{-# NOINLINE g #-} diff --git a/testsuite/tests/stranal/sigs/T19407.stderr b/testsuite/tests/stranal/sigs/T19407.stderr new file mode 100644 index 0000000000..7604ec039e --- /dev/null +++ b/testsuite/tests/stranal/sigs/T19407.stderr @@ -0,0 +1,39 @@ + +==================== Strictness signatures ==================== +T19407.$tc'Huge: +T19407.$tc'T: +T19407.$tcHuge: +T19407.$tcT: +T19407.$trModule: +T19407.f: <SP(SP(SL,M,M,M,M,M,M,M,M,M,M,M,M,M,M,M,M,M,M,M,M,M),ML)> +T19407.g: <1P(1L,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A)><MP(M,ML)> +T19407.h: <1P(1L,A)> +T19407.n: <1P(A,1L)> + + + +==================== Cpr signatures ==================== +T19407.$tc'Huge: +T19407.$tc'T: +T19407.$tcHuge: +T19407.$tcT: +T19407.$trModule: +T19407.f: +T19407.g: +T19407.h: +T19407.n: + + + +==================== Strictness signatures ==================== +T19407.$tc'Huge: +T19407.$tc'T: +T19407.$tcHuge: +T19407.$tcT: +T19407.$trModule: +T19407.f: <1P(SP(SL,M,M,M,M,M,M,M,M,M,M,M,M,M,M,M,M,M,M,M,M,M),ML)> +T19407.g: <1P(1L,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A)><MP(M,ML)> +T19407.h: <1P(1L,A)> +T19407.n: <1P(A,1L)> + + diff --git a/testsuite/tests/stranal/sigs/T5075.stderr b/testsuite/tests/stranal/sigs/T5075.stderr index e17d5e7c5c..e25bc744e9 100644 --- a/testsuite/tests/stranal/sigs/T5075.stderr +++ b/testsuite/tests/stranal/sigs/T5075.stderr @@ -1,7 +1,7 @@ ==================== Strictness signatures ==================== T5075.$trModule: -T5075.loop: <SP(A,A,SCS(C1(L)),A,A,A,A,A)><LP(A,A,LCL(C1(L)),A,A,A,L)><L> +T5075.loop: <SP(A,A,SCS(C1(L)),A,A,A,A,A)><LP(M,M,LCL(C1(L)),M,M,M,L)><L> @@ -13,6 +13,6 @@ T5075.loop: ==================== Strictness signatures ==================== T5075.$trModule: -T5075.loop: <1P(A,A,SCS(C1(L)),A,A,A,A,A)><LP(A,A,LCL(C1(L)),A,A,A,L)><L> +T5075.loop: <1P(A,A,SCS(C1(L)),A,A,A,A,A)><LP(L,L,LCL(C1(L)),L,L,L,L)><L> diff --git a/testsuite/tests/stranal/sigs/all.T b/testsuite/tests/stranal/sigs/all.T index 5d562a6a8c..39a70e3577 100644 --- a/testsuite/tests/stranal/sigs/all.T +++ b/testsuite/tests/stranal/sigs/all.T @@ -23,3 +23,4 @@ test('T13380c', expect_broken('!3014'), compile, ['']) test('T13380f', normal, compile, ['']) test('T18086', normal, compile, ['-package ghc']) test('T18957', normal, compile, ['']) +test('T19407', normal, compile, ['']) |