[Git][ghc/ghc][wip/nested-cpr-2019] Fix DataConWrapperCpr and accept other test outputs

Sebastian Graf gitlab at gitlab.haskell.org
Mon Apr 27 07:22:40 UTC 2020



Sebastian Graf pushed to branch wip/nested-cpr-2019 at Glasgow Haskell Compiler / GHC


Commits:
edabf4c9 by Sebastian Graf at 2020-04-27T09:22:35+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 wrap_arity topCpr)
+
              wrap_prag = dataConWrapperInlinePragma
                          `setInlinePragmaActivation` activeDuringFinal
                          -- See Note [Activation for data constructor wrappers]


=====================================
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/edabf4c94323b2d79aeec8fe89897a97309beb9e

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/edabf4c94323b2d79aeec8fe89897a97309beb9e
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/58795a1c/attachment-0001.html>


More information about the ghc-commits mailing list