Clarify the default demand on demand environments

by adding Notes and using easier to understand combinators.

4 files changed, 70 insertions, 57 deletions

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index 50b6f94949..8df6db7da7 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -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
diff --git a/compiler/basicTypes/VarEnv.lhs b/compiler/basicTypes/VarEnv.lhs
index 6e5989b034..30d40c8efd 100644
--- a/compiler/basicTypes/VarEnv.lhs
+++ b/compiler/basicTypes/VarEnv.lhs
@@ -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
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index 8a2cf4c033..3b805d97c0 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -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]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs
index 862af99443..d37041c9f2 100644
--- a/compiler/utils/UniqFM.lhs
+++ b/compiler/utils/UniqFM.lhs
@@ -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)