[Git][ghc/ghc][wip/refactor-demand] 3 commits: Unrelated pretty-printing improvement
Sebastian Graf
gitlab at gitlab.haskell.org
Fri Oct 30 17:12:54 UTC 2020
Sebastian Graf pushed to branch wip/refactor-demand at Glasgow Haskell Compiler / GHC
Commits:
e7f632bd by Sebastian Graf at 2020-10-30T15:51:55+01:00
Unrelated pretty-printing improvement
- - - - -
09ecf0e8 by Sebastian Graf at 2020-10-30T15:53:47+01:00
typo
- - - - -
87f49c7a by Sebastian Graf at 2020-10-30T18:11:10+01:00
Discard absent call demands in `lub` and `plus` (#18903)
Call demands are *relative* in the sense that a call demand `Cn(cd)`
on `g` says "`g` is called `n` times. Whenever `g` is called, the result
is used according to `cd`". Example from #18903:
```
h :: Int -> Int
h m =
let g :: Int -> (Int,Int)
g 1 = (m, 0)
g n = (2 * n, 2 `div` n)
{-# NOINLINE g #-}
in case m of
1 -> 0
2 -> snd (g m)
_ -> uncurry (+) (g m)
```
We want `1C1((1(U),S(U)))` as the demand on `g`, meaning that whenever
`g` is called, its second component is used strictly.
But from the first case alternative, where `g` is not called at all,
we get what is effectively an absent demand, which expands to `ACA(A)`.
If we blindly `lub` the A with the `(1(U),S(U))` from the other case
branches, we'll get `(1(U),1(U))`, so lazy in the second component.
But the `A` certainly means that the nested demands are redundant! The
premise for the information they encode is not met and should be
ignored, effectively treated like a bottom cardinality.
Thus, when we compute the `lub` or the `plus` of such an absent demand
with a proper call demand like `1C1((1(U),S(U)))`, we lub with
`botCleanDmd`. Thus we get `1C1((1(U),S(U)))` as the result, not
`1C1((1(U),1(U)))`, as wanted.
Fixes #18903.
- - - - -
9 changed files:
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Stg/Lift/Analysis.hs
- compiler/GHC/Types/Demand.hs
- compiler/GHC/Utils/Outputable.hs
- + testsuite/tests/stranal/should_compile/T18903.hs
- + testsuite/tests/stranal/should_compile/T18903.stderr
- testsuite/tests/stranal/should_compile/all.T
- testsuite/tests/stranal/sigs/CaseBinderCPR.stderr
- testsuite/tests/stranal/sigs/T5075.stderr
Changes:
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -578,7 +578,7 @@ dmdAnalRhsLetDown rec_flag env let_dmd id rhs
-- last argument demands were. Strictness won't change. But used-once
-- might turn into used-many even if the signature was stable and we'd
-- have to do an additional iteration. reuseEnv makes sure that we
- -- never get used-once info for FVs of recursive fucntions.
+ -- never get used-once info for FVs of recursive functions.
rhs_fv1 = case rec_flag of
Just bs -> reuseEnv (delVarEnvList rhs_fv bs)
Nothing -> rhs_fv
=====================================
compiler/GHC/Stg/Lift/Analysis.hs
=====================================
@@ -173,9 +173,9 @@ instance Outputable Skeleton where
ppr (BothSk l r) = ppr l $$ ppr r
ppr (ClosureSk f fvs body) = ppr f <+> ppr fvs $$ nest 2 (ppr body)
ppr (RhsSk card body) = hcat
- [ char 'λ'
+ [ lambda
, ppr card
- , text ". "
+ , dot
, ppr body
]
=====================================
compiler/GHC/Types/Demand.hs
=====================================
@@ -542,8 +542,10 @@ lubCleanDmd :: CleanDemand -> CleanDemand -> CleanDemand
lubCleanDmd (Prod ds1) (viewProd (length ds1) -> Just ds2) =
Prod $ zipWith lubDmd ds1 ds2 -- TODO: What about Note [Used should win]?
-- Handle Call
-lubCleanDmd (Call n1 d1) (viewCall -> Just (n2, d2)) =
- Call (lubCard n1 n2) (lubCleanDmd d1 d2)
+lubCleanDmd (Call n1 d1) (viewCall -> Just (n2, d2))
+ -- See Note [Call demands are relative]
+ | isAbs n2 = Call (lubCard n1 n2) (lubCleanDmd d1 botCleanDmd)
+ | otherwise = Call (lubCard n1 n2) (lubCleanDmd d1 d2)
-- Handle Poly
lubCleanDmd (Poly n1) (Poly n2) = Poly (lubCard n1 n2)
-- Make use of reflexivity (so we'll match the Prod or Call cases again).
@@ -559,10 +561,10 @@ plusCleanDmd :: CleanDemand -> CleanDemand -> CleanDemand
plusCleanDmd (Prod ds1) (viewProd (length ds1) -> Just ds2) =
Prod $ zipWith plusDmd ds1 ds2
-- Handle Call
--- TODO: Exciting special treatment of inner demand for call demands:
--- use `lubUse` instead of `plusUse`!
-plusCleanDmd (Call n1 d1) (viewCall -> Just (n2, d2)) =
- Call (plusCard n1 n2) (lubCleanDmd d1 d2)
+plusCleanDmd (Call n1 d1) (viewCall -> Just (n2, d2))
+ -- See Note [Call demands are relative]
+ | isAbs n2 = Call (plusCard n1 n2) (lubCleanDmd d1 botCleanDmd)
+ | otherwise = Call (plusCard n1 n2) (lubCleanDmd d1 d2)
-- Handle Poly
plusCleanDmd (Poly n1) (Poly n2) = Poly (plusCard n1 n2)
-- Make use of reflexivity (so we'll match the Prod or Call cases again).
@@ -604,6 +606,44 @@ seqDemand _ = ()
seqDemandList :: [Demand] -> ()
seqDemandList = foldr (seq . seqDemand) ()
+{- Note [Call demands are relative]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The expression @if b then 0 else f 1 2 + f 3 4@ uses @f@ according to the demand
+ at UCU(CS(S(U)))@, meaning
+
+ "f is called multiple times (CU) or not at all, but each time it is called,
+ it's called with *exactly one* (CS) more argument.
+ Whenever it is called with two arguments, the result is used exactly once
+ (S(..)), but we have no info on how often the field is used (U)."
+
+So the 'CleanDemand' nested in a 'Call' demand is relative to exactly one call.
+And that extends to the information we have how its results are used in each
+call site. Consider (#18903)
+
+ h :: Int -> Int
+ h m =
+ let g :: Int -> (Int,Int)
+ g 1 = (m, 0)
+ g n = (2 * n, 2 `div` n)
+ {-# NOINLINE g #-}
+ in case m of
+ 1 -> 0
+ 2 -> snd (g m)
+ _ -> uncurry (+) (g m)
+
+We want to give @g@ the demand @1C1((1(U),S(U)))@, so we see that in each call
+site of @g@, we are strict in the second component of the returned pair.
+
+This relative cardinality leads to an otherwise unexpected call to 'lubCleanDmd'
+in 'plusCleanDmd', but if you do the math it's just the right thing.
+
+There's one more subtlety: Since the nested demand is relative to exactly one
+call, in the case where we have *at most zero calls* (e.g. CA(...)), the premise
+is hurt and we can assume that the nested demand is 'botCleanDmd'. That ensures
+that @g@ above actually gets the @S(U)@ demand on its second pair component,
+rather than the lazy @1(U)@ if we 'lub'bed with an absent demand.
+-}
+
{- Note [Scaling demands]
~~~~~~~~~~~~~~~~~~~~~~~~~
If a demand is used multiple times (/reused/), for example the argument in an
@@ -1189,7 +1229,7 @@ multCleanDmd :: Card -> CleanDemand -> CleanDemand
multCleanDmd n cd
| Just cd' <- multTrivial n seqCleanDmd cd = cd'
multCleanDmd n (Poly n') = Poly (multCard n n')
-multCleanDmd n (Call n' cd) = Call (multCard n n') cd -- TODO Note
+multCleanDmd n (Call n' cd) = Call (multCard n n') cd -- See Note [Call demands are relative]
multCleanDmd n (Prod ds) = Prod (map (multDmd n) ds)
multDmd :: Card -> Demand -> Demand
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -35,6 +35,7 @@ module GHC.Utils.Outputable (
doubleQuotes, angleBrackets,
semi, comma, colon, dcolon, space, equals, dot, vbar,
arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt,
+ lambda,
lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, mulArrow,
blankLine, forAllLit, bullet,
(<>), (<+>), hcat, hsep,
@@ -648,7 +649,7 @@ quotes d = sdocOption sdocCanUseUnicode $ \case
| otherwise -> Pretty.quotes pp_d
semi, comma, colon, equals, space, dcolon, underscore, dot, vbar :: SDoc
-arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt :: SDoc
+arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt, lambda :: SDoc
lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
blankLine = docToSDoc $ Pretty.text ""
@@ -661,6 +662,7 @@ arrowt = unicodeSyntax (char '⤚') (docToSDoc $ Pretty.text ">-")
larrowt = unicodeSyntax (char '⤙') (docToSDoc $ Pretty.text "-<")
arrowtt = unicodeSyntax (char '⤜') (docToSDoc $ Pretty.text ">>-")
larrowtt = unicodeSyntax (char '⤛') (docToSDoc $ Pretty.text "-<<")
+lambda = unicodeSyntax (char 'λ') (char '\\')
semi = docToSDoc $ Pretty.semi
comma = docToSDoc $ Pretty.comma
colon = docToSDoc $ Pretty.colon
=====================================
testsuite/tests/stranal/should_compile/T18903.hs
=====================================
@@ -0,0 +1,16 @@
+{-# OPTIONS_GHC -O2 -fforce-recomp #-}
+
+-- | The point of this test is that @g@ get's a demand that says "whenever @g@
+-- is called, the second component of the pair is evaluated strictly".
+module T18903 where
+
+h :: Int -> Int
+h m =
+ let g :: Int -> (Int,Int)
+ g 1 = (m, 0)
+ g n = (2 * n, 2 `div` n)
+ {-# NOINLINE g #-}
+ in case m of
+ 1 -> 0
+ 2 -> snd (g m)
+ _ -> uncurry (+) (g m)
=====================================
testsuite/tests/stranal/should_compile/T18903.stderr
=====================================
@@ -0,0 +1,113 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+ = {terms: 84, types: 55, coercions: 0, joins: 0/1}
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T18903.$trModule4 :: GHC.Prim.Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+T18903.$trModule4 = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T18903.$trModule3 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T18903.$trModule3 = GHC.Types.TrNameS T18903.$trModule4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T18903.$trModule2 :: GHC.Prim.Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+T18903.$trModule2 = "T18903"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T18903.$trModule1 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T18903.$trModule1 = GHC.Types.TrNameS T18903.$trModule2
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T18903.$trModule :: GHC.Types.Module
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T18903.$trModule
+ = GHC.Types.Module T18903.$trModule3 T18903.$trModule1
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T18903.h1 :: Int
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T18903.h1 = GHC.Types.I# 0#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T18903.h2 :: Int
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T18903.h2 = GHC.Types.I# -2#
+
+-- RHS size: {terms: 56, types: 41, coercions: 0, joins: 0/1}
+T18903.$wh [InlPrag=[2]] :: GHC.Prim.Int# -> Int
+[GblId,
+ Arity=1,
+ Str=<S*U>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [70] 262 10}]
+T18903.$wh
+ = \ (ww_s11L :: GHC.Prim.Int#) ->
+ let {
+ $wg_s11H [InlPrag=NOINLINE, Dmd=1C1((1(U),S(U)))]
+ :: GHC.Prim.Int# -> (# Int, Int #)
+ [LclId, Arity=1, Str=<SU>, Unf=OtherCon []]
+ $wg_s11H
+ = \ (ww1_s11C [OS=OneShot] :: GHC.Prim.Int#) ->
+ case ww1_s11C of ds_X3 {
+ __DEFAULT ->
+ (# GHC.Types.I# (GHC.Prim.*# 2# ds_X3),
+ case ds_X3 of {
+ __DEFAULT ->
+ case GHC.Classes.divInt# 2# ds_X3 of ww4_aZI { __DEFAULT ->
+ GHC.Types.I# ww4_aZI
+ };
+ -1# -> T18903.h2;
+ 0# -> case GHC.Real.divZeroError of wild1_00 { }
+ } #);
+ 1# -> (# GHC.Types.I# ww_s11L, T18903.h1 #)
+ } } in
+ case ww_s11L of ds_X2 {
+ __DEFAULT ->
+ case $wg_s11H ds_X2 of { (# ww2_s11O, ww3_s11P #) ->
+ case ww2_s11O of { GHC.Types.I# x_aZS ->
+ case ww3_s11P of { GHC.Types.I# y_aZV ->
+ GHC.Types.I# (GHC.Prim.+# x_aZS y_aZV)
+ }
+ }
+ };
+ 1# -> T18903.h1;
+ 2# -> case $wg_s11H 2# of { (# ww2_s11O, ww3_s11P #) -> ww3_s11P }
+ }
+
+-- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0}
+h [InlPrag=[2]] :: Int -> Int
+[GblId,
+ Arity=1,
+ Str=<S(S*U)>,
+ Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True,
+ Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
+ Tmpl= \ (w_s11I [Occ=Once1!] :: Int) ->
+ case w_s11I of { GHC.Types.I# ww1_s11L [Occ=Once1] ->
+ T18903.$wh ww1_s11L
+ }}]
+h = \ (w_s11I :: Int) ->
+ case w_s11I of { GHC.Types.I# ww1_s11L -> T18903.$wh ww1_s11L }
+
+
+
=====================================
testsuite/tests/stranal/should_compile/all.T
=====================================
@@ -55,3 +55,6 @@ test('T13380b', [ grep_errmsg('bigDeadAction') ], compile, ['-dppr-cols=200 -dd
# We just want to find the worker of foo in there:
test('T18122', [ grep_errmsg(r'wfoo =') ], compile, ['-ddump-simpl'])
+
+# We care about the call demand on $wg
+test('T18903', [ grep_errmsg(r'Dmd=\S+C\S+') ], compile, ['-ddump-simpl'])
=====================================
testsuite/tests/stranal/sigs/CaseBinderCPR.stderr
=====================================
@@ -1,7 +1,7 @@
==================== Strictness signatures ====================
CaseBinderCPR.$trModule:
-CaseBinderCPR.f_list_cmp: <UCU(C1((U)))><SU><SU>
+CaseBinderCPR.f_list_cmp: <UCU(CS((S*U)))><SU><SU>
@@ -13,6 +13,6 @@ CaseBinderCPR.f_list_cmp: m1
==================== Strictness signatures ====================
CaseBinderCPR.$trModule:
-CaseBinderCPR.f_list_cmp: <UCU(C1((1U)))><SU><SU>
+CaseBinderCPR.f_list_cmp: <UCU(CS((SU)))><SU><SU>
=====================================
testsuite/tests/stranal/sigs/T5075.stderr
=====================================
@@ -1,7 +1,7 @@
==================== Strictness signatures ====================
T5075.$trModule:
-T5075.loop: <S*(A,A,S*CS*(C1(U)),A,A,A,A,A)><U(A,A,UCU(C1(U)),A,A,A,UCU(U))><U>
+T5075.loop: <S*(A,A,S*CS*(CS(U)),A,A,A,A,A)><U(A,A,UCU(CS(U)),A,A,A,UCU(U))><U>
@@ -13,6 +13,6 @@ T5075.loop:
==================== Strictness signatures ====================
T5075.$trModule:
-T5075.loop: <S(A,A,S*CS*(C1(U)),A,A,A,A,A)><U(A,A,UCU(C1(U)),A,A,A,UCU(U))><U>
+T5075.loop: <S(A,A,S*CS*(CS(U)),A,A,A,A,A)><U(A,A,UCU(CS(U)),A,A,A,UCU(U))><U>
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3b237ed92121a9ecb884879c5b2da2b3f5f56437...87f49c7af6db5813549bdad74a53d0c3c89a3ec0
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3b237ed92121a9ecb884879c5b2da2b3f5f56437...87f49c7af6db5813549bdad74a53d0c3c89a3ec0
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/20201030/55ae8f2b/attachment-0001.html>
More information about the ghc-commits
mailing list