[Git][ghc/ghc][wip/nested-cpr-2019] Fix DataConWrapperCpr and accept other test outputs
Sebastian Graf
gitlab at gitlab.haskell.org
Mon Apr 27 09:39:40 UTC 2020
Sebastian Graf pushed to branch wip/nested-cpr-2019 at Glasgow Haskell Compiler / GHC
Commits:
9acac76a by Sebastian Graf at 2020-04-27T11:39:31+02:00
Fix DataConWrapperCpr and accept other test outputs
- - - - -
7 changed files:
- compiler/GHC/Types/Cpr.hs
- compiler/GHC/Types/Id/Make.hs
- testsuite/tests/cpranal/sigs/DataConWrapperCpr.stderr
- testsuite/tests/deSugar/should_compile/T2431.stderr
- testsuite/tests/simplCore/should_compile/T13143.stderr
- testsuite/tests/simplCore/should_compile/spec-inline.stderr
- testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr
Changes:
=====================================
compiler/GHC/Types/Cpr.hs
=====================================
@@ -206,8 +206,8 @@ whnfTermCpr = Cpr Terminates Top
divergeCpr :: Cpr
divergeCpr = Cpr MightDiverge Bot
-conCpr :: TerminationFlag -> ConTag -> [Cpr] -> Cpr
-conCpr tf t fs = Cpr tf (Levitate (Con t fs))
+conCpr :: ConTag -> [Cpr] -> Cpr
+conCpr t fs = Cpr Terminates (Levitate (Con t fs))
-- | Forget encoded CPR info, but keep termination info.
forgetCpr :: Cpr -> Termination
@@ -299,13 +299,13 @@ extractArgCprAndTermination = map go
go _ = topCpr
conCprType :: ConTag -> [CprType] -> CprType
-conCprType con_tag args = CprType 0 (conCpr Terminates con_tag cprs)
+conCprType con_tag args = CprType 0 (conCpr con_tag cprs)
where
cprs = extractArgCprAndTermination args
markConCprType :: DataCon -> CprType -> CprType
markConCprType dc _ty@(CprType n cpr)
- = ASSERT2( n == 0, ppr _ty ) CprType 0 (conCpr Terminates con_tag fields)
+ = ASSERT2( n == 0, ppr _ty ) CprType 0 (conCpr con_tag fields)
where
con_tag = dataConTag dc
wkr_arity = dataConRepArity dc
=====================================
compiler/GHC/Types/Id/Make.hs
=====================================
@@ -611,6 +611,7 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
`setInlinePragInfo` wrap_prag
`setUnfoldingInfo` wrap_unf
`setStrictnessInfo` wrap_sig
+ `setCprInfo` mkCprSig wrap_arity wrap_cpr
-- We need to get the CAF info right here because GHC.Iface.Tidy
-- does not tidy the IdInfo of implicit bindings (like the wrapper)
-- so it not make sure that the CAF info is sane
@@ -627,6 +628,8 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
mk_dmd str | isBanged str = evalDmd
| otherwise = topDmd
+ wrap_cpr = conCpr (dataConTag data_con) (replicate wkr_arity topCpr)
+
wrap_prag = dataConWrapperInlinePragma
`setInlinePragmaActivation` activeDuringFinal
-- See Note [Activation for data constructor wrappers]
@@ -671,6 +674,7 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
-- The wrap_args are the arguments *other than* the eq_spec
-- Because we are going to apply the eq_spec args manually in the
-- wrapper
+ wkr_arity = dataConRepArity data_con
new_tycon = isNewTyCon tycon
arg_ibangs
=====================================
testsuite/tests/cpranal/sigs/DataConWrapperCpr.stderr
=====================================
@@ -7,6 +7,6 @@ DataConWrapperCpr.$tc'Foo: #c1(#, #, #c1(#c1(#), #c1(#)), #c1(#),
DataConWrapperCpr.$tcFoo: #c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #,
#c5(*))
DataConWrapperCpr.$trModule: #c1(#c1(#), #c1(#))
-DataConWrapperCpr.foo: #c1(#)
+DataConWrapperCpr.foo: #c1(*)
=====================================
testsuite/tests/deSugar/should_compile/T2431.stderr
=====================================
@@ -7,6 +7,7 @@ Result size of Tidy Core
T2431.$WRefl [InlPrag=INLINE[0] CONLIKE] :: forall a. a :~: a
[GblId[DataConWrapper],
Caf=NoCafRefs,
+ Cpr=#c1(),
Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)
@@ -16,7 +17,7 @@ T2431.$WRefl
-- RHS size: {terms: 4, types: 8, coercions: 0, joins: 0/0}
absurd :: forall a. (Int :~: Bool) -> a
-[GblId, Arity=1, Str=<L,U>b, Cpr=#b, Unf=OtherCon []]
+[GblId, Arity=1, Str=<L,U>b, Cpr=*b, Unf=OtherCon []]
absurd = \ (@a) (x :: Int :~: Bool) -> case x of { }
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
=====================================
testsuite/tests/simplCore/should_compile/T13143.stderr
=====================================
@@ -7,7 +7,7 @@ Rec {
-- RHS size: {terms: 4, types: 4, coercions: 0, joins: 0/0}
T13143.$wf [InlPrag=NOINLINE, Occ=LoopBreaker]
:: forall {a}. GHC.Prim.Void# -> a
-[GblId, Arity=1, Str=<B,A>b, Cpr=#b, Unf=OtherCon []]
+[GblId, Arity=1, Str=<B,A>b, Cpr=*b, Unf=OtherCon []]
T13143.$wf = \ (@a) _ [Occ=Dead] -> T13143.$wf @a GHC.Prim.void#
end Rec }
@@ -16,7 +16,7 @@ f [InlPrag=NOUSERINLINE[0]] :: forall a. Int -> a
[GblId,
Arity=1,
Str=<B,A>b,
- Cpr=#b,
+ Cpr=*b,
Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=True)
@@ -66,7 +66,7 @@ T13143.$trModule
-- RHS size: {terms: 2, types: 1, coercions: 0, joins: 0/0}
lvl :: Int
-[GblId, Str=b, Cpr=#b]
+[GblId, Str=b, Cpr=*b]
lvl = T13143.$wf @Int GHC.Prim.void#
Rec {
=====================================
testsuite/tests/simplCore/should_compile/spec-inline.stderr
=====================================
@@ -51,7 +51,7 @@ lvl = "spec-inline.hs:(19,5)-(29,25)|function go"#
-- RHS size: {terms: 2, types: 2, coercions: 0, joins: 0/0}
Roman.foo3 :: Int
-[GblId, Str=b, Cpr=#b]
+[GblId, Str=b, Cpr=*b]
Roman.foo3
= Control.Exception.Base.patError @'GHC.Types.LiftedRep @Int lvl
=====================================
testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr
=====================================
@@ -25,7 +25,7 @@ DmdAnalGADTs.$tc'B: #c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #,
DmdAnalGADTs.$tcD: #c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #,
#c4(#c5(*), #c5(*)))
DmdAnalGADTs.$trModule: #c1(#c1(#), #c1(#))
-DmdAnalGADTs.diverges: *(#..)
+DmdAnalGADTs.diverges: *b
DmdAnalGADTs.f: *
DmdAnalGADTs.f': #c1(#)
DmdAnalGADTs.g: *
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9acac76afc7ab639d60742c4a650de62a3be8860
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9acac76afc7ab639d60742c4a650de62a3be8860
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/20200427/265c0040/attachment-0001.html>
More information about the ghc-commits
mailing list