DmdAnal: Consider no variables weakwip/dmdanal-no-weak-vars

And measure the ghc/alloc impact of doing so

2 files changed, 23 insertions, 30 deletions

diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs
index fa4bed48f0..c52b079c61 100644
--- a/compiler/GHC/Core/Opt/DmdAnal.hs
+++ b/compiler/GHC/Core/Opt/DmdAnal.hs
@@ -101,13 +101,21 @@ dmdAnalProgram opts fam_envs rules binds
     add_exported_use env dmd_ty id
       | isExportedId id || elemVarSet id rule_fvs
       -- See Note [Absence analysis for stable unfoldings and RULES]
-      = dmd_ty `plusDmdType` fst (dmdAnalStar env topDmd (Var id))
+      = keepAlive env id dmd_ty
       | otherwise
       = dmd_ty
 
     rule_fvs :: IdSet
     rule_fvs = rulesRhsFreeIds rules
 
+keepAlive :: AnalEnv -> Id -> DmdType -> DmdType
+-- See Note [Absence analysis for stable unfoldings and RULES]
+keepAlive env id ty = plusDmdType ty (fst $ dmdAnalStar env topDmd $ Var id)
+
+keepAliveSet :: AnalEnv -> IdSet -> DmdType -> DmdType
+-- See Note [Absence analysis for stable unfoldings and RULES]
+keepAliveSet env ids ty = nonDetStrictFoldVarSet (keepAlive env) ty ids
+
 -- | We attach useful (e.g. not 'topDmd') 'idDemandInfo' to top-level bindings
 -- that satisfy this function.
 --
@@ -284,8 +292,7 @@ dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec
     (rhs_ty, rhs')     = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd') rhs
 
     -- See Note [Absence analysis for stable unfoldings and RULES]
-    rule_fvs           = bndrRuleAndUnfoldingIds id
-    final_ty           = body_ty' `plusDmdType` rhs_ty `keepAliveDmdType` rule_fvs
+    final_ty           = keepAliveSet env (bndrRuleAndUnfoldingIds id) (body_ty' `plusDmdType` rhs_ty)
 
 -- | Let bindings can be processed in two ways:
 -- Down (RHS before body) or Up (body before RHS).
@@ -867,7 +874,7 @@ dmdAnalRhsSig
 -- See Note [NOINLINE and strictness]
 dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs
   = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr sig $$ ppr lazy_fv) $
-    (env', lazy_fv, id', rhs')
+    (env', emptyVarEnv, id', rhs')
   where
     rhs_arity = idArity id
     -- See Note [Demand signatures are computed for a threshold demand based on idArity]
@@ -888,7 +895,7 @@ dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs
     WithDmdType rhs_dmd_ty rhs' = dmdAnal (adjustInlFun id env) rhs_dmd rhs
     DmdType rhs_fv rhs_dmds rhs_div = rhs_dmd_ty
 
-    sig = mkDmdSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div)
+    sig = mkDmdSigForArity rhs_arity sig_ty
 
     id' = id `setIdDmdSig` sig
     !env' = extendAnalEnv top_lvl env id' sig
@@ -905,15 +912,13 @@ dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs
     --        we'd have to do an additional iteration. reuseEnv makes sure that
     --        we never get used-once info for FVs of recursive functions.
     --        See #14816 where we try to get rid of reuseEnv.
-    rhs_fv1 = case rec_flag of
+    rhs_fv' = case rec_flag of
                 Recursive    -> reuseEnv rhs_fv
                 NonRecursive -> rhs_fv
 
+    dmd_ty' = DmdType rhs_fv' rhs_dmds rhs_div
     -- See Note [Absence analysis for stable unfoldings and RULES]
-    rhs_fv2 = rhs_fv1 `keepAliveDmdEnv` bndrRuleAndUnfoldingIds id
-
-    -- See Note [Lazy and unleashable free variables]
-    !(!lazy_fv, !sig_fv) = partitionVarEnv isWeakDmd rhs_fv2
+    sig_ty = keepAliveSet env (bndrRuleAndUnfoldingIds id) dmd_ty'
 
 unboxableResultWidth :: AnalEnv -> Id -> Maybe Arity
 unboxableResultWidth env id
diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs
index ed7ef25aa8..b4f6f3e549 100644
--- a/compiler/GHC/Types/Demand.hs
+++ b/compiler/GHC/Types/Demand.hs
@@ -98,7 +98,6 @@ import GHC.Utils.Binary
 import GHC.Utils.Misc
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
 
 import Data.Function
 
@@ -880,20 +879,7 @@ isUsedOnceDmd (n :* _) = isUsedOnce n
 -- signatures for analysis performance reasons.
 -- See Note [Lazy and unleashable free variables] in "GHC.Core.Opt.DmdAnal".
 isWeakDmd :: Demand -> Bool
-isWeakDmd dmd@(n :* _) = not (isStrict n) && is_plus_idem_dmd dmd
-  where
-    -- @is_plus_idem_* thing@ checks whether @thing `plus` thing = thing@,
-    -- e.g. if @thing@ is idempotent wrt. to @plus@.
-    -- is_plus_idem_card n = plusCard n n == n
-    is_plus_idem_card = isCardNonOnce
-    -- is_plus_idem_dmd dmd = plusDmd dmd dmd == dmd
-    is_plus_idem_dmd AbsDmd    = True
-    is_plus_idem_dmd BotDmd    = True
-    is_plus_idem_dmd (n :* sd) = is_plus_idem_card n && is_plus_idem_sub_dmd sd
-    -- is_plus_idem_sub_dmd sd = plusSubDmd sd sd == sd
-    is_plus_idem_sub_dmd (Poly _ n)  = assert (isCardNonOnce n) True
-    is_plus_idem_sub_dmd (Prod _ ds) = all is_plus_idem_dmd ds
-    is_plus_idem_sub_dmd (Call n _)  = is_plus_idem_card n -- See Note [Call demands are relative]
+isWeakDmd _ = False
 
 evalDmd :: Demand
 evalDmd = C_1N :* topSubDmd
@@ -1503,11 +1489,13 @@ data DmdType
 
 instance Eq DmdType where
   (==) (DmdType fv1 ds1 div1)
-       (DmdType fv2 ds2 div2) = nonDetUFMToList fv1 == nonDetUFMToList fv2
-         -- It's OK to use nonDetUFMToList here because we're testing for
-         -- equality and even though the lists will be in some arbitrary
-         -- Unique order, it is the same order for both
-                              && ds1 == ds2 && div1 == div2
+       (DmdType fv2 ds2 div2) =  div1 == div2 && ds1 == ds2 -- cheap checks first
+                              && as_list div1 fv1 == as_list div2 fv2
+       where
+         as_list div = filter (\(_, dmd) -> dmd /= defaultFvDmd div) . nonDetUFMToList
+           -- It's OK to use nonDetUFMToList here because we're testing for
+           -- equality and even though the lists will be in some arbitrary
+           -- Unique order, it is the same order for both
 
 -- | Compute the least upper bound of two 'DmdType's elicited /by the same
 -- incoming demand/!