[commit: ghc] wip/nested-cpr: Make types of bothDmdType more precise (0596028)
git at git.haskell.org
git at git.haskell.org
Sat Dec 14 22:22:01 UTC 2013
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/nested-cpr
Link : http://ghc.haskell.org/trac/ghc/changeset/05960283bcb7d6243dd4398e29d66719d17398d1/ghc
>---------------------------------------------------------------
commit 05960283bcb7d6243dd4398e29d66719d17398d1
Author: Joachim Breitner <mail at joachim-breitner.de>
Date: Mon Dec 9 18:40:09 2013 +0000
Make types of bothDmdType more precise
by only passing the demand on the free variables, and whether the
argument (resp. scrunitee) may or will diverge.
>---------------------------------------------------------------
05960283bcb7d6243dd4398e29d66719d17398d1
compiler/basicTypes/Demand.lhs | 55 +++++++++++++++++++++++++---------------
compiler/stranal/DmdAnal.lhs | 9 +++----
2 files changed, 39 insertions(+), 25 deletions(-)
diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index e4f49a9..bd68ea5 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -21,6 +21,7 @@ module Demand (
DmdType(..), dmdTypeDepth, lubDmdType, bothDmdType,
nopDmdType, botDmdType, mkDmdType,
addDemand,
+ BothDmdArg, mkBothDmdArg, toBothDmdArg,
DmdEnv, emptyDmdEnv,
peelFV,
@@ -709,14 +710,15 @@ We have lubs, but not glbs; but that is ok.
-- Constructed Product Result
------------------------------------------------------------------------
-data CPRResult = NoCPR -- Top of the lattice
- | RetProd -- Returns a constructor from a product type
- | RetSum ConTag -- Returns a constructor from a sum type with this tag
+data Termination r = Diverges -- Definitely diverges
+ | Dunno r -- Might diverge or converge
deriving( Eq, Show )
-data DmdResult = Diverges -- Definitely diverges
- | Dunno CPRResult -- Might diverge or converge, but in the latter case the
- -- result shape is described by CPRResult
+type DmdResult = Termination CPRResult
+
+data CPRResult = NoCPR -- Top of the lattice
+ | RetProd -- Returns a constructor from a product type
+ | RetSum ConTag -- Returns a constructor from a data type
deriving( Eq, Show )
lubCPR :: CPRResult -> CPRResult -> CPRResult
@@ -733,7 +735,7 @@ lubDmdResult (Dunno c1) (Dunno c2) = Dunno (c1 `lubCPR` c2)
-- defaultDmd (r1 `lubDmdResult` r2) = defaultDmd r1 `lubDmd` defaultDmd r2
-- (See Note [Default demand on free variables] for why)
-bothDmdResult :: DmdResult -> DmdResult -> DmdResult
+bothDmdResult :: DmdResult -> Termination () -> DmdResult
-- See Note [Asymmetry of 'both' for DmdType and DmdResult]
bothDmdResult _ Diverges = Diverges
bothDmdResult r _ = r
@@ -1024,13 +1026,25 @@ lubDmdType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2)
lub_ds ds1 [] = map (`lubDmd` resTypeArgDmd r2) ds1
lub_ds [] ds2 = map (resTypeArgDmd r1 `lubDmd`) ds2
-bothDmdType :: DmdType -> DmdType -> DmdType
-bothDmdType (DmdType fv1 ds1 r1) (DmdType fv2 _ r2)
+
+type BothDmdArg = (DmdEnv, Termination ())
+
+mkBothDmdArg :: DmdEnv -> BothDmdArg
+mkBothDmdArg env = (env, Dunno ())
+
+toBothDmdArg :: DmdType -> BothDmdArg
+toBothDmdArg (DmdType fv _ r) = (fv, go r)
+ where
+ go (Dunno {}) = Dunno ()
+ go Diverges = Diverges
+
+bothDmdType :: DmdType -> BothDmdArg -> DmdType
+bothDmdType (DmdType fv1 ds1 r1) (fv2, t2)
-- See Note [Asymmetry of 'both' for DmdType and DmdResult]
-- 'both' takes the argument/result info from its *first* arg,
-- using its second arg just for its free-var info.
- = DmdType both_fv ds1 (r1 `bothDmdResult` r2)
- where both_fv = plusVarEnv_CD bothDmd fv1 (defaultDmd r1) fv2 (defaultDmd r2)
+ = DmdType both_fv ds1 (r1 `bothDmdResult` t2)
+ where both_fv = plusVarEnv_CD bothDmd fv1 (defaultDmd r1) fv2 (defaultDmd t2)
instance Outputable DmdType where
ppr (DmdType fv ds res)
@@ -1126,17 +1140,18 @@ toCleanDmd (JD { strd = s, absd = u })
-- This is used in dmdAnalStar when post-processing
-- a function's argument demand. So we only care about what
-- does to free variables, and whether it terminates.
-postProcessDmdTypeM :: DeferAndUseM -> DmdType -> DmdType
-postProcessDmdTypeM Nothing _ = nopDmdType
+postProcessDmdTypeM :: DeferAndUseM -> DmdType -> BothDmdArg
+postProcessDmdTypeM Nothing _ = (emptyDmdEnv, Dunno ())
-- Incoming demand was Absent, so just discard all usage information
-- We only processed the thing at all to analyse the body
-- See Note [Always analyse in virgin pass]
postProcessDmdTypeM (Just du) (DmdType fv _ res_ty)
- = DmdType (postProcessDmdEnv du fv) [] (postProcessDmdResult du res_ty)
+ = (postProcessDmdEnv du fv, postProcessDmdResult du res_ty)
-postProcessDmdResult :: DeferAndUse -> DmdResult -> DmdResult
-postProcessDmdResult (True,_) r = topRes
-postProcessDmdResult (False,_) r = r
+postProcessDmdResult :: DeferAndUse -> DmdResult -> Termination ()
+postProcessDmdResult (True,_) _ = topRes
+postProcessDmdResult (False,_) (Dunno {}) = Dunno ()
+postProcessDmdResult (False,_) Diverges = Diverges
postProcessDmdEnv :: DeferAndUse -> DmdEnv -> DmdEnv
postProcessDmdEnv (True, Many) env = deferReuseEnv env
@@ -1246,9 +1261,9 @@ peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv)
-- See note [Default demand on free variables]
dmd = lookupVarEnv fv id `orElse` defaultDmd res
-defaultDmd :: DmdResult -> Demand
-defaultDmd res | isBotRes res = botDmd
- | otherwise = absDmd
+defaultDmd :: Termination r -> Demand
+defaultDmd Diverges = botDmd
+defaultDmd _ = absDmd
addDemand :: Demand -> DmdType -> DmdType
addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index cbdcc67..a942c4e 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -115,7 +115,7 @@ dmdTransformThunkDmd e
-- See |-* relation in the companion paper
dmdAnalStar :: AnalEnv
-> Demand -- This one takes a *Demand*
- -> CoreExpr -> (DmdType, CoreExpr)
+ -> CoreExpr -> (BothDmdArg, CoreExpr)
dmdAnalStar env dmd e
| (cd, defer_and_use) <- toCleanDmd dmd
, (dmd_ty, e') <- dmdAnal env cd e
@@ -255,7 +255,7 @@ dmdAnal env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)])
scrut_dmd = scrut_dmd1 `bothCleanDmd` scrut_dmd2
(scrut_ty, scrut') = dmdAnal env scrut_dmd scrut
- res_ty = alt_ty1 `bothDmdType` scrut_ty
+ res_ty = alt_ty1 `bothDmdType` toBothDmdArg scrut_ty
in
-- pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut
-- , text "dmd" <+> ppr dmd
@@ -271,7 +271,7 @@ dmdAnal env dmd (Case scrut case_bndr ty alts)
(alt_tys, alts') = mapAndUnzip (dmdAnalAlt env dmd) alts
(scrut_ty, scrut') = dmdAnal env cleanEvalDmd scrut
(alt_ty, case_bndr') = annotateBndr env (foldr lubDmdType botDmdType alt_tys) case_bndr
- res_ty = alt_ty `bothDmdType` scrut_ty
+ res_ty = alt_ty `bothDmdType` toBothDmdArg scrut_ty
in
-- pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut
-- , text "scrut_ty" <+> ppr scrut_ty
@@ -509,7 +509,6 @@ dmdTransform env var dmd
| otherwise -- Local non-letrec-bound thing
= unitVarDmd var (mkOnceUsedDmd dmd)
-
\end{code}
%************************************************************************
@@ -698,7 +697,7 @@ addVarDmd (DmdType fv ds res) var dmd
addLazyFVs :: DmdType -> DmdEnv -> DmdType
addLazyFVs dmd_ty lazy_fvs
- = dmd_ty `bothDmdType` mkDmdType lazy_fvs [] topRes
+ = dmd_ty `bothDmdType` mkBothDmdArg lazy_fvs
-- Using bothDmdType (rather than just both'ing the envs)
-- is vital. Consider
-- let f = \x -> (x,y)
More information about the ghc-commits
mailing list