Fix loop in the interface representation of some `Unfolding` fields

As discovered in #22272, dehydration of the unfolding info of a
recursive definition used to involve a traversal of the definition
itself, which in turn involves traversing the unfolding info. Hence,
a loop.

Instead, we now store enough data in the interface that we can produce
the unfolding info without this traversal. See Note [Tying the 'CoreUnfolding' knot]
for details.

Fixes #22272

Co-authored-by: Simon Peyton Jones <simon.peytonjones@gmail.com>

9 files changed, 83 insertions, 59 deletions

diff --git a/compiler/GHC/Core/Opt/Simplify/Iteration.hs b/compiler/GHC/Core/Opt/Simplify/Iteration.hs
index 36c969224c..1e285dcccd 100644
--- a/compiler/GHC/Core/Opt/Simplify/Iteration.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Iteration.hs
@@ -4210,7 +4210,7 @@ simplLetUnfolding env bind_cxt id new_rhs rhs_ty arity unf
 mkLetUnfolding :: UnfoldingOpts -> TopLevelFlag -> UnfoldingSource
                -> InId -> OutExpr -> SimplM Unfolding
 mkLetUnfolding !uf_opts top_lvl src id new_rhs
-  = return (mkUnfolding uf_opts src is_top_lvl is_bottoming new_rhs)
+  = return (mkUnfolding uf_opts src is_top_lvl is_bottoming new_rhs Nothing)
             -- We make an  unfolding *even for loop-breakers*.
             -- Reason: (a) It might be useful to know that they are WHNF
             --         (b) In GHC.Iface.Tidy we currently assume that, if we want to
@@ -4270,7 +4270,7 @@ simplStableUnfolding env bind_cxt id rhs_ty id_arity unf
                         -- A test case is #4138
                         -- But retain a previous boring_ok of True; e.g. see
                         -- the way it is set in calcUnfoldingGuidanceWithArity
-                        in return (mkCoreUnfolding src is_top_lvl expr' guide')
+                        in return (mkCoreUnfolding src is_top_lvl expr' Nothing guide')
                             -- See Note [Top-level flag on inline rules] in GHC.Core.Unfold
 
                   _other              -- Happens for INLINABLE things
diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs
index 262272b5d8..3a8a6b4acc 100644
--- a/compiler/GHC/Core/Opt/Simplify/Utils.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs
@@ -2169,7 +2169,7 @@ abstractFloats uf_opts top_lvl main_tvs floats body
       = (poly_id `setIdUnfolding` unf, poly_rhs)
       where
         poly_rhs = mkLams tvs_here rhs
-        unf = mkUnfolding uf_opts VanillaSrc is_top_lvl False poly_rhs
+        unf = mkUnfolding uf_opts VanillaSrc is_top_lvl False poly_rhs Nothing
 
         -- We want the unfolding.  Consider
         --      let
diff --git a/compiler/GHC/Core/Ppr.hs b/compiler/GHC/Core/Ppr.hs
index e24dc20fb9..17559cf4a9 100644
--- a/compiler/GHC/Core/Ppr.hs
+++ b/compiler/GHC/Core/Ppr.hs
@@ -627,18 +627,14 @@ instance Outputable Unfolding where
                 <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)
             2 (ppr con <+> sep (map ppr args))
   ppr (CoreUnfolding { uf_src = src
-                     , uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf
-                     , uf_is_conlike=conlike, uf_is_work_free=wf
-                     , uf_expandable=exp, uf_guidance=g })
+                     , uf_tmpl=rhs, uf_is_top=top
+                     , uf_cache=cache, uf_guidance=g })
         = text "Unf" <> braces (pp_info $$ pp_rhs)
     where
       pp_info = fsep $ punctuate comma
                 [ text "Src="        <> ppr src
                 , text "TopLvl="     <> ppr top
-                , text "Value="      <> ppr hnf
-                , text "ConLike="    <> ppr conlike
-                , text "WorkFree="   <> ppr wf
-                , text "Expandable=" <> ppr exp
+                , ppr cache
                 , text "Guidance="   <> ppr g ]
       pp_tmpl = ppUnlessOption sdocSuppressUnfoldings
                   (text "Tmpl=" <+> ppr rhs)
@@ -647,6 +643,15 @@ instance Outputable Unfolding where
             -- Don't print the RHS or we get a quadratic
             -- blowup in the size of the printout!
 
+instance Outputable UnfoldingCache where
+    ppr (UnfoldingCache { uf_is_value = hnf, uf_is_conlike = conlike
+                        , uf_is_work_free = wf, uf_expandable = exp })
+        = fsep $ punctuate comma
+          [ text "Value="      <> ppr hnf
+          , text "ConLike="    <> ppr conlike
+          , text "WorkFree="   <> ppr wf
+          , text "Expandable=" <> ppr exp ]
+
 {-
 -----------------------------------------------------
 --      Rules
diff --git a/compiler/GHC/Core/Seq.hs b/compiler/GHC/Core/Seq.hs
index 0addae9775..2f72fc4c9f 100644
--- a/compiler/GHC/Core/Seq.hs
+++ b/compiler/GHC/Core/Seq.hs
@@ -104,10 +104,11 @@ seqAlts (Alt c bs e:alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts al
 
 seqUnfolding :: Unfolding -> ()
 seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top,
-                uf_is_value = b1, uf_is_work_free = b2,
-                uf_expandable = b3, uf_is_conlike = b4,
-                uf_guidance = g})
-  = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` b3 `seq` b4 `seq` seqGuidance g
+                uf_cache = cache, uf_guidance = g})
+  = seqExpr e `seq` top `seq` cache `seq` seqGuidance g
+    -- The unf_cache :: UnfoldingCache field is a strict data type,
+    -- so it is sufficient to use plain `seq` for this field
+    -- See Note [UnfoldingCache] in GHC.Core
 
 seqUnfolding _ = ()
 
diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs
index 5638762e08..ba95baec64 100644
--- a/compiler/GHC/Core/SimpleOpt.hs
+++ b/compiler/GHC/Core/SimpleOpt.hs
@@ -759,7 +759,7 @@ add_info env old_bndr top_level new_rhs new_bndr
    unfolding_from_rhs = mkUnfolding uf_opts VanillaSrc
                                     (isTopLevel top_level)
                                     False -- may be bottom or not
-                                    new_rhs
+                                    new_rhs Nothing
 
 simpleUnfoldingFun :: IdUnfoldingFun
 simpleUnfoldingFun id
diff --git a/compiler/GHC/Core/Tidy.hs b/compiler/GHC/Core/Tidy.hs
index 2a4c538ab1..5326346ead 100644
--- a/compiler/GHC/Core/Tidy.hs
+++ b/compiler/GHC/Core/Tidy.hs
@@ -375,15 +375,16 @@ tidyNestedUnfolding tidy_env df@(DFunUnfolding { df_bndrs = bndrs, df_args = arg
     (tidy_env', bndrs') = tidyBndrs tidy_env bndrs
 
 tidyNestedUnfolding tidy_env
-    unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src, uf_is_value = is_value })
+    unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src, uf_cache = cache })
   | 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)
+            -- This seqIt avoids a space leak: otherwise the uf_cache
+            -- field 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
+  | uf_is_value cache = evaldUnfolding
   | otherwise = noUnfolding
 
   where
diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs
index 56f8251e3d..7446a2e983 100644
--- a/compiler/GHC/Core/Unfold.hs
+++ b/compiler/GHC/Core/Unfold.hs
@@ -1036,11 +1036,11 @@ callSiteInline logger opts !case_depth id active_unfolding lone_variable arg_inf
       -- Things with an INLINE pragma may have an unfolding *and*
       -- be a loop breaker  (maybe the knot is not yet untied)
         CoreUnfolding { uf_tmpl = unf_template
-                      , uf_is_work_free = is_wf
-                      , uf_guidance = guidance, uf_expandable = is_exp }
+                      , uf_cache = unf_cache
+                      , uf_guidance = guidance }
           | active_unfolding -> tryUnfolding logger opts case_depth id lone_variable
                                     arg_infos cont_info unf_template
-                                    is_wf is_exp guidance
+                                    unf_cache guidance
           | otherwise -> traceInline logger opts id "Inactive unfolding:" (ppr id) Nothing
         NoUnfolding      -> Nothing
         BootUnfolding    -> Nothing
@@ -1162,11 +1162,10 @@ needed on a per-module basis.
 -}
 
 tryUnfolding :: Logger -> UnfoldingOpts -> Int -> Id -> Bool -> [ArgSummary] -> CallCtxt
-             -> CoreExpr -> Bool -> Bool -> UnfoldingGuidance
+             -> CoreExpr -> UnfoldingCache -> UnfoldingGuidance
              -> Maybe CoreExpr
-tryUnfolding logger opts !case_depth id lone_variable
-             arg_infos cont_info unf_template
-             is_wf is_exp guidance
+tryUnfolding logger opts !case_depth id lone_variable arg_infos
+             cont_info unf_template unf_cache guidance
  = case guidance of
      UnfNever -> traceInline logger opts id str (text "UnfNever") Nothing
 
@@ -1178,7 +1177,7 @@ tryUnfolding logger opts !case_depth id lone_variable
         -> traceInline logger opts id str (mk_doc some_benefit empty False) Nothing
         where
           some_benefit = calc_some_benefit uf_arity
-          enough_args = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0)
+          enough_args  = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0)
 
      UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size }
         | unfoldingVeryAggressive opts
@@ -1189,9 +1188,6 @@ tryUnfolding logger opts !case_depth id lone_variable
         -> traceInline logger opts id str (mk_doc some_benefit extra_doc False) Nothing
         where
           some_benefit = calc_some_benefit (length arg_discounts)
-          extra_doc = vcat [ text "case depth =" <+> int case_depth
-                           , text "depth based penalty =" <+> int depth_penalty
-                           , text "discounted size =" <+> int adjusted_size ]
           -- See Note [Avoid inlining into deeply nested cases]
           depth_treshold = unfoldingCaseThreshold opts
           depth_scaling = unfoldingCaseScaling opts
@@ -1201,7 +1197,18 @@ tryUnfolding logger opts !case_depth id lone_variable
           small_enough = adjusted_size <= unfoldingUseThreshold opts
           discount = computeDiscount arg_discounts res_discount arg_infos cont_info
 
+          extra_doc = vcat [ text "case depth =" <+> int case_depth
+                           , text "depth based penalty =" <+> int depth_penalty
+                           , text "discounted size =" <+> int adjusted_size ]
+
   where
+    -- Unpack the UnfoldingCache lazily because it may not be needed, and all
+    -- its fields are strict; so evaluating unf_cache at all forces all the
+    -- isWorkFree etc computations to take place.  That risks wasting effort for
+    -- Ids that are never going to inline anyway.
+    -- See Note [UnfoldingCache] in GHC.Core
+    UnfoldingCache{ uf_is_work_free = is_wf, uf_expandable = is_exp } = unf_cache
+
     mk_doc some_benefit extra_doc yes_or_no
       = vcat [ text "arg infos" <+> ppr arg_infos
              , text "interesting continuation" <+> ppr cont_info
diff --git a/compiler/GHC/Core/Unfold/Make.hs b/compiler/GHC/Core/Unfold/Make.hs
index adbbdec763..479187005b 100644
--- a/compiler/GHC/Core/Unfold/Make.hs
+++ b/compiler/GHC/Core/Unfold/Make.hs
@@ -6,6 +6,7 @@ module GHC.Core.Unfold.Make
    , mkUnfolding
    , mkCoreUnfolding
    , mkFinalUnfolding
+   , mkFinalUnfolding'
    , mkSimpleUnfolding
    , mkWorkerUnfolding
    , mkInlineUnfoldingWithArity, mkInlineUnfoldingNoArity
@@ -35,6 +36,8 @@ import GHC.Utils.Outputable
 import GHC.Utils.Misc
 import GHC.Utils.Panic
 
+import Data.Maybe ( fromMaybe )
+
 -- the very simple optimiser is used to optimise unfoldings
 import {-# SOURCE #-} GHC.Core.SimpleOpt
 
@@ -43,7 +46,14 @@ import {-# SOURCE #-} GHC.Core.SimpleOpt
 mkFinalUnfolding :: UnfoldingOpts -> UnfoldingSource -> DmdSig -> CoreExpr -> Unfolding
 -- "Final" in the sense that this is a GlobalId that will not be further
 -- simplified; so the unfolding should be occurrence-analysed
-mkFinalUnfolding opts src strict_sig expr
+mkFinalUnfolding opts src strict_sig expr = mkFinalUnfolding' opts src strict_sig expr Nothing
+
+-- See Note [Tying the 'CoreUnfolding' knot] for why interfaces need
+-- to pass a precomputed 'UnfoldingCache'
+mkFinalUnfolding' :: UnfoldingOpts -> UnfoldingSource -> DmdSig -> CoreExpr -> Maybe UnfoldingCache -> Unfolding
+-- "Final" in the sense that this is a GlobalId that will not be further
+-- simplified; so the unfolding should be occurrence-analysed
+mkFinalUnfolding' opts src strict_sig expr
   = mkUnfolding opts src
                 True {- Top level -}
                 (isDeadEndSig strict_sig)
@@ -57,7 +67,7 @@ mkCompulsoryUnfolding' opts expr = mkCompulsoryUnfolding (simpleOptExpr opts exp
 mkCompulsoryUnfolding :: CoreExpr -> Unfolding
 mkCompulsoryUnfolding expr
   = mkCoreUnfolding CompulsorySrc True
-                    expr
+                    expr Nothing
                     (UnfWhen { ug_arity = 0    -- Arity of unfolding doesn't matter
                              , ug_unsat_ok = unSaturatedOk, ug_boring_ok = boringCxtOk })
 
@@ -69,7 +79,7 @@ mkCompulsoryUnfolding expr
 
 mkSimpleUnfolding :: UnfoldingOpts -> CoreExpr -> Unfolding
 mkSimpleUnfolding !opts rhs
-  = mkUnfolding opts VanillaSrc False False rhs
+  = mkUnfolding opts VanillaSrc False False rhs Nothing
 
 mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding
 mkDFunUnfolding bndrs con ops
@@ -81,7 +91,7 @@ mkDFunUnfolding bndrs con ops
 mkDataConUnfolding :: CoreExpr -> Unfolding
 -- Used for non-newtype data constructors with non-trivial wrappers
 mkDataConUnfolding expr
-  = mkCoreUnfolding StableSystemSrc True expr guide
+  = mkCoreUnfolding StableSystemSrc True expr Nothing guide
     -- No need to simplify the expression
   where
     guide = UnfWhen { ug_arity     = manifestArity expr
@@ -93,7 +103,7 @@ mkWrapperUnfolding :: SimpleOpts -> CoreExpr -> Arity -> Unfolding
 -- after demand/CPR analysis
 mkWrapperUnfolding opts expr arity
   = mkCoreUnfolding StableSystemSrc True
-                    (simpleOptExpr opts expr)
+                    (simpleOptExpr opts expr) Nothing
                     (UnfWhen { ug_arity     = arity
                              , ug_unsat_ok  = unSaturatedOk
                              , ug_boring_ok = boringCxtNotOk })
@@ -104,7 +114,7 @@ mkWorkerUnfolding opts work_fn
                   (CoreUnfolding { uf_src = src, uf_tmpl = tmpl
                                  , uf_is_top = top_lvl })
   | isStableSource src
-  = mkCoreUnfolding src top_lvl new_tmpl guidance
+  = mkCoreUnfolding src top_lvl new_tmpl Nothing guidance
   where
     new_tmpl = simpleOptExpr opts (work_fn tmpl)
     guidance = calcUnfoldingGuidance (so_uf_opts opts) False new_tmpl
@@ -119,7 +129,7 @@ mkInlineUnfoldingNoArity :: SimpleOpts -> UnfoldingSource -> CoreExpr -> Unfoldi
 mkInlineUnfoldingNoArity opts src expr
   = mkCoreUnfolding src
                     True         -- Note [Top-level flag on inline rules]
-                    expr' guide
+                    expr' Nothing guide
   where
     expr' = simpleOptExpr opts expr
     guide = UnfWhen { ug_arity = manifestArity expr'
@@ -133,7 +143,7 @@ mkInlineUnfoldingWithArity :: SimpleOpts -> UnfoldingSource -> Arity -> CoreExpr
 mkInlineUnfoldingWithArity opts src arity expr
   = mkCoreUnfolding src
                     True         -- Note [Top-level flag on inline rules]
-                    expr' guide
+                    expr' Nothing guide
   where
     expr' = simpleOptExpr opts expr
     guide = UnfWhen { ug_arity = arity
@@ -146,7 +156,7 @@ mkInlineUnfoldingWithArity opts src arity expr
 
 mkInlinableUnfolding :: SimpleOpts -> UnfoldingSource -> CoreExpr -> Unfolding
 mkInlinableUnfolding opts src expr
-  = mkUnfolding (so_uf_opts opts) src False False expr'
+  = mkUnfolding (so_uf_opts opts) src False False expr' Nothing
   where
     expr' = simpleOptExpr opts expr
 
@@ -180,7 +190,7 @@ specUnfolding opts spec_bndrs spec_app rule_lhs_args
                              , uf_guidance = old_guidance })
  | isStableSource src  -- See Note [Specialising unfoldings]
  , UnfWhen { ug_arity = old_arity } <- old_guidance
- = mkCoreUnfolding src top_lvl new_tmpl
+ = mkCoreUnfolding src top_lvl new_tmpl Nothing
                    (old_guidance { ug_arity = old_arity - arity_decrease })
  where
    new_tmpl = simpleOptExpr opts $
@@ -310,11 +320,12 @@ mkUnfolding :: UnfoldingOpts
             -> Bool       -- Definitely a bottoming binding
                           -- (only relevant for top-level bindings)
             -> CoreExpr
+            -> Maybe UnfoldingCache
             -> Unfolding
 -- Calculates unfolding guidance
 -- Occurrence-analyses the expression before capturing it
-mkUnfolding opts src top_lvl is_bottoming expr
-  = mkCoreUnfolding src top_lvl expr guidance
+mkUnfolding opts src top_lvl is_bottoming expr cache
+  = mkCoreUnfolding src top_lvl expr cache guidance
   where
     is_top_bottoming = top_lvl && is_bottoming
     guidance         = calcUnfoldingGuidance opts is_top_bottoming expr
@@ -322,26 +333,20 @@ mkUnfolding opts src top_lvl is_bottoming expr
         -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression]
 
 mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr
-                -> UnfoldingGuidance -> Unfolding
+                -> Maybe UnfoldingCache -> UnfoldingGuidance -> Unfolding
 -- Occurrence-analyses the expression before capturing it
-mkCoreUnfolding src top_lvl expr guidance
-  = CoreUnfolding { uf_tmpl = is_value `seq`
-                              is_conlike `seq`
-                              is_work_free `seq`
-                              is_expandable `seq`
+mkCoreUnfolding src top_lvl expr precomputed_cache guidance
+  = CoreUnfolding { uf_tmpl = cache `seq`
                               occurAnalyseExpr expr
       -- occAnalyseExpr: see Note [Occurrence analysis of unfoldings]
-      -- See #20905 for what a discussion of these 'seq's
+      -- See #20905 for what a discussion of this 'seq'.
       -- We are careful to make sure we only
       -- have one copy of an unfolding around at once.
       -- Note [Thoughtful forcing in mkCoreUnfolding]
 
                   , uf_src          = src
                   , uf_is_top       = top_lvl
-                  , uf_is_value     = is_value
-                  , uf_is_conlike   = is_conlike
-                  , uf_is_work_free = is_work_free
-                  , uf_expandable   = is_expandable
+                  , uf_cache        = cache
                   , uf_guidance     = guidance }
   where
     is_value      = exprIsHNF expr
@@ -349,6 +354,13 @@ mkCoreUnfolding src top_lvl expr guidance
     is_work_free  = exprIsWorkFree expr
     is_expandable = exprIsExpandable expr
 
+    recomputed_cache = UnfoldingCache { uf_is_value = is_value
+                                      , uf_is_conlike = is_conlike
+                                      , uf_is_work_free = is_work_free
+                                      , uf_expandable = is_expandable }
+
+    cache = fromMaybe recomputed_cache precomputed_cache
+
 ----------------
 certainlyWillInline :: UnfoldingOpts -> IdInfo -> CoreExpr -> Maybe Unfolding
 -- ^ Sees if the unfolding is pretty certain to inline.
@@ -476,4 +488,3 @@ reducing memory pressure.
 The result of fixing this led to a 1G reduction in peak memory usage (12G -> 11G) when
 compiling a very large module (peak 3 million terms). For more discussion see #20905.
 -}
-
diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs
index 3f3ef30a14..c88ddb3d55 100644
--- a/compiler/GHC/Core/Utils.hs
+++ b/compiler/GHC/Core/Utils.hs
@@ -2253,10 +2253,9 @@ diffUnfold env (DFunUnfolding bs1 c1 a1)
   | c1 == c2 && equalLength bs1 bs2
   = concatMap (uncurry (diffExpr False env')) (zip a1 a2)
   where env' = rnBndrs2 env bs1 bs2
-diffUnfold env (CoreUnfolding t1 _ _ v1 cl1 wf1 x1 g1)
-               (CoreUnfolding t2 _ _ v2 cl2 wf2 x2 g2)
-  | v1 == v2 && cl1 == cl2
-    && wf1 == wf2 && x1 == x2 && g1 == g2
+diffUnfold env (CoreUnfolding t1 _ _ c1 g1)
+               (CoreUnfolding t2 _ _ c2 g2)
+  | c1 == c2 && g1 == g2
   = diffExpr False env t1 t2
 diffUnfold _   uf1 uf2
   = [fsep [ppr uf1, text "/=", ppr uf2]]