Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : cardinality
http://hackage.haskell.org/trac/ghc/changeset/54f353751e5c0d26ab62c744e1337eefc0f9d75d >--------------------------------------------------------------- commit 54f353751e5c0d26ab62c744e1337eefc0f9d75d Author: Ilya Sergey <[email protected]> Date: Thu Sep 27 23:22:39 2012 +0100 a bug with absent free variables fixed; first working cardinality analysis >--------------------------------------------------------------- compiler/basicTypes/Demand.lhs | 2 +- compiler/stranal/DmdAnal.lhs | 20 +++++++++++++------- 2 files changed, 14 insertions(+), 8 deletions(-) diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs index 8e27004..6e333f2 100644 --- a/compiler/basicTypes/Demand.lhs +++ b/compiler/basicTypes/Demand.lhs @@ -934,7 +934,7 @@ trimFvUsageTy :: DmdType -> DmdType trimFvUsageTy (DmdType fv ds res_ty) = DmdType (trimFvUsageEnv fv) ds res_ty trimFvUsageEnv :: DmdEnv -> DmdEnv -trimFvUsageEnv = mapVarEnv (\(JD {strd = s}) -> mkJointDmd s bot) +trimFvUsageEnv = mapVarEnv (\(JD {strd = s}) -> mkJointDmd s Abs) modifyEnv :: Bool -- No-op if False -> (Demand -> Demand) -- The zapper diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs index aaac680..2f3f405 100644 --- a/compiler/stranal/DmdAnal.lhs +++ b/compiler/stranal/DmdAnal.lhs @@ -278,8 +278,8 @@ dmdAnal _ env dmd (Let (NonRec id rhs) body) -- Add lazy free variables body_ty2 = addLazyFVs body_ty1 lazy_fv -- Add unleashed cardinality demands - unleashed_fv = unleash_card_dmds (id, id_dmd) - body_ty3 = addLazyFVs body_ty2 unleashed_fv + unleashed_fv = unleash_card_dmds (id2, id_dmd) + body_ty3 = addNewFVs body_ty2 unleashed_fv in -- If the actual demand is better than the vanilla call -- demand, you might think that we might do better to re-analyse @@ -312,7 +312,7 @@ dmdAnal _ env dmd (Let (Rec pairs) body) -- being recursive, we can't treat them strictly. -- But we do need to remove the binders from the result demand env unleashed_envs = map unleash_card_dmds var_dmds - body_ty3 = foldl addLazyFVs body_ty2 unleashed_envs + body_ty3 = foldl addNewFVs body_ty2 unleashed_envs in (body_ty3, Let (Rec pairs') body') @@ -554,11 +554,11 @@ dmdTransform env var dmd where (call_depth, res_dmd) = splitCallDmd dmd - adjustCardinality dt = if not_precise_call dt - then markAsUsedType dt else dt + adjustCardinality dt = if precise_call dt + then dt else markAsUsedType dt -- True is the demand is weaker than C1(C1(...)), where -- the number of C1 is taken from the transformer threshold - not_precise_call dt = not $ allSingleCalls (dmdTypeDepth dt) dmd + precise_call dt = allSingleCalls (dmdTypeDepth dt) dmd \end{code} @@ -672,6 +672,12 @@ addVarDmd :: DmdType -> Var -> Demand -> DmdType addVarDmd (DmdType fv ds res) var dmd = DmdType (extendVarEnv_C both fv var dmd) ds res +addNewFVs :: DmdType -> DmdEnv -> DmdType +addNewFVs (DmdType fv ds res) new_fvs + = DmdType both_fv ds res + where + both_fv = plusVarEnv_C both fv new_fvs + addLazyFVs :: DmdType -> DmdEnv -> DmdType addLazyFVs (DmdType fv ds res) lazy_fvs = DmdType both_fv1 ds res @@ -734,7 +740,7 @@ is <L,A>). -- Recursive bindings are automaticaly marked as used unleash_card_dmds :: (Var, Demand) -> DmdEnv unleash_card_dmds (id, id_dmd) - | isAbs id_dmd + | Abs <- absd id_dmd -- do not unleash anything for absent demands = emptyDmdEnv | otherwise _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
