Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : cardinality
http://hackage.haskell.org/trac/ghc/changeset/c64052042677458dbdfb19f4eef6f4b5d8d8d137 >--------------------------------------------------------------- commit c64052042677458dbdfb19f4eef6f4b5d8d8d137 Author: Ilya Sergey <[email protected]> Date: Tue Sep 4 00:08:23 2012 +0100 single-shot call demands added >--------------------------------------------------------------- compiler/basicTypes/Demand.lhs | 16 +++++++++------- compiler/stranal/DmdAnal.lhs | 2 +- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs index d368d35..5a90f49 100644 --- a/compiler/basicTypes/Demand.lhs +++ b/compiler/basicTypes/Demand.lhs @@ -306,9 +306,9 @@ instance LatticeLike AbsDmd where both (UHead _) (UProd _ ux) = UProd Many ux both (UProd _ ux1) (UProd _ ux2) | length ux1 == length ux2 = absProd Many $ zipWith both ux1 ux2 - -- is it correct? - -- both (UCall _ u1) (UCall _ u2) = absCall Many (u1 `lub` u2) - both (UCall _ u1) (UCall _ u2) = absCall Many (u1 `both` u2) + -- is it correct? -- explain! + both (UCall _ u1) (UCall _ u2) = absCall Many (u1 `lub` u2) + --both (UCall _ u1) (UCall _ u2) = absCall Many (u1 `both` u2) both _ _ = top -- utility functions @@ -532,7 +532,7 @@ should be: <L,C(U(AU))>m mkCallDmd :: JointDmd -> JointDmd mkCallDmd (JD {strd = d, absd = a}) - = mkJointDmd (strCall d) (absCall Many a) + = mkJointDmd (strCall d) (absCall One a) -- TODO: think how to peel peelCallDmd :: JointDmd -> Maybe JointDmd @@ -556,11 +556,13 @@ isSingleShot :: JointDmd -> Bool isSingleShot (JD {absd=a}) = isUsedOnce a vanillaCall :: Arity -> Demand -vanillaCall 0 = evalDmd +vanillaCall 0 = + -- we have no ide how many times the result is going to be used + evalDmd vanillaCall n = - -- generate S^n (S) + -- generate C^n (S) let strComp = (iterate strCall strStr) !! n - absComp = (iterate (absCall Many) usedOnce) !! n + absComp = (iterate (absCall One) usedOnce) !! n in mkJointDmd strComp absComp \end{code} diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs index edee3c2..4eb8a79 100644 --- a/compiler/stranal/DmdAnal.lhs +++ b/compiler/stranal/DmdAnal.lhs @@ -393,7 +393,7 @@ dmdTransform env var dmd ------ LOCAL LET/REC BOUND THING | Just (StrictSig dmd_ty, top_lvl) <- lookupSigEnv env var - = -- pprTrace "dmdTransform-Local" (vcat [ppr var, ppr env, ppr dmd]) $ + = pprTrace "dmdTransform-Local" (vcat [ppr var, ppr dmd, ppr dmd_ty]) $ let fn_ty | dmdTypeDepth dmd_ty <= call_depth = dmd_ty | otherwise = deferType dmd_ty _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
