Fix the perf regression in T12227/T12545wip/dmdanal-precise-exn

But now T9233 fails because we are doing more work. Temporarily marking
as accepted increase.

Metric Increase:
    T9233

Metric Decrease:
    hie002

6 files changed, 71 insertions, 30 deletions

diff --git a/compiler/GHC/Core/Op/DmdAnal.hs b/compiler/GHC/Core/Op/DmdAnal.hs
index d7305b1e52..f23c94f5e5 100644
--- a/compiler/GHC/Core/Op/DmdAnal.hs
+++ b/compiler/GHC/Core/Op/DmdAnal.hs
@@ -27,6 +27,7 @@ import Data.List        ( mapAccumL )
 import GHC.Core.DataCon
 import GHC.Types.Id
 import GHC.Types.Id.Info
+import GHC.Core.Arity ( typeArity )
 import GHC.Core.Utils
 import GHC.Core.TyCon
 import GHC.Core.Type
@@ -152,7 +153,7 @@ dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $
 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)
+  = (DmdType (coercionDmdEnv co) [] conDiv, Coercion co)
 
 dmdAnal' env dmd (Var var)
   = (dmdTransform env var dmd, Var var)
@@ -410,7 +411,7 @@ forcesRealWorld fam_envs = go initRecTc
       -- search depth-first
       | Just DataConAppContext{ dcac_dc = dc, dcac_arg_tys = field_tys }
           <- deepSplitProductType_maybe fam_envs ty
-      -- don't check the same TyCon twice
+      -- don't check the same TyCon more than n times
       , Just rec_tc' <- checkRecTc rec_tc (dataConTyCon dc)
       = any (strict_field_forces rec_tc') field_tys
       | otherwise
@@ -510,27 +511,63 @@ dmdTransform :: AnalEnv         -- The strictness environment
         -- this function plus demand on its free variables
 
 dmdTransform env var dmd
-  | isDataConWorkId var                          -- Data constructor
+  -- Data constructors
+  | isDataConWorkId var
   = dmdTransformDataConSig (idArity var) dmd
-
+  -- Dictionary component selectors
   | gopt Opt_DmdTxDictSel (ae_dflags env),
-    Just _ <- isClassOpId_maybe var -- Dictionary component selector
+    Just _ <- isClassOpId_maybe var
   = dmdTransformDictSelSig (idStrictness var) dmd
-
-  | isGlobalId var                               -- Imported function
-  , let res = dmdTransformSig (idStrictness var) dmd
-  = -- pprTrace "dmdTransform" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res])
+  -- Imported functions
+  | isGlobalId var
+  , let res = dmdTransformSig (globalIdStrictness env var) dmd
+  = -- pprTrace "dmdTransform:import" (vcat [ppr var, ppr (idStrictness var), ppr (globalIdStrictness var), ppr dmd, ppr res])
     res
-
-  | Just (sig, top_lvl) <- lookupSigEnv env var  -- Local letrec bound thing
+  -- Top-level or local let-bound thing for which we use LetDown ('useLetUp').
+  -- In that case, we have a strictness signature to unleash in our AnalEnv.
+  | Just (sig, top_lvl) <- lookupSigEnv env var
   , let fn_ty = dmdTransformSig sig dmd
-  = -- pprTrace "dmdTransform" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $
+  = -- pprTrace "dmdTransform:LetDown" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $
     if isTopLevel top_lvl
-    then fn_ty   -- Don't record top level things
+    then fn_ty   -- Don't record demand on top-level things
     else addVarDmd fn_ty var (mkOnceUsedDmd dmd)
-
-  | otherwise                                    -- Local non-letrec-bound thing
-  = unitDmdType (unitVarEnv var (mkOnceUsedDmd dmd))
+  -- Everything else:
+  --   * Local let binders for which we use LetUp (cf. 'useLetUp')
+  --   * Lambda binders
+  --   * Case and constructor field binders
+  | let sig     = mkConservativeSig env (idType var)
+  , let res     = dmdTransformSig sig dmd
+  = -- pprTrace "dmdTransform:Other" (vcat [ppr var, ppr sig, ppr dmd, ppr res]) $
+    addVarDmd res var (mkOnceUsedDmd dmd)
+
+-- | Returns 'idStrictness' or a conservative strictness signature for an
+-- imported global variable for which 'idStrictness' is Top.
+globalIdStrictness :: AnalEnv -> Id -> StrictSig
+globalIdStrictness env var
+  | isTopSig (idStrictness var) = mkConservativeSig env (idType var)
+  | otherwise                   = idStrictness var
+
+mkConservativeSig :: AnalEnv -> Type -> StrictSig
+mkConservativeSig env ty
+  -- Binders of unlifted types can't throw anything. This special case isn't
+  -- handled well by forcesRealWorld, which focuses on case scrutinees.
+  | unlifted  = emptySig conDiv
+  -- no point in retaining cleared_sig when it's just Top
+  | no_change = topSig
+  | otherwise = cleared_sig
+  where
+    unlifted        = isLiftedType_maybe ty == Just False
+    fam_envs        = ae_fam_envs env
+    -- This is isomorphic to topSig. But this one has the right number of
+    -- arguments and will possibly have conDiv after the call to
+    -- tryClearPreciseException!
+    pessimistic_sig = StrictSig $ DmdType emptyVarEnv args topDiv
+    args            = replicate (length (typeArity ty)) topDmd
+    -- In contrast to pessimistic_sig, cleared_sig might not have conDiv
+    -- Divergence!
+    cleared_sig     = tryClearPreciseException fam_envs ty pessimistic_sig
+    sig_div         = snd . splitStrictSig
+    no_change       = sig_div cleared_sig == topDiv
 
 {-
 ************************************************************************
@@ -603,7 +640,7 @@ dmdFix top_lvl env let_dmd orig_pairs
 
     zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]
     zapIdStrictness pairs
-      = [(setIdStrictnessClearExn env id (emptySig topDiv), rhs) | (id, rhs) <- pairs ]
+      = [(setIdStrictnessClearExn env id topSig, rhs) | (id, rhs) <- pairs ]
 
 {-
 Note [Safe abortion in the fixed-point iteration]
@@ -658,7 +695,7 @@ dmdAnalRhsLetDown rec_flag env let_dmd id rhs
       = mkRhsDmd env rhs_arity rhs
     (DmdType rhs_fv rhs_dmds rhs_div, rhs')
                    = dmdAnal env rhs_dmd rhs
-    sig            = mkStrictSigForArity rhs_arity (mkDmdType sig_fv rhs_dmds rhs_div)
+    sig            = mkStrictSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div)
     id'            = -- pprTraceWith "dmdAnalRhsLetDown" (\sig'-> ppr id <+> ppr sig <+> ppr sig') $
                      setIdStrictnessClearExn env id sig
         -- See Note [NOINLINE and strictness]
@@ -944,9 +981,6 @@ deleted the special case.
 ************************************************************************
 -}
 
-unitDmdType :: DmdEnv -> DmdType
-unitDmdType dmd_env = DmdType dmd_env [] conDiv
-
 coercionDmdEnv :: Coercion -> DmdEnv
 coercionDmdEnv co = mapVarEnv (const topDmd) (getUniqSet $ coVarsOfCo co)
                     -- The VarSet from coVarsOfCo is really a VarEnv Var
diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs
index 2ffb9625a2..4e8ea71a24 100644
--- a/compiler/GHC/Types/Demand.hs
+++ b/compiler/GHC/Types/Demand.hs
@@ -23,8 +23,7 @@ module GHC.Types.Demand (
 
         DmdType(..), dmdTypeDepth, lubDmdType, bothDmdType,
         BothDmdArg, mkBothDmdArg, toBothDmdArg,
-        emptyDmdType, botDmdType, mkDmdType, addDemand,
-        mayThrowPreciseDmdType,
+        emptyDmdType, botDmdType, addDemand, mayThrowPreciseDmdType,
 
         DmdEnv, emptyDmdEnv,
         peelFV, findIdDemand,
@@ -33,7 +32,7 @@ module GHC.Types.Demand (
         topDiv, botDiv, exnDiv, conDiv,
         appIsDeadEnd, isDeadEndSig, pprIfaceStrictSig,
         StrictSig(..), mkStrictSigForArity, mkClosedStrictSig,
-        emptySig, botSig, cprProdSig,
+        emptySig, topSig, botSig, cprProdSig,
         isTopSig, hasDemandEnvSig,
         splitStrictSig, strictSigDmdEnv,
         prependArgsStrictSig, etaConvertStrictSig,
@@ -1275,6 +1274,9 @@ emptyDmdType div = DmdType emptyDmdEnv [] div
 botDmdType :: DmdType
 botDmdType = emptyDmdType botDiv
 
+topDmdType :: DmdType
+topDmdType = emptyDmdType topDiv
+
 isTopDmdType :: DmdType -> Bool
 isTopDmdType (DmdType env args div)
   = div == topDiv && null args && isEmptyVarEnv env
@@ -1284,9 +1286,6 @@ mayThrowPreciseDmdType (DmdType _ _ Dunno)    = True
 mayThrowPreciseDmdType (DmdType _ _ ExnOrDiv) = True
 mayThrowPreciseDmdType _                      = False
 
-mkDmdType :: DmdEnv -> [Demand] -> Divergence -> DmdType
-mkDmdType fv ds res = DmdType fv ds res
-
 dmdTypeDepth :: DmdType -> Arity
 dmdTypeDepth (DmdType _ ds _) = length ds
 
@@ -1788,6 +1787,9 @@ emptySig div = StrictSig (emptyDmdType div)
 botSig :: StrictSig
 botSig = StrictSig botDmdType
 
+topSig :: StrictSig
+topSig = StrictSig topDmdType
+
 cprProdSig :: Arity -> StrictSig
 cprProdSig _arity = emptySig conDiv -- constructor applications never throw precise exceptions
 
diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs
index 07edd8521a..7950f0d68a 100644
--- a/compiler/GHC/Types/Id.hs
+++ b/compiler/GHC/Types/Id.hs
@@ -658,7 +658,7 @@ setIdCprInfo :: Id -> CprSig -> Id
 setIdCprInfo id sig = modifyIdInfo (\info -> setCprInfo info sig) id
 
 zapIdStrictness :: Id -> Id
-zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` emptySig topDiv) id
+zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` topSig) 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/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs
index 2f92aaf327..241bd2138c 100644
--- a/compiler/GHC/Types/Id/Info.hs
+++ b/compiler/GHC/Types/Id/Info.hs
@@ -324,7 +324,7 @@ vanillaIdInfo
             inlinePragInfo      = defaultInlinePragma,
             occInfo             = noOccInfo,
             demandInfo          = topDmd,
-            strictnessInfo      = emptySig topDiv,
+            strictnessInfo      = topSig,
             cprInfo             = topCprSig,
             callArityInfo       = unknownArity,
             levityInfo          = NoLevityInfo
diff --git a/testsuite/tests/simplCore/should_compile/T18013.stderr b/testsuite/tests/simplCore/should_compile/T18013.stderr
index 677c08e7d9..73f41215e2 100644
--- a/testsuite/tests/simplCore/should_compile/T18013.stderr
+++ b/testsuite/tests/simplCore/should_compile/T18013.stderr
@@ -136,7 +136,7 @@ mapMaybeRule
   :: forall a b. Rule IO a b -> Rule IO (Maybe a) (Maybe b)
 [GblId,
  Arity=1,
- Str=<S,1*U>,
+ Str=<S,1*U>c,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True, Guidance=IF_ARGS [20] 150 30}]
 mapMaybeRule
@@ -170,6 +170,7 @@ mapMaybeRule
 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
 T18013.$trModule4 :: GHC.Prim.Addr#
 [GblId,
+ Str=c,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
 T18013.$trModule4 = "main"#
@@ -177,6 +178,7 @@ T18013.$trModule4 = "main"#
 -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
 T18013.$trModule3 :: GHC.Types.TrName
 [GblId,
+ Str=c,
  Cpr=m1,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
@@ -185,6 +187,7 @@ T18013.$trModule3 = GHC.Types.TrNameS T18013.$trModule4
 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
 T18013.$trModule2 :: GHC.Prim.Addr#
 [GblId,
+ Str=c,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
 T18013.$trModule2 = "T18013"#
@@ -192,6 +195,7 @@ T18013.$trModule2 = "T18013"#
 -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
 T18013.$trModule1 :: GHC.Types.TrName
 [GblId,
+ Str=c,
  Cpr=m1,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
@@ -200,6 +204,7 @@ T18013.$trModule1 = GHC.Types.TrNameS T18013.$trModule2
 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
 T18013.$trModule :: GHC.Types.Module
 [GblId,
+ Str=c,
  Cpr=m1,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}]
diff --git a/utils/haddock b/utils/haddock
-Subproject 65f22afa9e66195baa6b7d44369e2b23cd8f77d
+Subproject 5ec817a3e41b7eaa50c74701ab2d7642df86464