Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : new-demand
http://hackage.haskell.org/trac/ghc/changeset/662e55b7ffd82f3187cb0cbbf360fe65797b2a3d >--------------------------------------------------------------- commit 662e55b7ffd82f3187cb0cbbf360fe65797b2a3d Author: Ilya Sergey <[email protected]> Date: Thu Jul 12 18:36:13 2012 +0100 more stuff in >--------------------------------------------------------------- compiler/basicTypes/NewDemand.lhs | 37 ++++++++++++++--- compiler/stranal/NewDmdAnal.lhs | 84 +++++++++++++++++++++++++++++++++++-- 2 files changed, 111 insertions(+), 10 deletions(-) diff --git a/compiler/basicTypes/NewDemand.lhs b/compiler/basicTypes/NewDemand.lhs index 1448b37..5cfbc39 100644 --- a/compiler/basicTypes/NewDemand.lhs +++ b/compiler/basicTypes/NewDemand.lhs @@ -10,7 +10,7 @@ module NewDemand ( LatticeLike, top, bot, lub, both, pre, StrDmd(..), strBot, strTop, strStr, strProd, AbsDmd(..), absBot, absTop, absProd, - Demand, JointDmd(..), mkJointDmd, isTop, + Demand, JointDmd(..), mkJointDmd, isTop, isAbs, DmdType(..), topDmdType, botDmdType, mkDmdType, mkTopDmdType, dmdTypeDepth, DmdEnv, emptyDmdEnv, @@ -21,7 +21,8 @@ module NewDemand ( seqStrDmd, seqStrDmdList, seqAbsDmd, seqAbsDmdList, seqDemand, seqDemandList, seqDmdType, seqStrictSig, - evalDmd, vanillaCall, isStrictDmd, + evalDmd, vanillaCall, isStrictDmd, splitCallDmd, splitDmdTy, + defer, deferType, deferEnv ) where #include "HsVersions.h" @@ -284,9 +285,13 @@ instance LatticeLike JointDmd where both (JD s1 a1) (JD s2 a2) = mkJointDmd (both s1 s2) $ both a1 a2 isTop :: JointDmd -> Bool -isTop (JD s a) - | s == top && a == top = True -isTop _ = False +isTop (JD s a) | s == top && a == top = True +isTop _ = False + +isAbs :: JointDmd -> Bool +isAbs (JD s a) | s == top && a == bot = True +isAbs _ = False + -- More utility functions for strictness seqDemand :: JointDmd -> () @@ -310,6 +315,12 @@ isStrictDmd (JD x _) = x /= top evalDmd :: JointDmd evalDmd = mkJointDmd strStr absTop +splitCallDmd :: JointDmd -> (Int, JointDmd) +splitCallDmd (JD (SProd False [d]) a) + = case splitCallDmd (JD d a) of + (n, r) -> (n + 1, r) +splitCallDmd d = (0, d) + vanillaCall :: Arity -> Demand vanillaCall 0 = evalDmd vanillaCall n = @@ -317,6 +328,9 @@ vanillaCall n = let strComp = (iterate (strProd False . return) strStr) !! n in mkJointDmd strComp absTop +defer :: Demand -> Demand +defer (JD _ a) = (JD bot a) + \end{code} %************************************************************************ @@ -450,7 +464,6 @@ resTypeArgDmd :: DmdResult -> Demand resTypeArgDmd r | isBotRes r = bot resTypeArgDmd _ = top - \end{code} %************************************************************************ @@ -555,6 +568,18 @@ seqDmdType :: DmdType -> () seqDmdType (DmdType _env ds res) = {- ??? env `seq` -} seqDemandList ds `seq` seqDmdResult res `seq` () +splitDmdTy :: DmdType -> (Demand, DmdType) +-- Split off one function argument +-- We already have a suitable demand on all +-- free vars, so no need to add more! +splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty) +splitDmdTy ty@(DmdType _ [] res_ty) = (resTypeArgDmd res_ty, ty) + +deferType :: DmdType -> DmdType +deferType (DmdType fv _ _) = DmdType (deferEnv fv) [] top + +deferEnv :: DmdEnv -> DmdEnv +deferEnv fv = mapVarEnv defer fv \end{code} %************************************************************************ diff --git a/compiler/stranal/NewDmdAnal.lhs b/compiler/stranal/NewDmdAnal.lhs index 9a6a0b8..0c82cfd 100644 --- a/compiler/stranal/NewDmdAnal.lhs +++ b/compiler/stranal/NewDmdAnal.lhs @@ -33,7 +33,10 @@ import Data.List import Id import CoreUtils ( exprIsHNF, exprIsTrivial ) import UniqFM - +import TyCon +import Pair +import Type +import Coercion ( coercionKind ) -- import Var ( Var, isTyVar ) -- import Util @@ -49,7 +52,6 @@ import UniqFM -- import UniqFM ( addToUFM_Directly, lookupUFM_Directly, -- minusUFM, filterUFM ) -- import Type ( isUnLiftedType, eqType, tyConAppTyCon_maybe ) --- import Coercion ( coercionKind ) -- import Pair @@ -99,10 +101,66 @@ dmdAnalTopBind sigs (Rec pairs) \begin{code} dmdAnal :: AnalEnv -> Demand -> CoreExpr -> (DmdType, CoreExpr) -dmdAnal _ dmd e | dmd == top +dmdAnal _ dmd e | isTop(dmd) || isAbs(dmd) -- top demand does not provide any way to infer something interesting = (topDmdType, e) +--Ilya: Why?! +dmdAnal env dmd e + | not (isStrictDmd dmd) + = let (res_ty, e') = dmdAnal env evalDmd e + in -- compute as with a strict demand, return with a lazy demand + (deferType res_ty, e') + -- It's important not to analyse e with a lazy demand because + -- a) When we encounter case s of (a,b) -> + -- we demand s with U(d1d2)... but if the overall demand is lazy + -- that is wrong, and we'd need to reduce the demand on s, + -- which is inconvenient + -- b) More important, consider + -- f (let x = R in x+x), where f is lazy + -- We still want to mark x as demanded, because it will be when we + -- enter the let. If we analyse f's arg with a Lazy demand, we'll + -- just mark x as Lazy + -- c) The application rule wouldn't be right either + -- Evaluating (f x) in a L demand does *not* cause + -- evaluation of f in a C(L) demand! + +dmdAnal _ _ (Lit lit) = (topDmdType, Lit lit) +dmdAnal _ _ (Type ty) = (topDmdType, Type ty) -- Doesn't happen, in fact +dmdAnal _ _ (Coercion co) = (topDmdType, Coercion co) + +dmdAnal env dmd (Var var) + = (dmdTransform env var dmd, Var var) + +dmdAnal env dmd (Cast e co) + = (dmd_ty, Cast e' co) + where + (dmd_ty, e') = dmdAnal env dmd' e + to_co = pSnd (coercionKind co) + dmd' + | Just tc <- tyConAppTyCon_maybe to_co + , isRecursiveTyCon tc = evalDmd + | otherwise = dmd + -- This coerce usually arises from a recursive + -- newtype, and we don't want to look inside them + -- for exactly the same reason that we don't look + -- inside recursive products -- we might not reach + -- a fixpoint. So revert to a vanilla Eval demand + +dmdAnal env dmd (Tick t e) + = (dmd_ty, Tick t e') + where + (dmd_ty, e') = dmdAnal env dmd e + +dmdAnal env dmd (App fun (Type ty)) + = (fun_ty, App fun' (Type ty)) + where + (fun_ty, fun') = dmdAnal env dmd fun + +dmdAnal sigs dmd (App fun (Coercion co)) + = (fun_ty, App fun' (Coercion co)) + where + (fun_ty, fun') = dmdAnal sigs dmd fun dmdAnal _ _ _ = undefined @@ -111,6 +169,25 @@ dmdAnal _ _ _ = undefined %************************************************************************ %* * + Demand transformer +%* * +%************************************************************************ + +\begin{code} +dmdTransform :: AnalEnv -- The strictness environment + -> Id -- The function + -> Demand -- The demand on the function + -> DmdType -- The demand type of the function in this context + -- Returned DmdEnv includes the demand on + -- this function plus demand on its free variables + +dmdTransform _ _ _ = undefined + +\end{code} + + +%************************************************************************ +%* * \subsection{Bindings} %* * %************************************************************************ @@ -145,7 +222,6 @@ dmdAnalRhs top_lvl rec_flag env (id, rhs) id' = id `nd_setIdStrictness` sig_ty sigs' = extendSigEnv top_lvl (sigEnv env) id' sig_ty - \end{code} %************************************************************************ _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
