Fix a nasty loop in Tidywip/T22112

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]

6 files changed, 124 insertions, 71 deletions

diff --git a/compiler/GHC/Core/Tidy.hs b/compiler/GHC/Core/Tidy.hs
index d3cface58c..3a73ce7dd5 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
@@ -360,33 +360,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 76c0a7b2cb..373a881c0c 100644
--- a/compiler/GHC/Iface/Tidy.hs
+++ b/compiler/GHC/Iface/Tidy.hs
@@ -24,16 +24,17 @@ import GHC.Tc.Utils.Env
 
 import GHC.Core
 import GHC.Core.Unfold
-import GHC.Core.Unfold.Make
+-- import GHC.Core.Unfold.Make
 import GHC.Core.FVs
 import GHC.Core.Tidy
-import GHC.Core.Seq     (seqBinds)
+import GHC.Core.Seq         ( seqBinds )
 import GHC.Core.Opt.Arity   ( exprArity, typeArity, exprBotStrictness_maybe )
 import GHC.Core.InstEnv
 import GHC.Core.Type     ( Type, tidyTopType )
 import GHC.Core.DataCon
 import GHC.Core.TyCon
 import GHC.Core.Class
+import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )
 
 import GHC.Iface.Tidy.StaticPtrTable
 import GHC.Iface.Env
@@ -383,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
@@ -1152,60 +1152,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
@@ -1214,17 +1203,18 @@ 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' ty'
+    idinfo'  = tidyTopIdInfo rhs_tidy_env name' ty'
                              rhs rhs1 (idInfo cbv_bndr) show_unfold
 
 -- tidyTopIdInfo creates the final IdInfo for top-level
@@ -1234,9 +1224,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 -> Type
+tidyTopIdInfo :: TidyEnv -> Name -> Type
               -> CoreExpr -> CoreExpr -> IdInfo -> Bool -> IdInfo
-tidyTopIdInfo uf_opts rhs_tidy_env name rhs_ty 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;
@@ -1292,31 +1282,20 @@ tidyTopIdInfo uf_opts rhs_tidy_env name rhs_ty orig_rhs tidy_rhs idinfo show_unf
           Just (arity, _, _) -> not (isDeadEndAppSig id_sig arity)
 
     --------- Unfolding ------------
+    -- Force unfold_info (hence bangs), otherwise the old unfolding
+    -- is retained during code generation. See #22071
+
     unf_info = realUnfoldingInfo idinfo
-    -- Force this, otherwise the old unfolding is retained over code generation
-    -- See #22071
-    !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
-    -- 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
-    -- This is important: if you expose the worker for a loop-breaker
-    -- then you can make the simplifier go into an infinite loop, because
-    -- in effect the unfolding is exposed.  See #1709
-    --
-    -- You might think that if show_unfold is False, then the thing should
-    -- not be w/w'd in the first place.  But a legitimate reason is this:
-    --    the function returns bottom
-    -- In this case, show_unfold will be false (we don't expose unfoldings
-    -- for bottoming functions), but we might still have a worker/wrapper
-    -- split (see Note [Worker/wrapper for bottoming functions] in
-    -- GHC.Core.Opt.WorkWrap)
 
+    !unfold_info | isCompulsoryUnfolding unf_info || show_unfold
+                 = tidyTopUnfolding rhs_tidy_env tidy_rhs unf_info
+                 | otherwise
+                 = minimal_unfold_info
+--    unf_from_rhs = mkFinalUnfolding uf_opts InlineRhs final_sig orig_rhs
+     -- 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)
 
     --------- Arity ------------
     -- Usually the Id will have an accurate arity on it, because
@@ -1328,10 +1307,59 @@ tidyTopIdInfo uf_opts rhs_tidy_env name rhs_ty orig_rhs tidy_rhs idinfo show_unf
     arity = exprArity orig_rhs `min` typeArity rhs_ty
             -- orig_rhs: using tidy_rhs would make a black hole, since
             --           exprArity uses the arities of Ids inside the rhs
+            --
             -- typeArity: see Note [Arity invariants for bindings]
             --            in GHC.Core.Opt.Arity
 
-{-
+------------ 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).
+
+
 ************************************************************************
 *                                                                      *
                   Old, dead, type-trimming code
diff --git a/compiler/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs
index a35845f612..381a48efd3 100644
--- a/compiler/GHC/Types/Id/Info.hs
+++ b/compiler/GHC/Types/Id/Info.hs
@@ -816,7 +816,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 012150b21e..badd9d8834 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -415,6 +415,7 @@ test('T17966',  [ grep_errmsg(r'SPEC') ], compile, ['-O -ddump-spec'])
 # We expect to see a SPEC rule for $cm
 test('T19644',  [ grep_errmsg(r'SPEC') ], compile, ['-O -ddump-spec'])
 test('T21391', normal, compile, ['-O -dcore-lint'])
+test('T22112', normal, compile, ['-O -dsuppress-uniques -dno-typeable-binds -ddump-simpl'])
 test('T21391a', normal, compile, ['-O -dcore-lint'])
 # We don't want to see a thunk allocation for the insertBy expression after CorePrep.
 test('T21392', [ grep_errmsg(r'sat.* :: \[\(.*Unique, .*Int\)\]'), expect_broken(21392) ], compile, ['-O -ddump-prep -dno-typeable-binds -dsuppress-uniques'])