From d4d3fe6e02c0eb2117dbbc9df72ae394edf50f06 Mon Sep 17 00:00:00 2001
From: Andreas Klebinger <klebinger.andreas@gmx.at>
Date: Sat, 9 Jul 2022 01:19:52 +0200
Subject: Rule matching: Don't compute the FVs if we don't look at them.

---
 compiler/GHC/Core/Rules.hs    |  6 ++++--
 compiler/GHC/Types/Var/Env.hs | 14 +++++++++++++-
 2 files changed, 17 insertions(+), 3 deletions(-)

diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs
index 444ed1e50b..eba63f590a 100644
--- a/compiler/GHC/Core/Rules.hs
+++ b/compiler/GHC/Core/Rules.hs
@@ -34,7 +34,7 @@ import GHC.Core         -- All of it
 import GHC.Core.Subst
 import GHC.Core.SimpleOpt ( exprIsLambda_maybe )
 import GHC.Core.FVs       ( exprFreeVars, exprsFreeVars, bindFreeVars
-                          , rulesFreeVarsDSet, exprsOrphNames, exprFreeVarsList )
+                          , rulesFreeVarsDSet, exprsOrphNames )
 import GHC.Core.Utils     ( exprType, mkTick, mkTicks
                           , stripTicksTopT, stripTicksTopE
                           , isJoinBind, mkCastMCo )
@@ -1223,7 +1223,9 @@ match_tmpl_var :: RuleMatchEnv
 match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env })
                subst@(RS { rs_id_subst = id_subst, rs_bndrs = let_bndrs })
                v1' e2
-  | any (inRnEnvR rn_env) (exprFreeVarsList e2)
+  -- anyInRnEnvR is lazy in the 2nd arg which allows us to avoid computing fvs
+  -- if the right side of the env is empty.
+  | anyInRnEnvR rn_env (exprFreeVars e2)
   = Nothing     -- Skolem-escape failure
                 -- e.g. match forall a. (\x-> a x) against (\y. y y)
 
diff --git a/compiler/GHC/Types/Var/Env.hs b/compiler/GHC/Types/Var/Env.hs
index 81fc95070b..02d3fa2ad5 100644
--- a/compiler/GHC/Types/Var/Env.hs
+++ b/compiler/GHC/Types/Var/Env.hs
@@ -72,7 +72,7 @@ module GHC.Types.Var.Env (
 
         -- * TidyEnv and its operation
         TidyEnv,
-        emptyTidyEnv, mkEmptyTidyEnv, delTidyEnvList
+        emptyTidyEnv, mkEmptyTidyEnv, delTidyEnvList, anyInRnEnvR
     ) where
 
 import GHC.Prelude
@@ -400,6 +400,14 @@ inRnEnvL, inRnEnvR :: RnEnv2 -> Var -> Bool
 inRnEnvL (RV2 { envL = env }) v = v `elemVarEnv` env
 inRnEnvR (RV2 { envR = env }) v = v `elemVarEnv` env
 
+-- | `anyInRnEnvR env set` == `any (inRnEnvR rn_env) (toList set)`
+-- but lazy in the second argument if the right side of the env is empty.
+anyInRnEnvR :: RnEnv2 -> VarSet -> Bool
+anyInRnEnvR (RV2 { envR = env }) vs
+  -- Avoid allocating the predicate if we deal with an empty env.
+  | isEmptyVarEnv env = False
+  | otherwise = anyVarEnv (`elemVarSet` vs) env
+
 lookupRnInScope :: RnEnv2 -> Var -> Var
 lookupRnInScope env v = lookupInScope (in_scope env) v `orElse` v
 
@@ -495,6 +503,7 @@ plusVarEnvList    :: [VarEnv a] -> VarEnv a
 extendVarEnvList  :: VarEnv a -> [(Var, a)] -> VarEnv a
 
 partitionVarEnv   :: (a -> Bool) -> VarEnv a -> (VarEnv a, VarEnv a)
+-- | Only keep variables contained in the VarSet
 restrictVarEnv    :: VarEnv a -> VarSet -> VarEnv a
 delVarEnvList     :: VarEnv a -> [Var] -> VarEnv a
 delVarEnv         :: VarEnv a -> Var -> VarEnv a
@@ -509,6 +518,7 @@ isEmptyVarEnv     :: VarEnv a -> Bool
 lookupVarEnv      :: VarEnv a -> Var -> Maybe a
 lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a
 filterVarEnv      :: (a -> Bool) -> VarEnv a -> VarEnv a
+anyVarEnv         :: (elt -> Bool) -> UniqFM key elt -> Bool
 lookupVarEnv_NF   :: VarEnv a -> Var -> a
 lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a
 elemVarEnv        :: Var -> VarEnv a -> Bool
@@ -539,6 +549,7 @@ plusVarEnvList   = plusUFMList
 lookupVarEnv     = lookupUFM
 lookupVarEnv_Directly = lookupUFM_Directly
 filterVarEnv     = filterUFM
+anyVarEnv        = anyUFM
 lookupWithDefaultVarEnv = lookupWithDefaultUFM
 mapVarEnv        = mapUFM
 mkVarEnv         = listToUFM
@@ -557,6 +568,7 @@ lookupVarEnv_NF env id = case lookupVarEnv env id of
                          Just xx -> xx
                          Nothing -> panic "lookupVarEnv_NF: Nothing"
 
+
 {-
 @modifyVarEnv@: Look up a thing in the VarEnv,
 then mash it with the modify function, and put it back.
-- 
cgit v1.2.1