More pondering over the can of worms I opened

4 files changed, 56 insertions, 34 deletions

diff --git a/compiler/basicTypes/Demand.hs b/compiler/basicTypes/Demand.hs
index 025eff2ee3..8869876413 100644
--- a/compiler/basicTypes/Demand.hs
+++ b/compiler/basicTypes/Demand.hs
@@ -22,7 +22,7 @@ module Demand (
         addCaseBndrDmd,
 
         DmdType(..), dmdTypeDepth, lubDmdType, bothDmdType,
-        nopDmdType, botDmdType, mkDmdType,
+        emptyDmdType, botDmdType, mkDmdType,
         addDemand, ensureArgs,
         BothDmdArg, mkBothDmdArg, toBothDmdArg,
 
@@ -32,7 +32,7 @@ module Demand (
         Divergence(..), lubDivergence, isBotDiv, topDiv, botDiv, exnDiv, conDiv,
         appIsBottom, isBottomingSig, pprIfaceStrictSig,
         StrictSig(..), mkStrictSigForArity, mkClosedStrictSig,
-        nopSig, botSig, cprProdSig,
+        emptySig, botSig, cprProdSig,
         isTopSig, hasDemandEnvSig,
         splitStrictSig, strictSigDmdEnv,
         increaseStrictSigArity, etaExpandStrictSig,
@@ -1219,13 +1219,26 @@ instance Outputable DmdType where
 emptyDmdEnv :: VarEnv Demand
 emptyDmdEnv = emptyVarEnv
 
--- nopDmdType is the demand of doing nothing
--- (lazy, absent, no CPR information, no termination information).
--- Note that it is ''not'' the top of the lattice (which would be "may use everything"),
--- so it is (no longer) called topDmd
-nopDmdType, botDmdType :: DmdType
-nopDmdType = DmdType emptyDmdEnv [] conDiv
-botDmdType = DmdType emptyDmdEnv [] botDiv
+-- | 'emptyDmdType' is the demand type where every FV is used according to the
+-- defaultFvDemand of the given 'Divergence' and every argument is used
+-- according to the defaultArgDmd. Examples:
+--
+--   * 'botDiv': Every free var has 'botDmd' and every argument has 'botDmd'.
+--               This is 'botDmdType'.
+--   * 'exnDiv': Every free var has 'absDmd' and every argument has 'absDmd'.
+--   * 'botDiv': This is 'botDmdType'. Every free variable and argument has
+--               'botDmd'.
+--   * 'topDiv': Every free var has 'absDmd' and every argument has 'topDmd'.
+--   * 'conDiv': Like 'topDiv', but the 'Divergence' interacts in a crucial way
+--               when 'bothDmdType'd with a 'botDiv' 'DmdType'.
+--               See Note [Precise exceptions and strictness analysis] in
+--               "Demand".
+--
+emptyDmdType :: Divergence -> DmdType
+emptyDmdType div = DmdType emptyDmdEnv [] div
+
+botDmdType :: DmdType
+botDmdType = emptyDmdType botDiv
 
 isTopDmdType :: DmdType -> Bool
 isTopDmdType (DmdType env [] Dunno)
@@ -1239,12 +1252,12 @@ dmdTypeDepth :: DmdType -> Arity
 dmdTypeDepth (DmdType _ ds _) = length ds
 
 -- | This makes sure we can use the demand type with n arguments.
--- It extends the argument list with the correct defaultArgDmd.
--- It also adjusts the Divergence: Divergence survives additional arguments.
+-- It appends the argument list with the correct defaultArgDmd.
+-- It also adjusts the Divergence: 'Diverges'survives additional arguments.
 ensureArgs :: Arity -> DmdType -> DmdType
 ensureArgs n d | n == depth = d
                | n >  depth = DmdType inc_fv inc_ds inc_div
-               | otherwise  = DmdType dec_fv dec_ds dec_div
+               | otherwise  = decreaseArityDmdType d
   where depth = dmdTypeDepth d
         DmdType fv ds div = d
 
@@ -1260,16 +1273,22 @@ ensureArgs n d | n == depth = d
           ConOrDiv -> Dunno
           _        -> div
 
-        -- Arity decrease:
-        --  * Demands on FVs must be zapped, because they were computed for a
-        --    stronger incoming demand.
-        --  * Demands on args must also be zapped.
-        --  * Divergence may now also converge. Dunno would be a conservative
-        --    way to say so, but also very crude because we won't throw a
-        --    precise exception if we didn't before anyway.
-        dec_fv = emptyVarEnv
-        dec_ds = []
-        dec_div = lubDivergence ConOrDiv div -- we possibly converge now
+-- | A conservative approximation for a given 'DmdType' in case of an arity
+-- decrease:
+--
+--  * Demands on FVs must be zapped, because they were computed for a
+--    stronger incoming demand.
+--  * Demands on args must also be zapped.
+--  * Divergence may now also converge. Dunno would be a conservative
+--    way to say so, but also very crude because we won't throw a
+--    precise exception if we didn't before anyway.
+--
+-- So, basically this will return either @'emptyDmdType' topDiv@ or
+-- @'emptyDmdType' conDiv@, depending on whether the original 'DmdType'
+-- could throw a precise exception or not.
+decreaseArityDmdType :: DmdType -> DmdType
+decreaseArityDmdType (DmdType _ _ div)
+  = DmdType emptyVarEnv [] (lubDivergence ConOrDiv div)
 
 seqDmdType :: DmdType -> ()
 seqDmdType (DmdType env ds res) =
@@ -1675,7 +1694,7 @@ increaseStrictSigArity arity_increase sig@(StrictSig dmd_ty@(DmdType env dmds re
   | arity_increase < 0  = WARN( True, text "increaseStrictSigArity:"
                                   <+> text "negative arity increase"
                                   <+> ppr arity_increase )
-                          nopSig
+                          StrictSig (decreaseArityDmdType dmd_ty)
   | otherwise           = StrictSig (DmdType env dmds' res)
   where
     dmds' = replicate arity_increase topDmd ++ dmds
@@ -1699,12 +1718,15 @@ strictSigDmdEnv (StrictSig (DmdType env _ _)) = env
 isBottomingSig :: StrictSig -> Bool
 isBottomingSig (StrictSig (DmdType _ _ res)) = isBotDiv res
 
-nopSig, botSig :: StrictSig
-nopSig = StrictSig nopDmdType
+-- | See 'emptyDmdType'.
+emptySig :: Divergence ->StrictSig
+emptySig div = StrictSig (emptyDmdType div)
+
+botSig :: StrictSig
 botSig = StrictSig botDmdType
 
 cprProdSig :: Arity -> StrictSig
-cprProdSig _arity = nopSig
+cprProdSig _arity = emptySig conDiv -- constructor applications never throw precise exceptions
 
 seqStrictSig :: StrictSig -> ()
 seqStrictSig (StrictSig ty) = seqDmdType ty
@@ -1730,7 +1752,7 @@ dmdTransformDataConSig arity (StrictSig (DmdType _ _ con_res))
                 -- Must remember whether it's a product, hence con_res, not TopRes
 
   | otherwise   -- Not saturated
-  = nopDmdType
+  = emptyDmdType conDiv
   where
     go_str 0 dmd        = splitStrProdDmd arity dmd
     go_str n (SCall s') = go_str (n-1) s'
@@ -1752,7 +1774,7 @@ dmdTransformDictSelSig (StrictSig (DmdType _ [dict_dmd] _)) cd
    = postProcessUnsat defer_use $
      DmdType emptyDmdEnv [mkOnceUsedDmd $ mkProdDmd $ map (enhance cd') jds] conDiv
    | otherwise
-   = nopDmdType              -- See Note [Demand transformer for a dictionary selector]
+   = emptyDmdType conDiv -- See Note [Demand transformer for a dictionary selector]
   where
     enhance cd old | isAbsDmd old = old
                    | otherwise    = mkOnceUsedDmd cd  -- This is the one!
@@ -1771,7 +1793,7 @@ For single-method classes, which are represented by newtypes the signature
 of 'op' won't look like U(...), so the splitProdDmd_maybe will fail.
 That's fine: if we are doing strictness analysis we are also doing inlining,
 so we'll have inlined 'op' into a cast.  So we can bale out in a conservative
-way, returning nopDmdType.
+way, returning emptyDmdType.
 
 It is (just.. #8329) possible to be running strictness analysis *without*
 having inlined class ops from single-method classes.  Suppose you are using
diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs
index 8eafcdee2f..d4d74df912 100644
--- a/compiler/basicTypes/Id.hs
+++ b/compiler/basicTypes/Id.hs
@@ -657,7 +657,7 @@ setIdCprInfo :: Id -> CprSig -> Id
 setIdCprInfo id sig = modifyIdInfo (\info -> setCprInfo info sig) id
 
 zapIdStrictness :: Id -> Id
-zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` nopSig) id
+zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` emptySig topDiv) id
 
 -- | This predicate says whether the 'Id' has a strict demand placed on it or
 -- has a type such that it can always be evaluated strictly (i.e an
diff --git a/compiler/basicTypes/IdInfo.hs b/compiler/basicTypes/IdInfo.hs
index dcf1740d3c..822b109114 100644
--- a/compiler/basicTypes/IdInfo.hs
+++ b/compiler/basicTypes/IdInfo.hs
@@ -323,7 +323,7 @@ vanillaIdInfo
             inlinePragInfo      = defaultInlinePragma,
             occInfo             = noOccInfo,
             demandInfo          = topDmd,
-            strictnessInfo      = nopSig,
+            strictnessInfo      = emptySig topDiv,
             cprInfo             = topCprSig,
             callArityInfo       = unknownArity,
             levityInfo          = NoLevityInfo
diff --git a/compiler/stranal/DmdAnal.hs b/compiler/stranal/DmdAnal.hs
index 529224ddff..649610838a 100644
--- a/compiler/stranal/DmdAnal.hs
+++ b/compiler/stranal/DmdAnal.hs
@@ -148,8 +148,8 @@ dmdAnal, dmdAnal' :: AnalEnv
 dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $
                   dmdAnal' env d e
 
-dmdAnal' _ _ (Lit lit)     = (nopDmdType, Lit lit)
-dmdAnal' _ _ (Type ty)     = (nopDmdType, Type ty)      -- Doesn't happen, in fact
+dmdAnal' _ _ (Lit lit)     = (emptyDmdType conDiv, Lit lit)
+dmdAnal' _ _ (Type ty)     = (emptyDmdType conDiv, Type ty) -- Doesn't happen, in fact
 dmdAnal' _ _ (Coercion co)
   = (unitDmdType (coercionDmdEnv co), Coercion co)
 
@@ -485,7 +485,7 @@ dmdFix top_lvl env let_dmd orig_pairs
 
 
     zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]
-    zapIdStrictness pairs = [(setIdStrictness id nopSig, rhs) | (id, rhs) <- pairs ]
+    zapIdStrictness pairs = [(setIdStrictness id (emptySig topDiv), rhs) | (id, rhs) <- pairs ]
 
 {-
 Note [Safe abortion in the fixed-point iteration]