Commit fbe14a8e authored by Joachim Breitner's avatar Joachim Breitner
Browse files

Clarify the default demand on demand environments

by adding Notes and using easier to understand combinators.
parent 6b6a30d6
......@@ -18,7 +18,7 @@ module Demand (
isTopDmd, isBotDmd, isAbsDmd, isSeqDmd,
peelUseCall, cleanUseDmd_maybe, strictenDmd, bothCleanDmd,
DmdType(..), dmdTypeDepth, lubDmdType, bothDmdEnv, bothDmdType,
DmdType(..), dmdTypeDepth, lubDmdType, bothDmdType,
nopDmdType, botDmdType, mkDmdType,
addDemand,
......@@ -63,7 +63,7 @@ import UniqFM
import Util
import BasicTypes
import Binary
import Maybes ( isJust, expectJust, orElse )
import Maybes ( isJust, orElse )
import Type ( Type )
import TyCon ( isNewTyCon, isClassTyCon )
......@@ -706,11 +706,17 @@ lubCPR (RetSum t1) (RetSum t2)
| t1 == t2 = RetSum t1
lubCPR RetProd RetProd = RetProd
lubCPR _ _ = NoCPR
-- This needs to commute with defaultDmd, i.e.
-- defaultDmd (r1 `lubCPR` r2) = defaultDmd r1 `lubDmd` defaultDmd r2
-- (See Note [Default demand on free variables] for why)
bothCPR :: CPRResult -> CPRResult -> CPRResult
-- See Note [Asymmetry of 'both' for DmdType and DmdResult]
bothCPR _ BotCPR = BotCPR -- If either diverges, we diverge
bothCPR r _ = r
-- This needs to commute with defaultDmd, i.e.
-- defaultDmd (r1 `bothCPR` r2) = defaultDmd r1 `bothDmd` defaultDmd r2
-- (See Note [Default demand on free variables] for why)
instance Outputable DmdResult where
ppr RetProd = char 'm'
......@@ -898,8 +904,7 @@ in GHC itself where the tuple was DynFlags
\begin{code}
type Demand = JointDmd
type DmdEnv = VarEnv Demand -- If a variable v is not in the domain of the
-- DmdEnv, it implicitly maps to <Lazy,Absent>
type DmdEnv = VarEnv Demand -- See Note [Default demand on free variables]
data DmdType = DmdType
DmdEnv -- Demand on explicitly-mentioned
......@@ -945,8 +950,13 @@ Similarly with
we get dt_scrut from the scrutinee and dt_rhs from the RHS, and then
compute (dt_rhs `bothType` dt_scrut).
We take the CPR info from FIRST argument, but combine both to get
termination info.
We
1. combine the information on the free variables,
2. take the demand on arguments from the first argument
3. combine the termination results, but
4. take CPR info from the first argument.
3 and 4 are implementd in bothDmdResult.
\begin{code}
......@@ -958,39 +968,23 @@ instance Eq DmdType where
lubDmdType :: DmdType -> DmdType -> DmdType
lubDmdType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2)
= DmdType lub_fv2 (lub_ds ds1 ds2) (r1 `lubDmdResult` r2)
= DmdType lub_fv (lub_ds ds1 ds2) (r1 `lubDmdResult` r2)
where
absLub = lubDmd absDmd
lub_fv = plusVarEnv_C lubDmd fv1 fv2
-- Consider (if x then y else []) with demand V
-- Then the first branch gives {y->V} and the second
-- *implicitly* has {y->A}. So we must put {y->(V `lub` A)}
-- in the result env.
lub_fv1 = modifyEnv (not (isBotRes r1)) absLub fv2 fv1 lub_fv
lub_fv2 = modifyEnv (not (isBotRes r2)) absLub fv1 fv2 lub_fv1
-- lub is the identity for Bot
lub_fv = plusVarEnv_CD lubDmd fv1 (defaultDmd r1) fv2 (defaultDmd r2)
-- Extend the shorter argument list to match the longer
lub_ds (d1:ds1) (d2:ds2) = lubDmd d1 d2 : lub_ds ds1 ds2
lub_ds [] [] = []
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)
-- 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.
-- NB: Don't forget about r2! It might be BotRes, which is
-- a bottom demand on all the in-scope variables.
= DmdType both_fv2 ds1 (r1 `bothDmdResult` r2)
where
both_fv = plusVarEnv_C bothDmd fv1 fv2
both_fv1 = modifyEnv (isBotRes r1) (`bothDmd` botDmd) fv2 fv1 both_fv
both_fv2 = modifyEnv (isBotRes r2) (`bothDmd` botDmd) fv1 fv2 both_fv1
bothDmdEnv :: DmdEnv -> DmdEnv -> DmdEnv
bothDmdEnv = plusVarEnv_C bothDmd
= DmdType both_fv ds1 (r1 `bothDmdResult` r2)
where both_fv = plusVarEnv_CD bothDmd fv1 (defaultDmd r1) fv2 (defaultDmd r2)
instance Outputable DmdType where
ppr (DmdType fv ds res)
......@@ -1054,20 +1048,6 @@ deferAfterIO d@(DmdType _ _ res) =
defer_res BotCPR = NoCPR
defer_res r = r
modifyEnv :: Bool -- No-op if False
-> (Demand -> Demand) -- The zapper
-> DmdEnv -> DmdEnv -- Env1 and Env2
-> DmdEnv -> DmdEnv -- Transform this env
-- Zap anything in Env1 but not in Env2
-- Assume: dom(env) includes dom(Env1) and dom(Env2)
modifyEnv need_to_modify zapper env1 env2 env
| need_to_modify = foldr zap env (varEnvKeys (env1 `minusUFM` env2))
| otherwise = env
where
zap uniq env = addToUFM_Directly env uniq (zapper current_val)
where
current_val = expectJust "modifyEnv" (lookupUFM_Directly env uniq)
strictenDmd :: JointDmd -> CleanDemand
strictenDmd (JD {strd = s, absd = u})
= CD { sd = poke_s s, ud = poke_u u }
......@@ -1155,21 +1135,34 @@ peelManyCalls arg_ds (CD { sd = str, ud = abs })
go_abs (_:as) (UCall One d') = go_abs as d'
go_abs _ _ = Many
peelFV :: DmdType -> Var -> (DmdType, Demand)
peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv)
(DmdType fv' ds res, dmd)
where
fv' = fv `delVarEnv` id
dmd = lookupVarEnv fv id `orElse` deflt
-- See note [Default demand for variables]
deflt | isBotRes res = botDmd
| otherwise = absDmd
-- See note [Default demand on free variables]
dmd = lookupVarEnv fv id `orElse` defaultDmd res
defaultDmd :: DmdResult -> Demand
defaultDmd res | isBotRes res = botDmd
| otherwise = absDmd
addDemand :: Demand -> DmdType -> DmdType
addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res
\end{code}
Note [Default demand on free variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If the variable is not mentioned in the environment of a demand type,
its demand is taken to be a result demand of the type.
For the stricness component,
if the result demand is a Diverges, then we use HyperStr
else we use Lazy
For the usage component, we use Absent.
So we use either absDmd or botDmd.
Also note the equations for lubDmdResult (resp. bothDmdResult) noted there.
Note [Always analyse in virgin pass]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tricky point: make sure that we analyse in the 'virgin' pass. Consider
......
......@@ -12,7 +12,7 @@ module VarEnv (
emptyVarEnv, unitVarEnv, mkVarEnv,
elemVarEnv, varEnvElts, varEnvKeys,
extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnvList,
plusVarEnv, plusVarEnv_C, alterVarEnv,
plusVarEnv, plusVarEnv_C, plusVarEnv_CD, alterVarEnv,
delVarEnvList, delVarEnv,
minusVarEnv, intersectsVarEnv,
lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv,
......@@ -385,6 +385,7 @@ delVarEnv :: VarEnv a -> Var -> VarEnv a
minusVarEnv :: VarEnv a -> VarEnv b -> VarEnv a
intersectsVarEnv :: VarEnv a -> VarEnv a -> Bool
plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
plusVarEnv_CD :: (a -> a -> a) -> VarEnv a -> a -> VarEnv a -> a -> VarEnv a
mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b
modifyVarEnv :: (a -> a) -> VarEnv a -> Var -> VarEnv a
varEnvElts :: VarEnv a -> [a]
......@@ -409,6 +410,7 @@ extendVarEnv_C = addToUFM_C
extendVarEnv_Acc = addToUFM_Acc
extendVarEnvList = addListToUFM
plusVarEnv_C = plusUFM_C
plusVarEnv_CD = plusUFM_CD
delVarEnvList = delListFromUFM
delVarEnv = delFromUFM
minusVarEnv = minusUFM
......
......@@ -728,16 +728,6 @@ addLazyFVs dmd_ty lazy_fvs
-- call to f. So we just get an L demand for x for g.
\end{code}
Note [Default demand for variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If the variable is not mentioned in the environment of a demand type,
its demand is taken to be a result demand of the type: either L or the
bottom. Both are safe from the semantical pont of view, however, for
the safe result we also have absent demand set to Abs, which makes it
possible to safely ignore non-mentioned variables (their joint demand
is <L,A>).
Note [do not strictify the argument dictionaries of a dfun]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -45,6 +45,7 @@ module UniqFM (
delListFromUFM,
plusUFM,
plusUFM_C,
plusUFM_CD,
minusUFM,
intersectUFM,
intersectUFM_C,
......@@ -134,6 +135,16 @@ plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
plusUFM_C :: (elt -> elt -> elt)
-> UniqFM elt -> UniqFM elt -> UniqFM elt
-- | plusUFM_CD f m1 d1 m2 d2
-- merges the maps using `f` as the combinding function and d1 resp. d2 as
-- the default value if there is no entry in m1 reps. m2. The domain is the union
-- of the domains of m1 m2.
-- Representative example:
-- > plusUFM_CD f {A: 1, B: 2} 23 {B: 3, C: 4} 42
-- > == {A: f 1 42, B: f 2 3, C: f 23 4 }
plusUFM_CD :: (elt -> elt -> elt)
-> UniqFM elt -> elt -> UniqFM elt -> elt -> UniqFM elt
minusUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1
intersectUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
......@@ -222,7 +233,24 @@ delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m)
-- M.union is left-biased, plusUFM should be right-biased.
plusUFM (UFM x) (UFM y) = UFM (M.union y x)
-- Note (M.union y x), with arguments flipped
-- M.union is left-biased, plusUFM should be right-biased.
plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y)
plusUFM_CD f (UFM xm) dx (UFM ym) dy
{-
The following implementation should be used as soon as we can expect
containers-0.5; presumably from GHC 7.9 on:
= UFM $ M.mergeWithKey
(\_ x y -> Just (x `f` y))
(M.map (\x -> x `f` dy))
(M.map (\y -> dx `f` y))
xm ym
-}
= UFM $ M.intersectionWith f xm ym
`M.union` M.map (\x -> x `f` dy) xm
`M.union` M.map (\y -> dx `f` y) ym
minusUFM (UFM x) (UFM y) = UFM (M.difference x y)
intersectUFM (UFM x) (UFM y) = UFM (M.intersection x y)
intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment