Take account of loop breakers in specLookupRulewip/T22802

The key change is that in GHC.Core.Opt.Specialise.specLookupRule
we were using realIdUnfolding, which ignores the loop-breaker
flag.  When given a loop breaker, rule matching therefore
looped infinitely -- #22802.

In fixing this I refactored a bit.

* Define GHC.Core.InScopeEnv as a data type, and use it.
  (Previously it was a pair: hard to grep for.)

* Put several functions returning an IdUnfoldingFun into
  GHC.Types.Id, namely
     idUnfolding
     alwaysActiveUnfoldingFun,
     whenActiveUnfoldingFun,
     noUnfoldingFun
  and use them.  (The are all loop-breaker aware.)

3 files changed, 20 insertions, 19 deletions

diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs
index 3d36368d5b..7ace3124e9 100644
--- a/compiler/GHC/Core/Opt/ConstantFold.hs
+++ b/compiler/GHC/Core/Opt/ConstantFold.hs
@@ -2402,7 +2402,7 @@ match_cstring_foldr_lit _ _ _ _ _ = Nothing
 -- Also, look into variable's unfolding just in case the expression we look for
 -- is in a top-level thunk.
 stripStrTopTicks :: InScopeEnv -> CoreExpr -> ([CoreTickish], CoreExpr)
-stripStrTopTicks (_,id_unf) e = case e of
+stripStrTopTicks (ISE _ id_unf) e = case e of
   Var v
     | Just rhs <- expandUnfolding_maybe (id_unf v)
     -> stripTicksTop tickishFloatable rhs
diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs
index 28b1ebc221..19daab0075 100644
--- a/compiler/GHC/Core/Opt/Simplify/Utils.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs
@@ -1241,14 +1241,13 @@ getUnfoldingInRuleMatch :: SimplEnv -> InScopeEnv
 -- is 'otherwise' which we want exprIsConApp_maybe to be able to
 -- see very early on
 getUnfoldingInRuleMatch env
-  = (in_scope, id_unf)
+  = ISE in_scope id_unf
   where
     in_scope = seInScope env
-    id_unf id | unf_is_active id = idUnfolding id
-              | otherwise        = NoUnfolding
-    unf_is_active id = isActive (sePhase env) (idInlineActivation id)
-       -- When sm_rules was off we used to test for a /stable/ unfolding,
-       -- but that seems wrong (#20941)
+    phase    = sePhase env
+    id_unf   = whenActiveUnfoldingFun (isActive phase)
+     -- When sm_rules was off we used to test for a /stable/ unfolding,
+     -- but that seems wrong (#20941)
 
 ----------------------
 activeRule :: SimplMode -> Activation -> Bool
diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs
index fa9323ab3b..13bff9f170 100644
--- a/compiler/GHC/Core/Opt/Specialise.hs
+++ b/compiler/GHC/Core/Opt/Specialise.hs
@@ -1626,11 +1626,11 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
 --      See Note [Inline specialisations] for why we do not
 --      switch off specialisation for inline functions
 
-  = do { -- debugTraceMsg (text "specCalls: some" <+> vcat
-         --   [ text "function" <+> ppr fn
-         --   , text "calls:" <+> ppr calls_for_me
-         --   , text "subst" <+> ppr (se_subst env) ])
-       ; foldlM spec_call ([], [], emptyUDs) calls_for_me }
+  = -- pprTrace "specCalls: some" (vcat
+    --   [ text "function" <+> ppr fn
+    --   , text "calls:" <+> ppr calls_for_me
+    --   , text "subst" <+> ppr (se_subst env) ]) $
+    foldlM spec_call ([], [], emptyUDs) calls_for_me
 
   | otherwise   -- No calls or RHS doesn't fit our preconceptions
   = warnPprTrace (not (exprIsTrivial rhs) && notNull calls_for_me && not (isClassOpId fn))
@@ -1685,7 +1685,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
              , rule_bndrs, rule_lhs_args
              , spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args
 
---           ; debugTraceMsg (text "spec_call" <+> vcat
+--           ; pprTrace "spec_call" (vcat
 --                [ text "fun:       "  <+> ppr fn
 --                , text "call info: "  <+> ppr _ci
 --                , text "useful:    "  <+> ppr useful
@@ -1698,7 +1698,8 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
 --                , text "rhs_bndrs"     <+> ppr rhs_bndrs
 --                , text "rhs_body"     <+> ppr rhs_body
 --                , text "rhs_env2:  "  <+> ppr (se_subst rhs_env2)
---                , ppr dx_binds ]
+--                , ppr dx_binds ]) $
+--             return ()
 
            ; if not useful  -- No useful specialisation
                 || already_covered rhs_env2 rules_acc rule_lhs_args
@@ -1795,12 +1796,13 @@ specLookupRule :: SpecEnv -> Id -> [CoreExpr]
                -> CompilerPhase  -- Look up rules as if we were in this phase
                -> [CoreRule] -> Maybe (CoreRule, CoreExpr)
 specLookupRule env fn args phase rules
-  = lookupRule ropts (in_scope, realIdUnfolding) is_active fn args rules
+  = lookupRule ropts in_scope_env is_active fn args rules
   where
-    dflags    = se_dflags env
-    in_scope  = getSubstInScope (se_subst env)
-    ropts     = initRuleOpts dflags
-    is_active = isActive phase
+    dflags       = se_dflags env
+    in_scope     = getSubstInScope (se_subst env)
+    in_scope_env = ISE in_scope (whenActiveUnfoldingFun is_active)
+    ropts        = initRuleOpts dflags
+    is_active    = isActive phase
 
 {- Note [Specialising DFuns]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~