Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : cardinality
http://hackage.haskell.org/trac/ghc/changeset/185ca3fd2aee751ec34105a27d004a9198c3c12a >--------------------------------------------------------------- commit 185ca3fd2aee751ec34105a27d004a9198c3c12a Author: Ilya Sergey <[email protected]> Date: Wed Sep 19 15:38:08 2012 +0100 bugfix: demand analysis clauses rearranged; explanation added >--------------------------------------------------------------- compiler/basicTypes/Demand.lhs | 8 ++- compiler/stranal/DmdAnal.lhs | 114 ++++++++++++++++++++++++++------------- 2 files changed, 82 insertions(+), 40 deletions(-) diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs index f003d28..2c278f1 100644 --- a/compiler/basicTypes/Demand.lhs +++ b/compiler/basicTypes/Demand.lhs @@ -114,6 +114,11 @@ strProd sx | all (== Lazy) sx = strStr | otherwise = SProd sx +isStrict :: StrDmd -> Bool +isStrict (SCall s) = isStrict s +isStrict Lazy = False +isStrict _ = True + -- Pretty-printing instance Outputable StrDmd where ppr HyperStr = char 'B' @@ -472,7 +477,7 @@ instance Binary JointDmd where return $ mkJointDmd x y isStrictDmd :: Demand -> Bool -isStrictDmd (JD {strd = x}) = x /= top +isStrictDmd (JD {strd = x}) = isStrict x isProdUsage :: Demand -> Bool isProdUsage (JD {absd = (UProd _ _)}) = True @@ -527,7 +532,6 @@ mkCallDmd (JD {strd = d, absd = a}) peelCallDmd :: JointDmd -> Maybe (JointDmd, Count) 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 diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs index 57d700e..12f760e 100644 --- a/compiler/stranal/DmdAnal.lhs +++ b/compiler/stranal/DmdAnal.lhs @@ -94,6 +94,45 @@ dmdAnal _ dmd e | isAbs dmd -- top demand does not provide any way to infer something interesting = (topDmdType, e) +-- this case should go before analyzing with the lazy demand +-- see Note [Analyzing with lazy demand and lambdas] +dmdAnal env dmd (Lam var body) + | isTyVar var + = let + (body_ty, body') = dmdAnal env dmd body + in + (body_ty, Lam var body') + + | Just (body_dmd, One) <- peelCallDmd dmd + -- A call demand, also a one-shot lambda + = let + env' = extendSigsWithLam env var + (body_ty, body') = dmdAnal env' body_dmd body + armed_var = setOneShotLambda var + (lam_ty, var') = annotateLamIdBndr env body_ty armed_var + in + -- 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 + (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') + + + | otherwise -- Not enough demand on the lambda; but do the body + = let -- anyway to annotate it and gather free var info + (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 e | not (isStrictDmd dmd) = let (res_ty, e') = dmdAnal env fake_dmd e @@ -159,46 +198,8 @@ 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]) $ (res_ty `both` arg_ty, App fun' arg') -dmdAnal env dmd (Lam var body) - | isTyVar var - = let - (body_ty, body') = dmdAnal env dmd body - in - (body_ty, Lam var body') - - | Just (body_dmd, One) <- peelCallDmd dmd - -- A call demand, also a one-shot lambda - = let - env' = extendSigsWithLam env var - (body_ty, body') = dmdAnal env' body_dmd body - armed_var = setOneShotLambda var - (lam_ty, var') = annotateLamIdBndr env body_ty armed_var - in - -- 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 - (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') - - - | otherwise -- Not enough demand on the lambda; but do the body - = let -- anyway to annotate it and gather free var info - (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, _, _)]) -- Only one alternative with a product constructor | let tycon = dataConTyCon dc @@ -336,6 +337,43 @@ dmdAnalAlt env dmd (con,bndrs,rhs) in (final_alt_ty, (con, bndrs', rhs')) +\end{code} + +Note [Analyzing with lazy demand and lambdas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Because of some interferences between strictness and usage analyses, +the clause responsible for analyzing lambdas goes before the +administrative one, that creates a `fake` strict demand: + +dmdAnal env dmd e + | not (isStrictDmd dmd) + = let (res_ty, e') = dmdAnal env fake_dmd e + in -- compute as with a strict demand, return with a lazy demand + (deferType res_ty, e') + +The motivation for this rearrangement follows from the fact that for +strictness L = C(L) = C(C(L)). This polymothpic expansion is critical +for cardinality analysis of the following example: + +build g = (g (:) [], g (:) []) + +h z = build (\x -> \y -> x (y ++ z)) + +One can see that `build` assigns to `g` demand <L, +C(C1(U))>. Therefore, when analyzing the lambda `(\x -> \y -> x (y ++ +z))`, we expect the lambda \y -> ... to be annotated as "one-shot" +one. Therefore (\x -> \y -> x (y ++ z)) should be analyzed with a +demand <C(C(..), C(C1(U))>. However, had we the clause above coming +before analysis of lambda, the inner lambda (\y -> ...) would be +analyzed with demand U, rather than C1(U), as the "fake" strict demand +S cannot be polymorphically expanded for calls. + + + + +\begin{code} + addDataConPatDmds :: AltCon -> [Var] -> DmdType -> DmdType -- See Note [Add demands for strict constructors] addDataConPatDmds DEFAULT _ dmd_ty = dmd_ty _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
