[commit: ghc] new-demand: New demand analyser finished (e2851ba)
Ilya Sergey
ilya at galois.com
Fri Jul 13 22:04:55 CEST 2012
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : new-demand
http://hackage.haskell.org/trac/ghc/changeset/e2851ba19d2a1507b3ac8568573e5ea54d8f0bb8
>---------------------------------------------------------------
commit e2851ba19d2a1507b3ac8568573e5ea54d8f0bb8
Author: Ilya Sergey <Ilya.Sergey at cs.kuleuven.be>
Date: Fri Jul 13 19:15:39 2012 +0100
New demand analyser finished
>---------------------------------------------------------------
compiler/basicTypes/NewDemand.lhs | 11 ++--
compiler/stranal/NewDmdAnal.lhs | 97 ++++++++++++++++++++++++++++++++++--
2 files changed, 96 insertions(+), 12 deletions(-)
diff --git a/compiler/basicTypes/NewDemand.lhs b/compiler/basicTypes/NewDemand.lhs
index b99d0bb..638eb3b 100644
--- a/compiler/basicTypes/NewDemand.lhs
+++ b/compiler/basicTypes/NewDemand.lhs
@@ -23,7 +23,7 @@ module NewDemand (
seqStrDmd, seqStrDmdList, seqAbsDmd, seqAbsDmdList,
seqDemand, seqDemandList, seqDmdType, seqStrictSig,
evalDmd, vanillaCall, isStrictDmd, splitCallDmd, splitDmdTy,
- defer, deferType, deferEnv,
+ defer, deferType, deferEnv, modifyEnv,
isProdDmd, isPolyDmd, replicateDmd, splitProdDmd, peelCallDmd, mkCallDmd
) where
@@ -312,7 +312,7 @@ isPolyAbsDmd _ = False
\begin{code}
-data JointDmd = JD { str :: StrDmd, abs :: AbsDmd }
+data JointDmd = JD { strD :: StrDmd, absD :: AbsDmd }
deriving ( Eq, Show )
-- Pretty-printing
@@ -328,11 +328,10 @@ mkJointDmd s a
mkProdDmd :: [JointDmd] -> JointDmd
mkProdDmd dx
- = ASSERT( length sx == length ux)
- mkJointDmd sp up
+ = mkJointDmd sp up
where
- sp = strProd $ map str dx
- up = absProd $ map abs dx
+ sp = strProd $ map strD dx
+ up = absProd $ map absD dx
instance LatticeLike JointDmd where
bot = mkJointDmd bot bot
diff --git a/compiler/stranal/NewDmdAnal.lhs b/compiler/stranal/NewDmdAnal.lhs
index b986744..ce45c64 100644
--- a/compiler/stranal/NewDmdAnal.lhs
+++ b/compiler/stranal/NewDmdAnal.lhs
@@ -30,6 +30,7 @@ import VarEnv
import BasicTypes
import FastString
import Data.List
+import DataCon ( dataConTyCon, dataConRepStrictness )
import Id
import CoreUtils ( exprIsHNF, exprIsTrivial )
import PprCore
@@ -40,6 +41,9 @@ import Type
import Coercion ( coercionKind )
import Util
import Maybes ( orElse )
+import TysWiredIn ( unboxedPairDataCon )
+import TysPrim ( realWorldStatePrimTy )
+
-- import Var ( Var, isTyVar )
-- import Util
@@ -48,9 +52,7 @@ import Maybes ( orElse )
-- import Coercion ( isCoVarType )
-- import CoreUtils ( exprIsHNF, exprIsTrivial )
-- import CoreArity ( exprArity )
--- import DataCon ( dataConTyCon, dataConRepStrictness )
-- import TyCon ( isProductTyCon, isRecursiveTyCon )
--- import TysWiredIn ( unboxedPairDataCon )
-- import TysPrim ( realWorldStatePrimTy )
-- import UniqFM ( addToUFM_Directly, lookupUFM_Directly,
-- minusUFM, filterUFM )
@@ -245,7 +247,7 @@ dmdAnal env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)])
alt_dmd = mkProdDmd [nd_idDemandInfo b | b <- bndrs', isId b]
scrut_dmd = alt_dmd `both`
- idDemandInfo case_bndr'
+ nd_idDemandInfo case_bndr'
(scrut_ty, scrut') = dmdAnal env scrut_dmd scrut
res_ty = alt_ty1 `both` scrut_ty
@@ -257,7 +259,57 @@ dmdAnal env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)])
(res_ty, Case scrut' case_bndr' ty [alt'])
-dmdAnal _ _ _ = undefined
+dmdAnal env dmd (Case scrut case_bndr ty alts)
+ = let
+ (alt_tys, alts') = mapAndUnzip (dmdAnalAlt env dmd) alts
+ (scrut_ty, scrut') = dmdAnal env evalDmd scrut
+ (alt_ty, case_bndr') = annotateBndr (foldr lub botDmdType alt_tys) case_bndr
+ res_ty = alt_ty `both` scrut_ty
+ in
+-- pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut
+-- , text "scrut_ty" <+> ppr scrut_ty
+-- , text "alt_ty" <+> ppr alt_ty
+-- , text "res_ty" <+> ppr res_ty ]) $
+ (res_ty, Case scrut' case_bndr' ty alts')
+
+dmdAnal env dmd (Let (NonRec id rhs) body)
+ = let
+ (sigs', lazy_fv, (id1, rhs')) = dmdAnalRhs NotTopLevel NonRecursive env (id, rhs)
+ (body_ty, body') = dmdAnal (updSigEnv env sigs') dmd body
+ (body_ty1, id2) = annotateBndr body_ty id1
+ body_ty2 = addLazyFVs body_ty1 lazy_fv
+ in
+ -- If the actual demand is better than the vanilla call
+ -- demand, you might think that we might do better to re-analyse
+ -- the RHS with the stronger demand.
+ -- But (a) That seldom happens, because it means that *every* path in
+ -- the body of the let has to use that stronger demand
+ -- (b) It often happens temporarily in when fixpointing, because
+ -- the recursive function at first seems to place a massive demand.
+ -- But we don't want to go to extra work when the function will
+ -- probably iterate to something less demanding.
+ -- In practice, all the times the actual demand on id2 is more than
+ -- the vanilla call demand seem to be due to (b). So we don't
+ -- bother to re-analyse the RHS.
+ (body_ty2, Let (NonRec id2 rhs') body')
+
+dmdAnal env dmd (Let (Rec pairs) body)
+ = let
+ bndrs = map fst pairs
+ (sigs', lazy_fv, pairs') = dmdFix NotTopLevel env pairs
+ (body_ty, body') = dmdAnal (updSigEnv env sigs') dmd body
+ body_ty1 = addLazyFVs body_ty lazy_fv
+ in
+ sigs' `seq` body_ty `seq`
+ let
+ (body_ty2, _) = annotateBndrs body_ty1 bndrs
+ -- Don't bother to add demand info to recursive
+ -- binders as annotateBndr does;
+ -- being recursive, we can't treat them strictly.
+ -- But we do need to remove the binders from the result demand env
+ in
+ (body_ty2, Let (Rec pairs') body')
+
dmdAnalAlt :: AnalEnv -> Demand -> Alt Var -> (DmdType, Alt Var)
dmdAnalAlt env dmd (con,bndrs,rhs)
@@ -297,7 +349,7 @@ addDataConPatDmds (LitAlt _) _ dmd_ty = dmd_ty
addDataConPatDmds (DataAlt con) bndrs dmd_ty
= foldr add dmd_ty str_bndrs
where
- add bndr dmd_ty = addVarDmd dmd_ty bndr seqDmd
+ add bndr dmd_ty = addVarDmd dmd_ty bndr absDmd
str_bndrs = [ b | (b,s) <- zipEqual "addDataConPatBndrs"
(filter isId bndrs)
(dataConRepStrictness con)
@@ -489,6 +541,39 @@ addVarDmd :: DmdType -> Var -> Demand -> DmdType
addVarDmd (DmdType fv ds res) var dmd
= DmdType (extendVarEnv_C both fv var dmd) ds res
+addLazyFVs :: DmdType -> DmdEnv -> DmdType
+addLazyFVs (DmdType fv ds res) lazy_fvs
+ = DmdType both_fv1 ds res
+ where
+ both_fv = plusVarEnv_C both fv lazy_fvs
+ both_fv1 = modifyEnv (isBotRes res) (`both` bot) lazy_fvs fv both_fv
+ -- This modifyEnv is vital. Consider
+ -- let f = \x -> (x,y)
+ -- in error (f 3)
+ -- Here, y is treated as a lazy-fv of f, but we must `both` that L
+ -- demand with the bottom coming up from 'error'
+ --
+ -- I got a loop in the fixpointer without this, due to an interaction
+ -- with the lazy_fv filtering in mkSigTy. Roughly, it was
+ -- letrec f n x
+ -- = letrec g y = x `fatbar`
+ -- letrec h z = z + ...g...
+ -- in h (f (n-1) x)
+ -- in ...
+ -- In the initial iteration for f, f=Bot
+ -- Suppose h is found to be strict in z, but the occurrence of g in its RHS
+ -- is lazy. Now consider the fixpoint iteration for g, esp the demands it
+ -- places on its free variables. Suppose it places none. Then the
+ -- x `fatbar` ...call to h...
+ -- will give a x->V demand for x. That turns into a L demand for x,
+ -- which floats out of the defn for h. Without the modifyEnv, that
+ -- L demand doesn't get both'd with the Bot coming up from the inner
+ -- call to f. So we just get an L demand for x for g.
+ --
+ -- A better way to say this is that the lazy-fv filtering should give the
+ -- same answer as putting the lazy fv demands in the function's type.
+
+
removeFV :: DmdEnv -> Var -> DmdResult -> (DmdEnv, Demand)
removeFV fv id res = (fv', dmd)
where
@@ -503,7 +588,7 @@ annotateBndr :: DmdType -> Var -> (DmdType, Var)
-- No effect on the argument demands
annotateBndr dmd_ty@(DmdType fv ds res) var
| isTyVar var = (dmd_ty, var)
- | otherwise = (DmdType fv' ds res, setIdDemandInfo var dmd)
+ | otherwise = (DmdType fv' ds res, nd_setIdDemandInfo var dmd)
where
(fv', dmd) = removeFV fv var res
More information about the Cvs-ghc
mailing list