Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : cardinality
http://hackage.haskell.org/trac/ghc/changeset/dc69220d2db9cedbb200a148a9af0e505e9d3467 >--------------------------------------------------------------- commit dc69220d2db9cedbb200a148a9af0e505e9d3467 Author: Ilya Sergey <[email protected]> Date: Wed Sep 19 00:07:13 2012 +0100 a controversial treatment of call demands changed >--------------------------------------------------------------- compiler/basicTypes/Demand.lhs | 2 +- compiler/stranal/DmdAnal.lhs | 13 +++++-------- 2 files changed, 6 insertions(+), 9 deletions(-) diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs index aab016d..d7c7f1a 100644 --- a/compiler/basicTypes/Demand.lhs +++ b/compiler/basicTypes/Demand.lhs @@ -546,8 +546,8 @@ isSingleUsed (JD {absd=a}) = isUsedOnce a -- see Note [Default semands for right-hand sides] vanillaCall :: Arity -> Demand vanillaCall 0 = onceEvalDmd +-- generate C^n (U) vanillaCall n = - -- generate C^n (U) let strComp = (iterate strCall strStr) !! n absComp = (iterate (absCall Many) usedMany) !! n in mkJointDmd strComp absComp diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs index a8af607..f78b13d 100644 --- a/compiler/stranal/DmdAnal.lhs +++ b/compiler/stranal/DmdAnal.lhs @@ -170,7 +170,7 @@ dmdAnal env dmd (Lam var body) (body_ty, Lam var body') | Just (body_dmd, One) <- peelCallDmd dmd - -- A call demand, also a single-shot lambda + -- A call demand, also a one-shot lambda = let env' = extendSigsWithLam env var (body_ty, body') = dmdAnal env' body_dmd body @@ -180,12 +180,12 @@ dmdAnal env dmd (Lam var body) (lam_ty, Lam armed_var body') | Just (body_dmd, Many) <- peelCallDmd dmd - -- A call demand: good! + -- A call demand: good! (but not a one-shot lambda) = let env' = extendSigsWithLam env var (body_ty, body') = dmdAnal env' body_dmd body - coarse_ty = coarsenType body_ty - (lam_ty, var') = annotateLamIdBndr env coarse_ty var + -- coarse_ty = body_ty `both` body_ty + (lam_ty, var') = annotateLamIdBndr env body_ty var in (lam_ty, Lam var' body') @@ -196,9 +196,6 @@ dmdAnal env dmd (Lam var body) (lam_ty, var') = annotateLamIdBndr env body_ty var in (deferType lam_ty, Lam var' body') - where - coarsenType ty = ty `both` ty - dmdAnal env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)]) -- Only one alternative with a product constructor @@ -519,7 +516,7 @@ dmdAnalRhs top_lvl rec_flag env (id, rhs) (lazy_fv, sig_ty) = WARN( arity /= dmdTypeDepth rhs_dmd_ty && not (exprIsTrivial rhs), ppr id ) -- The RHS can be eta-reduced to just a variable, -- in which case we should not complain. - mkSigTy top_lvl rec_flag env id rhs rhs_dmd_ty + mkSigTy top_lvl rec_flag env id rhs rhs_dmd_ty id' = id `setIdStrictness` sig_ty sigs' = extendSigEnv top_lvl (sigEnv env) id sig_ty _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
