Fix a nasty loop in Tidywip/andreask/tidy-94

As the remarkably-simple #22112 showed, we were making a black hole
in the unfolding of a self-recursive binding.  Boo!

It's a bit tricky.  Documented in GHC.Iface.Tidy,
   Note [tidyTopUnfolding: avoiding black holes]

This is the 9.4 packport based on
commit 4945953823620b223a0b51b2b1275a1de8f4a851

6 files changed, 126 insertions, 58 deletions

diff --git a/compiler/GHC/Core/Tidy.hs b/compiler/GHC/Core/Tidy.hs
index 3f6c212f49..2201c9c3c1 100644
--- a/compiler/GHC/Core/Tidy.hs
+++ b/compiler/GHC/Core/Tidy.hs
@@ -10,7 +10,7 @@ The code for *top-level* bindings is in GHC.Iface.Tidy.
 
 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
 module GHC.Core.Tidy (
-        tidyExpr, tidyRules, tidyUnfolding, tidyCbvInfoTop
+        tidyExpr, tidyRules, tidyCbvInfoTop, tidyBndrs
     ) where
 
 import GHC.Prelude
@@ -345,33 +345,36 @@ tidyLetBndr rec_tidy_env env@(tidy_env, var_env) id
                     `setUnfoldingInfo`  new_unf
 
         old_unf = realUnfoldingInfo old_info
-        new_unf | isStableUnfolding old_unf = tidyUnfolding rec_tidy_env old_unf old_unf
-                | otherwise                 = trimUnfolding old_unf
-                                              -- See Note [Preserve evaluatedness]
+        new_unf = tidyNestedUnfolding rec_tidy_env old_unf
 
     in
     ((tidy_env', var_env'), id') }
 
 ------------ Unfolding  --------------
-tidyUnfolding :: TidyEnv -> Unfolding -> Unfolding -> Unfolding
-tidyUnfolding tidy_env df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) _
+tidyNestedUnfolding :: TidyEnv -> Unfolding -> Unfolding
+tidyNestedUnfolding _ NoUnfolding   = NoUnfolding
+tidyNestedUnfolding _ BootUnfolding = BootUnfolding
+tidyNestedUnfolding _ (OtherCon {}) = evaldUnfolding
+
+tidyNestedUnfolding tidy_env df@(DFunUnfolding { df_bndrs = bndrs, df_args = args })
   = df { df_bndrs = bndrs', df_args = map (tidyExpr tidy_env') args }
   where
     (tidy_env', bndrs') = tidyBndrs tidy_env bndrs
 
-tidyUnfolding tidy_env
-              unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })
-              unf_from_rhs
+tidyNestedUnfolding tidy_env
+    unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src, uf_is_value = is_value })
   | isStableSource src
   = seqIt $ unf { uf_tmpl = tidyExpr tidy_env unf_rhs }    -- Preserves OccInfo
-    -- This seqIt avoids a space leak: otherwise the uf_is_value,
-    -- uf_is_conlike, ... fields may retain a reference to the
-    -- pre-tidied expression forever (GHC.CoreToIface doesn't look at them)
-
-  | otherwise
-  = unf_from_rhs
-  where seqIt unf = seqUnfolding unf `seq` unf
-tidyUnfolding _ unf _ = unf     -- NoUnfolding or OtherCon
+            -- This seqIt avoids a space leak: otherwise the uf_is_value,
+            -- uf_is_conlike, ... fields may retain a reference to the
+            -- pre-tidied expression forever (GHC.CoreToIface doesn't look at them)
+
+  -- Discard unstable unfoldings, but see Note [Preserve evaluatedness]
+  | is_value = evaldUnfolding
+  | otherwise = noUnfolding
+
+  where
+    seqIt unf = seqUnfolding unf `seq` unf
 
 {-
 Note [Tidy IdInfo]
diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs
index 1417f26f49..4032bfbc4d 100644
--- a/compiler/GHC/Iface/Tidy.hs
+++ b/compiler/GHC/Iface/Tidy.hs
@@ -24,13 +24,12 @@ import GHC.Tc.Utils.Env
 
 import GHC.Core
 import GHC.Core.Unfold
-import GHC.Core.Unfold.Make
 import GHC.Core.FVs
 import GHC.Core.Tidy
 import GHC.Core.Seq     (seqBinds)
-import GHC.Core.Opt.Arity   ( exprArity, exprBotStrictness_maybe )
+import GHC.Core.Opt.Arity   ( exprArity, exprBotStrictness_maybe, typeArity )
 import GHC.Core.InstEnv
-import GHC.Core.Type     ( tidyTopType )
+import GHC.Core.Type     ( tidyTopType, Type )
 import GHC.Core.DataCon
 import GHC.Core.TyCon
 import GHC.Core.Class
@@ -74,6 +73,7 @@ import Data.Function
 import Data.List        ( sortBy, mapAccumL )
 import qualified Data.Set as S
 import GHC.Types.CostCentre
+import GHC.Core.Opt.OccurAnal (occurAnalyseExpr)
 
 {-
 Constructing the TypeEnv, Instances, Rules from which the
@@ -384,8 +384,7 @@ tidyProgram opts (ModGuts { mg_module           = mod
   (unfold_env, tidy_occ_env) <- chooseExternalIds opts mod binds implicit_binds imp_rules
   let (trimmed_binds, trimmed_rules) = findExternalRules opts binds imp_rules unfold_env
 
-  let uf_opts = opt_unfolding_opts opts
-  (tidy_env, tidy_binds) <- tidyTopBinds uf_opts unfold_env boot_exports tidy_occ_env trimmed_binds
+  (tidy_env, tidy_binds) <- tidyTopBinds unfold_env boot_exports tidy_occ_env trimmed_binds
 
   -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.
   (spt_entries, mcstub, tidy_binds') <- case opt_static_ptr_opts opts of
@@ -1146,60 +1145,49 @@ tidyTopName mod name_cache maybe_ref occ_env id
 --
 --   * subst_env: A Var->Var mapping that substitutes the new Var for the old
 
-tidyTopBinds :: UnfoldingOpts
-             -> UnfoldEnv
+tidyTopBinds :: UnfoldEnv
              -> NameSet
              -> TidyOccEnv
              -> CoreProgram
              -> IO (TidyEnv, CoreProgram)
 
-tidyTopBinds uf_opts unfold_env boot_exports init_occ_env binds
+tidyTopBinds unfold_env boot_exports init_occ_env binds
   = do let result = tidy init_env binds
        seqBinds (snd result) `seq` return result
        -- This seqBinds avoids a spike in space usage (see #13564)
   where
     init_env = (init_occ_env, emptyVarEnv)
 
-    tidy = mapAccumL (tidyTopBind uf_opts unfold_env boot_exports)
+    tidy = mapAccumL (tidyTopBind unfold_env boot_exports)
 
 ------------------------
-tidyTopBind  :: UnfoldingOpts
-             -> UnfoldEnv
+tidyTopBind  :: UnfoldEnv
              -> NameSet
              -> TidyEnv
              -> CoreBind
              -> (TidyEnv, CoreBind)
 
-tidyTopBind uf_opts unfold_env boot_exports
+tidyTopBind unfold_env boot_exports
             (occ_env,subst1) (NonRec bndr rhs)
   = (tidy_env2,  NonRec bndr' rhs')
   where
-    Just (name',show_unfold) = lookupVarEnv unfold_env bndr
-    (bndr', rhs') = tidyTopPair uf_opts show_unfold boot_exports tidy_env2 name' (bndr, rhs)
+    (bndr', rhs') = tidyTopPair unfold_env boot_exports tidy_env2 (bndr, rhs)
     subst2        = extendVarEnv subst1 bndr bndr'
     tidy_env2     = (occ_env, subst2)
 
-tidyTopBind uf_opts unfold_env boot_exports (occ_env, subst1) (Rec prs)
+tidyTopBind unfold_env boot_exports (occ_env, subst1) (Rec prs)
   = (tidy_env2, Rec prs')
   where
-    prs' = [ tidyTopPair uf_opts show_unfold boot_exports tidy_env2 name' (id,rhs)
-           | (id,rhs) <- prs,
-             let (name',show_unfold) =
-                    expectJust "tidyTopBind" $ lookupVarEnv unfold_env id
-           ]
-
-    subst2    = extendVarEnvList subst1 (bndrs `zip` map fst prs')
+    prs'      = map (tidyTopPair unfold_env boot_exports tidy_env2) prs
+    subst2    = extendVarEnvList subst1 (map fst prs `zip` map fst prs')
     tidy_env2 = (occ_env, subst2)
-
-    bndrs = map fst prs
+    -- This is where we "tie the knot": tidy_env2 is fed into tidyTopPair
 
 -----------------------------------------------------------
-tidyTopPair :: UnfoldingOpts
-            -> Bool  -- show unfolding
+tidyTopPair :: UnfoldEnv
             -> NameSet
             -> TidyEnv  -- The TidyEnv is used to tidy the IdInfo
                         -- It is knot-tied: don't look at it!
-            -> Name             -- New name
             -> (Id, CoreExpr)   -- Binder and RHS before tidying
             -> (Id, CoreExpr)
         -- This function is the heart of Step 2
@@ -1208,18 +1196,19 @@ tidyTopPair :: UnfoldingOpts
         -- group, a variable late in the group might be mentioned
         -- in the IdInfo of one early in the group
 
-tidyTopPair uf_opts show_unfold boot_exports rhs_tidy_env name' (bndr, rhs)
+tidyTopPair unfold_env boot_exports rhs_tidy_env (bndr, rhs)
   = -- pprTrace "tidyTop" (ppr name' <+> ppr details <+> ppr rhs) $
     (bndr1, rhs1)
 
   where
+    Just (name',show_unfold) = lookupVarEnv unfold_env bndr
     !cbv_bndr = tidyCbvInfoTop boot_exports bndr rhs
     bndr1    = mkGlobalId details name' ty' idinfo'
     details  = idDetails cbv_bndr -- Preserve the IdDetails
     ty'      = tidyTopType (idType cbv_bndr)
     rhs1     = tidyExpr rhs_tidy_env rhs
-    idinfo'  = tidyTopIdInfo uf_opts rhs_tidy_env name' rhs rhs1 (idInfo cbv_bndr)
-                             show_unfold
+    idinfo'  = tidyTopIdInfo rhs_tidy_env name' ty'
+                             rhs rhs1 (idInfo cbv_bndr) show_unfold
 
 -- tidyTopIdInfo creates the final IdInfo for top-level
 -- binders.  The delicate piece:
@@ -1228,9 +1217,9 @@ tidyTopPair uf_opts show_unfold boot_exports rhs_tidy_env name' (bndr, rhs)
 --      Indeed, CorePrep must eta expand where necessary to make
 --      the manifest arity equal to the claimed arity.
 --
-tidyTopIdInfo :: UnfoldingOpts -> TidyEnv -> Name -> CoreExpr -> CoreExpr
+tidyTopIdInfo :: TidyEnv -> Name -> Type -> CoreExpr -> CoreExpr
               -> IdInfo -> Bool -> IdInfo
-tidyTopIdInfo uf_opts rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold
+tidyTopIdInfo rhs_tidy_env name rhs_ty orig_rhs tidy_rhs idinfo show_unfold
   | not is_external     -- For internal Ids (not externally visible)
   = vanillaIdInfo       -- we only need enough info for code generation
                         -- Arity and strictness info are enough;
@@ -1281,13 +1270,17 @@ tidyTopIdInfo uf_opts rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold
 
     --------- Unfolding ------------
     unf_info = realUnfoldingInfo idinfo
-    unfold_info
-      | isCompulsoryUnfolding unf_info || show_unfold
-      = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs
-      | otherwise
-      = minimal_unfold_info
-    minimal_unfold_info = trimUnfolding unf_info
-    unf_from_rhs = mkFinalUnfolding uf_opts InlineRhs final_sig tidy_rhs
+    !minimal_unfold_info = trimUnfolding unf_info
+
+    !unfold_info | isCompulsoryUnfolding unf_info || show_unfold
+                 = tidyTopUnfolding rhs_tidy_env tidy_rhs unf_info
+                 | otherwise
+                 = minimal_unfold_info
+
+     -- NB: use `orig_rhs` not `tidy_rhs` in this call to mkFinalUnfolding
+     -- else you get a black hole (#22122). Reason: mkFinalUnfolding
+     -- looks at IdInfo, and that is knot-tied in tidyTopBind (the Rec case)
+
     -- NB: do *not* expose the worker if show_unfold is off,
     --     because that means this thing is a loop breaker or
     --     marked NOINLINE or something like that
@@ -1311,4 +1304,54 @@ tidyTopIdInfo uf_opts rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold
     -- did was to let-bind a non-atomic argument and then float
     -- it to the top level. So it seems more robust just to
     -- fix it here.
-    arity = exprArity orig_rhs
+    arity = exprArity orig_rhs `min` (length $ typeArity rhs_ty)
+
+
+------------ Unfolding  --------------
+tidyTopUnfolding :: TidyEnv -> CoreExpr -> Unfolding -> Unfolding
+tidyTopUnfolding _ _ NoUnfolding   = NoUnfolding
+tidyTopUnfolding _ _ BootUnfolding = BootUnfolding
+tidyTopUnfolding _ _ (OtherCon {}) = evaldUnfolding
+
+tidyTopUnfolding tidy_env _ df@(DFunUnfolding { df_bndrs = bndrs, df_args = args })
+  = df { df_bndrs = bndrs', df_args = map (tidyExpr tidy_env') args }
+  where
+    (tidy_env', bndrs') = tidyBndrs tidy_env bndrs
+
+tidyTopUnfolding tidy_env tidy_rhs
+     unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src  })
+  = -- See Note [tidyTopUnfolding: avoiding black holes]
+    unf { uf_tmpl = tidy_unf_rhs }
+  where
+    tidy_unf_rhs | isStableSource src
+                 = tidyExpr tidy_env unf_rhs    -- Preserves OccInfo in unf_rhs
+                 | otherwise
+                 = occurAnalyseExpr tidy_rhs    -- Do occ-anal
+
+{- Note [tidyTopUnfolding: avoiding black holes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we are exposing all unfoldings we don't want to tidy the unfolding
+twice -- we just want to use the tidied RHS.  That tidied RHS itself
+contains fully-tidied Ids -- it is knot-tied.  So the uf_tmpl for the
+unfolding contains stuff we can't look at.  Now consider (#22112)
+   foo = foo
+If we freshly compute the uf_is_value field for foo's unfolding,
+we'll call `exprIsValue`, which will look at foo's unfolding!
+Whether or not the RHS is a value depends on whether foo is a value...
+black hole.
+
+In the Simplifier we deal with this by not giving `foo` an unfolding
+in its own RHS.  And we could do that here.  But it's qite nice
+to common everything up to a single Id for foo, used everywhere.
+
+And it's not too hard: simply leave the unfolding undisturbed, except
+tidy the uf_tmpl field. Hence tidyTopUnfolding does
+   unf { uf_tmpl = tidy_unf_rhs }
+
+Don't mess with uf_is_value, or guidance; in particular don't recompute
+them from tidy_unf_rhs.
+
+And (unlike tidyNestedUnfolding) don't deep-seq the new unfolding,
+because that'll cause a black hole (I /think/ because occurAnalyseExpr
+looks in IdInfo).
+-}
\ No newline at end of file
diff --git a/compiler/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs
index c0027eab18..126223226c 100644
--- a/compiler/GHC/Types/Id/Info.hs
+++ b/compiler/GHC/Types/Id/Info.hs
@@ -834,7 +834,7 @@ zapFragileUnfolding unf
 trimUnfolding :: Unfolding -> Unfolding
 -- Squash all unfolding info, preserving only evaluated-ness
 trimUnfolding unf | isEvaldUnfolding unf = evaldUnfolding
-                 | otherwise            = noUnfolding
+                  | otherwise            = noUnfolding
 
 zapTailCallInfo :: IdInfo -> Maybe IdInfo
 zapTailCallInfo info
diff --git a/testsuite/tests/simplCore/should_compile/T22112.hs b/testsuite/tests/simplCore/should_compile/T22112.hs
new file mode 100644
index 0000000000..19291c39dc
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T22112.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+module Rec where
+
+-- This one created a black hole in Tidy,
+-- when creating the tidied unfolding for foo
+foo :: () -> ()
+foo = foo
diff --git a/testsuite/tests/simplCore/should_compile/T22112.stderr b/testsuite/tests/simplCore/should_compile/T22112.stderr
new file mode 100644
index 0000000000..1a97dd9b41
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T22112.stderr
@@ -0,0 +1,14 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+  = {terms: 2, types: 2, coercions: 0, joins: 0/0}
+
+Rec {
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+foo [Occ=LoopBreaker] :: () -> ()
+[GblId, Str=b, Cpr=b]
+foo = foo
+end Rec }
+
+
+
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index bbed3c805f..acaba48686 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -393,4 +393,5 @@ test('OpaqueNoStrictArgWW', normal, compile, ['-O -fworker-wrapper-cbv -ddump-si
 test('OpaqueNoWW', normal, compile, ['-O -ddump-simpl -dsuppress-uniques'])
 
 test('T21144',  normal, compile, ['-O'])
+test('T22112', normal, compile, ['-O -dsuppress-uniques -dno-typeable-binds -ddump-simpl'])