[Git][ghc/ghc][wip/nested-cpr-2019] 3 commits: Accept two more changed test outputs
Sebastian Graf
gitlab at gitlab.haskell.org
Wed Apr 29 14:02:28 UTC 2020
Sebastian Graf pushed to branch wip/nested-cpr-2019 at Glasgow Haskell Compiler / GHC
Commits:
fe309b07 by Sebastian Graf at 2020-04-27T12:46:41+02:00
Accept two more changed test outputs
- - - - -
0f2dc7d4 by Sebastian Graf at 2020-04-29T16:01:40+02:00
Update CaseBinderCPR with a new function
- - - - -
e64516e7 by Sebastian Graf at 2020-04-29T16:02:23+02:00
Don't give the case binder the CPR property
- - - - -
6 changed files:
- compiler/GHC/Core/Opt/CprAnal.hs
- compiler/GHC/Types/Cpr.hs
- testsuite/tests/cpranal/sigs/CaseBinderCPR.hs
- testsuite/tests/cpranal/sigs/CaseBinderCPR.stderr
- testsuite/tests/deSugar/should_compile/T2431.stderr
- testsuite/tests/simplCore/should_compile/T7360.stderr
Changes:
=====================================
compiler/GHC/Core/Opt/CprAnal.hs
=====================================
@@ -27,13 +27,12 @@ import GHC.Core.DataCon
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Core.Utils ( exprIsHNF, dumpIdInfoOfProgram )
-import GHC.Core.TyCon
import GHC.Core.Type
import GHC.Core.FamInstEnv
import GHC.Core.Opt.WorkWrap.Utils
import Util
import ErrUtils ( dumpIfSet_dyn, DumpFormat (..) )
-import Maybes ( isJust, isNothing )
+import Maybes ( isNothing )
{- Note [Constructed Product Result]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -205,10 +204,8 @@ cprAnal' env args (Case scrut case_bndr ty alts)
-- head strictness.
(scrut_ty, scrut') = cprAnal env [] scrut
(whnf_flag, case_bndr_ty) = forceCprTy (getStrDmd seqDmd) scrut_ty
- -- Regardless of whether scrut had the CPR property or not, the case binder
- -- certainly has it. See 'extendEnvForDataAlt'.
- (alt_tys, alts') = mapAndUnzip (cprAnalAlt env args case_bndr case_bndr_ty) alts
- res_ty = lubCprTypes alt_tys `bothCprType` whnf_flag
+ (alt_tys, alts') = mapAndUnzip (cprAnalAlt env args case_bndr case_bndr_ty) alts
+ res_ty = lubCprTypes alt_tys `bothCprType` whnf_flag
cprAnal' env args (Let (NonRec id rhs) body)
= (body_ty, Let (NonRec id' rhs') body')
@@ -477,19 +474,10 @@ nonVirgin env = env { ae_virgin = False }
extendEnvForDataAlt :: AnalEnv -> Id -> CprType -> DataCon -> [Var] -> AnalEnv
-- See Note [CPR in a DataAlt case alternative]
extendEnvForDataAlt env case_bndr case_bndr_ty dc bndrs
- = extendAnalEnv env' case_bndr (CprSig case_bndr_ty')
+ = extendAnalEnv env' case_bndr (CprSig case_bndr_ty)
where
- tycon = dataConTyCon dc
- is_product = isJust (isDataProductTyCon_maybe tycon)
- is_sum = isJust (isDataSumTyCon_maybe tycon)
- case_bndr_ty'
- | is_product || is_sum = markConCprType dc case_bndr_ty
- -- Any of the constructors had existentials. This is a little too
- -- conservative (after all, we only care about the particular data con),
- -- but there is no easy way to write is_sum and this won't happen much.
- | otherwise = case_bndr_ty
env'
- | Just fields <- splitConCprTy dc case_bndr_ty'
+ | Just fields <- splitConCprTy dc case_bndr_ty
, let ids = filter isId bndrs
, let cpr_tys = map (CprSig . CprType 0) fields
= extendAnalEnvList env (zipEqual "extendEnvForDataAlt" ids cpr_tys)
=====================================
compiler/GHC/Types/Cpr.hs
=====================================
@@ -12,7 +12,7 @@ module GHC.Types.Cpr (
TerminationFlag (Terminates),
Cpr, topCpr, conCpr, whnfTermCpr, divergeCpr, lubCpr, asConCpr,
CprType (..), topCprType, whnfTermCprType, conCprType, lubCprType, lubCprTypes,
- pruneDeepCpr, markConCprType, splitConCprTy, applyCprTy, abstractCprTy,
+ pruneDeepCpr, splitConCprTy, applyCprTy, abstractCprTy,
abstractCprTyNTimes, ensureCprTyArity, trimCprTy,
forceCprTy, forceCpr, bothCprType,
cprTransformDataConSig, UnboxingStrategy, cprTransformSig, argCprTypesFromStrictSig,
@@ -303,21 +303,6 @@ 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 con_tag fields)
- where
- con_tag = dataConTag dc
- wkr_arity = dataConRepArity dc
- fields = case cpr of
- NoMoreCpr (Term _ (Levitate (Con t terms)))
- | con_tag == t -> map NoMoreCpr terms
- NoMoreCpr (Term _ Bot) -> replicate wkr_arity (NoMoreCpr botTerm)
- Cpr _ (Levitate (Con t cprs))
- | con_tag == t -> cprs
- Cpr _ Bot -> replicate wkr_arity botCpr
- _ -> replicate wkr_arity topCpr
-
splitConCprTy :: DataCon -> CprType -> Maybe [Cpr]
splitConCprTy dc (CprType 0 (Cpr _ l))
| Bot <- l
=====================================
testsuite/tests/cpranal/sigs/CaseBinderCPR.hs
=====================================
@@ -13,3 +13,9 @@ f_list_cmp a_cmp (a_x:a_xs) (a_y:a_ys)=
else r_order
where
r_order = a_cmp a_x a_y
+
+
+-- But not every case binder has the CPR property.
+-- x below does not and we should not CPR nestedly for it:
+g :: [Int] -> (Int, Int)
+g xs = let x = xs !! 0 in x `seq` (x, x)
=====================================
testsuite/tests/cpranal/sigs/CaseBinderCPR.stderr
=====================================
@@ -2,5 +2,6 @@
==================== Cpr signatures ====================
CaseBinderCPR.$trModule: #c1(#c1(#), #c1(#))
CaseBinderCPR.f_list_cmp: *c1(*)
+CaseBinderCPR.g: *c1(#, #)
=====================================
testsuite/tests/deSugar/should_compile/T2431.stderr
=====================================
@@ -7,7 +7,7 @@ Result size of Tidy Core
T2431.$WRefl [InlPrag=INLINE[0] CONLIKE] :: forall a. a :~: a
[GblId[DataConWrapper],
Caf=NoCafRefs,
- Cpr=#c1(),
+ 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)
=====================================
testsuite/tests/simplCore/should_compile/T7360.stderr
=====================================
@@ -9,6 +9,7 @@ T7360.$WFoo3 [InlPrag=INLINE[0] CONLIKE] :: Int -> Foo
Arity=1,
Caf=NoCafRefs,
Str=<S,U>,
+ Cpr=#c3(*),
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)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9acac76afc7ab639d60742c4a650de62a3be8860...e64516e7a710c7402660b9a05bdf97fa8f7d5134
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9acac76afc7ab639d60742c4a650de62a3be8860...e64516e7a710c7402660b9a05bdf97fa8f7d5134
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/20200429/fea69d85/attachment-0001.html>
More information about the ghc-commits
mailing list