Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : cardinality
http://hackage.haskell.org/trac/ghc/changeset/fb55ce2b236af800cf79a2f4421cd4d86dc682ba >--------------------------------------------------------------- commit fb55ce2b236af800cf79a2f4421cd4d86dc682ba Author: Ilya Sergey <[email protected]> Date: Wed Sep 19 12:39:03 2012 +0100 peeling call demand bug fixed >--------------------------------------------------------------- compiler/basicTypes/Demand.lhs | 9 ++++++--- compiler/stranal/DmdAnal.lhs | 16 +++++++++------- 2 files changed, 15 insertions(+), 10 deletions(-) diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs index d7c7f1a..f003d28 100644 --- a/compiler/basicTypes/Demand.lhs +++ b/compiler/basicTypes/Demand.lhs @@ -525,9 +525,12 @@ mkCallDmd (JD {strd = d, absd = a}) -- Returns result demand + one-shotness of the call peelCallDmd :: JointDmd -> Maybe (JointDmd, Count) -peelCallDmd (JD {strd = SCall d, absd = UCall c a}) = Just (mkJointDmd d a, c) -peelCallDmd (JD {strd = SCall d, absd = Used _}) = Just (mkJointDmd d top, Many) -peelCallDmd _ = Nothing +peelCallDmd (JD {strd = SCall d, absd = UCall c a}) = Just (mkJointDmd d a, c) +peelCallDmd (JD {strd = Lazy, absd = UCall c a}) = Just (mkJointDmd Lazy a, c) +peelCallDmd (JD {strd = Str, absd = UCall c a}) = Just (mkJointDmd Lazy a, c) +peelCallDmd (JD {strd = HyperStr, absd = UCall c a}) = Just (mkJointDmd HyperStr a, c) +peelCallDmd (JD {strd = SCall d, absd = Used _}) = Just (mkJointDmd d top, Many) +peelCallDmd _ = Nothing splitCallDmd :: JointDmd -> (Int, JointDmd) diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs index f78b13d..aff4664 100644 --- a/compiler/stranal/DmdAnal.lhs +++ b/compiler/stranal/DmdAnal.lhs @@ -159,7 +159,7 @@ dmdAnal env dmd (App fun arg) -- Non-type arguments (arg_dmd, res_ty) = splitDmdTy fun_ty (arg_ty, arg') = dmdAnal env arg_dmd arg in - -- pprTrace "dmdAnal-App" (vcat [ppr fun, ppr fun_ty]) $ + pprTrace "dmdAnal-App" (vcat [ppr fun, ppr fun_ty]) $ (res_ty `both` arg_ty, App fun' arg') dmdAnal env dmd (Lam var body) @@ -172,21 +172,22 @@ dmdAnal env dmd (Lam var body) | Just (body_dmd, One) <- peelCallDmd dmd -- A call demand, also a one-shot lambda = let - env' = extendSigsWithLam env var + env' = extendSigsWithLam env var (body_ty, body') = dmdAnal env' body_dmd body - (lam_ty, var') = annotateLamIdBndr env body_ty var - armed_var = setOneShotLambda var' + armed_var = setOneShotLambda var + (lam_ty, var') = annotateLamIdBndr env body_ty armed_var in - (lam_ty, Lam armed_var body') + pprTrace "dmdAnal-Lam-One" (vcat [ppr var, ppr dmd, ppr lam_ty]) $ + (lam_ty, Lam var' body') | Just (body_dmd, Many) <- peelCallDmd dmd -- 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 = body_ty `both` body_ty (lam_ty, var') = annotateLamIdBndr env body_ty var in + pprTrace "dmdAnal-Lam-Many" (vcat [ppr var, ppr dmd, ppr lam_ty]) $ (lam_ty, Lam var' body') @@ -195,6 +196,7 @@ dmdAnal env dmd (Lam var body) (body_ty, body') = dmdAnal env evalDmd body (lam_ty, var') = annotateLamIdBndr env body_ty var in + pprTrace "dmdAnal-Lam-Other" (vcat [ppr var, ppr dmd, ppr lam_ty]) $ (deferType lam_ty, Lam var' body') dmdAnal env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)]) @@ -660,7 +662,7 @@ mk_sig_ty thunk_cpr_ok rhs (DmdType fv dmds res) -- See Note [Lazy and unleasheable free variables] lazy_fv = filterUFM (not . can_be_unleahsed) fv unleashed_fv = filterUFM can_be_unleahsed fv - can_be_unleahsed d = isStrictDmd d || isSingleUsed d + can_be_unleahsed d = isStrictDmd d -- final_dmds = setUnpackStrategy dmds -- Set the unpacking strategy _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
