compiler/GHC/Cmm/CLabel.hs

@@ -108,7 +108,7 @@ module GHC.Cmm.CLabel (
         pprCLabel,
         isInfoTableLabel,
         isConInfoTableLabel,
-        isIdLabel
+        isIdLabel, isTickyLabel
     ) where
 
 #include "HsVersions.h"
@@ -268,6 +268,12 @@ isIdLabel :: CLabel -> Bool
 isIdLabel IdLabel{} = True
 isIdLabel _ = False
 
+-- Used in SRT analysis. See Note [Ticky labels in SRT analysis] in
+-- GHC.Cmm.Info.Build.
+isTickyLabel :: CLabel -> Bool
+isTickyLabel (IdLabel _ _ RednCounts) = True
+isTickyLabel _ = False
+
 -- This is laborious, but necessary. We can't derive Ord because
 -- Unique doesn't have an Ord instance. Note nonDetCmpUnique in the
 -- implementation. See Note [No Ord for Unique]
@@ -462,8 +468,7 @@ mkSRTLabel     :: Unique -> CLabel
 mkSRTLabel u = SRTLabel u
 
 mkRednCountsLabel :: Name -> CLabel
-mkRednCountsLabel       name    =
-  IdLabel name NoCafRefs RednCounts  -- Note [ticky for LNE]
+mkRednCountsLabel name = IdLabel name NoCafRefs RednCounts  -- Note [ticky for LNE]
 
 -- These have local & (possibly) external variants:
 mkLocalClosureLabel      :: Name -> CafInfo -> CLabel

compiler/GHC/Cmm/Info/Build.hs

@@ -409,6 +409,30 @@ Maybe, but could you prove that RET_FUN is the only way that
 resurrection can occur?
 
 So, no shortcutting.
+
+Note [Ticky labels in SRT analysis]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Raw Cmm data (CmmStaticsRaw) can't contain pointers so they're considered
+non-CAFFY in SRT analysis and we update the SRTMap mapping them to `Nothing`
+(meaning they're not CAFFY).
+
+However when building with -ticky we generate ticky CLabels using the function's
+`Name`. For example, if we have a top-level function `sat_s1rQ`, in a ticky
+build we get two IdLabels using the name `sat_s1rQ`:
+
+- For the function itself: IdLabel sat_s1rQ ... Entry
+- For the ticky counter: IdLabel sat_s1rQ ... RednCounts
+
+In these cases we really want to use the function definition for the SRT
+analysis of this Name, because that's what we export for this Name -- ticky
+counters are not exported. So we ignore ticky counters in SRT analysis (which
+are never CAFFY and never exported).
+
+Not doing this caused #17947 where we analysed the function first mapped the
+name to CAFFY. We then saw the ticky constructor, and becuase it has the same
+Name as the function and is not CAFFY we overrode the CafInfo of the name as
+non-CAFFY.
 -}
 
 -- ---------------------------------------------------------------------
@@ -818,8 +842,11 @@ doSRTs dflags moduleSRTInfo procs data_ = do
                       -- already updated by oneSRT
                       srtMap
                     CmmData _ (CmmStaticsRaw lbl _)
-                      | isIdLabel lbl ->
-                          -- not analysed by oneSRT, declare it non-CAFFY here
+                      | isIdLabel lbl && not (isTickyLabel lbl) ->
+                          -- Raw data are not analysed by oneSRT and they can't
+                          -- be CAFFY.
+                          -- See Note [Ticky labels in SRT analysis] above for
+                          -- why we exclude ticky labels here.
                           Map.insert (mkCAFLabel lbl) Nothing srtMap
                       | otherwise ->
                           -- Not an IdLabel, ignore

compiler/GHC/Core/Op/Specialise.hs

@@ -589,19 +589,11 @@ specProgram guts@(ModGuts { mg_module = this_mod
              -- Specialise the bindings of this module
        ; (binds', uds) <- runSpecM dflags this_mod (go binds)
 
-             -- Specialise imported functions
-       ; hpt_rules <- getRuleBase
-       ; let rule_base = extendRuleBaseList hpt_rules local_rules
-       ; (new_rules, spec_binds) <- specImports dflags this_mod top_env emptyVarSet
-                                                [] rule_base uds
-
-       ; let final_binds
-               | null spec_binds = binds'
-               | otherwise       = Rec (flattenBinds spec_binds) : binds'
-                   -- Note [Glom the bindings if imported functions are specialised]
+       ; (spec_rules, spec_binds) <- specImports dflags this_mod top_env
+                                                 local_rules uds
 
-       ; return (guts { mg_binds = final_binds
-                      , mg_rules = new_rules ++ local_rules }) }
+       ; return (guts { mg_binds = spec_binds ++ binds'
+                      , mg_rules = spec_rules ++ local_rules }) }
   where
         -- We need to start with a Subst that knows all the things
         -- that are in scope, so that the substitution engine doesn't
@@ -645,72 +637,93 @@ See #10491
 *                                                                      *
 ********************************************************************* -}
 
--- | Specialise a set of calls to imported bindings
-specImports :: DynFlags
-            -> Module
-            -> SpecEnv          -- Passed in so that all top-level Ids are in scope
-            -> VarSet           -- Don't specialise these ones
-                                -- See Note [Avoiding recursive specialisation]
-            -> [Id]             -- Stack of imported functions being specialised
-            -> RuleBase         -- Rules from this module and the home package
-                                -- (but not external packages, which can change)
-            -> UsageDetails     -- Calls for imported things, and floating bindings
-            -> CoreM ( [CoreRule]   -- New rules
-                     , [CoreBind] ) -- Specialised bindings
-                                    -- See Note [Wrapping bindings returned by specImports]
-specImports dflags this_mod top_env done callers rule_base
+specImports :: DynFlags -> Module -> SpecEnv
+            -> [CoreRule]
+            -> UsageDetails
+            -> CoreM ([CoreRule], [CoreBind])
+specImports dflags this_mod top_env local_rules
             (MkUD { ud_binds = dict_binds, ud_calls = calls })
-  -- See Note [Disabling cross-module specialisation]
   | not $ gopt Opt_CrossModuleSpecialise dflags
-  = return ([], [])
+    -- See Note [Disabling cross-module specialisation]
+  = return ([], wrapDictBinds dict_binds [])
 
   | otherwise
-  = do { let import_calls = dVarEnvElts calls
-       ; (rules, spec_binds) <- go rule_base import_calls
+  = do { hpt_rules <- getRuleBase
+       ; let rule_base = extendRuleBaseList hpt_rules local_rules
+
+       ; (spec_rules, spec_binds) <- spec_imports dflags this_mod top_env
+                                                  [] rule_base
+                                                  dict_binds calls
 
              -- Don't forget to wrap the specialized bindings with
              -- bindings for the needed dictionaries.
              -- See Note [Wrap bindings returned by specImports]
-       ; let spec_binds' = wrapDictBinds dict_binds spec_binds
+             -- and Note [Glom the bindings if imported functions are specialised]
+       ; let final_binds
+               | null spec_binds = wrapDictBinds dict_binds []
+               | otherwise       = [Rec $ flattenBinds $
+                                    wrapDictBinds dict_binds spec_binds]
+
+       ; return (spec_rules, final_binds)
+    }
+
+-- | Specialise a set of calls to imported bindings
+spec_imports :: DynFlags
+             -> Module
+             -> SpecEnv          -- Passed in so that all top-level Ids are in scope
+             -> [Id]             -- Stack of imported functions being specialised
+                                 -- See Note [specImport call stack]
+             -> RuleBase         -- Rules from this module and the home package
+                                 -- (but not external packages, which can change)
+             -> Bag DictBind     -- Dict bindings, used /only/ for filterCalls
+                                 -- See Note [Avoiding loops in specImports]
+             -> CallDetails      -- Calls for imported things
+             -> CoreM ( [CoreRule]   -- New rules
+                      , [CoreBind] ) -- Specialised bindings
+spec_imports dflags this_mod top_env
+             callers rule_base dict_binds calls
+  = do { let import_calls = dVarEnvElts calls
+       -- ; debugTraceMsg (text "specImports {" <+>
+       --                  vcat [ text "calls:" <+> ppr import_calls
+       --                       , text "dict_binds:" <+> ppr dict_binds ])
+       ; (rules, spec_binds) <- go rule_base import_calls
+       -- ; debugTraceMsg (text "End specImports }" <+> ppr import_calls)
 
-       ; return (rules, spec_binds') }
+       ; return (rules, spec_binds) }
   where
     go :: RuleBase -> [CallInfoSet] -> CoreM ([CoreRule], [CoreBind])
     go _ [] = return ([], [])
-    go rb (cis@(CIS fn _) : other_calls)
-      = do { let ok_calls = filterCalls cis dict_binds
-                     -- Drop calls that (directly or indirectly) refer to fn
-                     -- See Note [Avoiding loops]
---           ; debugTraceMsg (text "specImport" <+> vcat [ ppr fn
---                                                       , text "calls" <+> ppr cis
---                                                       , text "ud_binds =" <+> ppr dict_binds
---                                                       , text "dump set =" <+> ppr dump_set
---                                                       , text "filtered calls =" <+> ppr ok_calls ])
-           ; (rules1, spec_binds1) <- specImport dflags this_mod top_env
-                                                 done callers rb fn ok_calls
+    go rb (cis : other_calls)
+      = do { -- debugTraceMsg (text "specImport {" <+> ppr cis)
+           ; (rules1, spec_binds1) <- spec_import dflags this_mod top_env
+                                                  callers rb dict_binds cis
+           -- ; debugTraceMsg (text "specImport }" <+> ppr cis)
 
            ; (rules2, spec_binds2) <- go (extendRuleBaseList rb rules1) other_calls
            ; return (rules1 ++ rules2, spec_binds1 ++ spec_binds2) }
 
-specImport :: DynFlags
-           -> Module
-           -> SpecEnv               -- Passed in so that all top-level Ids are in scope
-           -> VarSet                -- Don't specialise these
-                                    -- See Note [Avoiding recursive specialisation]
-           -> [Id]                  -- Stack of imported functions being specialised
-           -> RuleBase              -- Rules from this module
-           -> Id -> [CallInfo]      -- Imported function and calls for it
-           -> CoreM ( [CoreRule]    -- New rules
-                    , [CoreBind] )  -- Specialised bindings
-specImport dflags this_mod top_env done callers rb fn calls_for_fn
-  | fn `elemVarSet` done
+spec_import :: DynFlags
+            -> Module
+            -> SpecEnv               -- Passed in so that all top-level Ids are in scope
+            -> [Id]                  -- Stack of imported functions being specialised
+                                     -- See Note [specImport call stack]
+            -> RuleBase              -- Rules from this module
+            -> Bag DictBind          -- Dict bindings, used /only/ for filterCalls
+                                     -- See Note [Avoiding loops in specImports]
+            -> CallInfoSet           -- Imported function and calls for it
+            -> CoreM ( [CoreRule]    -- New rules
+                     , [CoreBind] )  -- Specialised bindings
+spec_import dflags this_mod top_env callers
+            rb dict_binds cis@(CIS fn _)
+  | isIn "specImport" fn callers
   = return ([], [])     -- No warning.  This actually happens all the time
                         -- when specialising a recursive function, because
                         -- the RHS of the specialised function contains a recursive
                         -- call to the original function
 
-  | null calls_for_fn   -- We filtered out all the calls in deleteCallsMentioning
-  = return ([], [])
+  | null good_calls
+  = do { -- debugTraceMsg (text "specImport:no valid calls")
+       ; return ([], []) }
 
   | wantSpecImport dflags unfolding
   , Just rhs <- maybeUnfoldingTemplate unfolding
@@ -723,32 +736,37 @@ specImport dflags this_mod top_env done callers rb fn calls_for_fn
        ; let full_rb = unionRuleBase rb (eps_rule_base eps)
              rules_for_fn = getRules (RuleEnv full_rb vis_orphs) fn
 
-       ; (rules1, spec_pairs, uds)
-             <- -- pprTrace "specImport1" (vcat [ppr fn, ppr calls_for_fn, ppr rhs]) $
-                runSpecM dflags this_mod $
-                specCalls (Just this_mod) top_env rules_for_fn calls_for_fn fn rhs
+       ; (rules1, spec_pairs, MkUD { ud_binds = dict_binds1, ud_calls = new_calls })
+             <- do { -- debugTraceMsg (text "specImport1" <+> vcat [ppr fn, ppr good_calls, ppr rhs])
+                   ; runSpecM dflags this_mod $
+                     specCalls (Just this_mod) top_env rules_for_fn good_calls fn rhs }
        ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs]
              -- After the rules kick in we may get recursion, but
              -- we rely on a global GlomBinds to sort that out later
              -- See Note [Glom the bindings if imported functions are specialised]
 
               -- Now specialise any cascaded calls
-       ; (rules2, spec_binds2) <- -- pprTrace "specImport 2" (ppr fn $$ ppr rules1 $$ ppr spec_binds1) $
-                                  specImports dflags this_mod top_env
-                                              (extendVarSet done fn)
-                                              (fn:callers)
-                                              (extendRuleBaseList rb rules1)
-                                              uds
+       -- ; debugTraceMsg (text "specImport 2" <+> (ppr fn $$ ppr rules1 $$ ppr spec_binds1))
+       ; (rules2, spec_binds2) <- spec_imports dflags this_mod top_env
+                                               (fn:callers)
+                                               (extendRuleBaseList rb rules1)
+                                               (dict_binds `unionBags` dict_binds1)
+                                               new_calls
 
-       ; let final_binds = spec_binds2 ++ spec_binds1
+       ; let final_binds = wrapDictBinds dict_binds1 $
+                           spec_binds2 ++ spec_binds1
 
        ; return (rules2 ++ rules1, final_binds) }
 
-  | otherwise = do { tryWarnMissingSpecs dflags callers fn calls_for_fn
-                   ; return ([], [])}
+  | otherwise
+  = do { tryWarnMissingSpecs dflags callers fn good_calls
+       ; return ([], [])}
 
   where
     unfolding = realIdUnfolding fn   -- We want to see the unfolding even for loop breakers
+    good_calls = filterCalls cis dict_binds
+       -- SUPER IMPORTANT!  Drop calls that (directly or indirectly) refer to fn
+       -- See Note [Avoiding loops in specImports]
 
 -- | Returns whether or not to show a missed-spec warning.
 -- If -Wall-missed-specializations is on, show the warning.
@@ -790,8 +808,114 @@ wantSpecImport dflags unf
                -- inside it that we want to specialise
        | otherwise -> False    -- Stable, not INLINE, hence INLINABLE
 
-{- Note [Warning about missed specialisations]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Avoiding loops in specImports]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We must take great care when specialising instance declarations
+(functions like $fOrdList) lest we accidentally build a recursive
+dictionary. See Note [Avoiding loops].
+
+The basic strategy of Note [Avoiding loops] is to use filterCalls
+to discard loopy specialisations.  But to do that we must ensure
+that the in-scope dict-binds (passed to filterCalls) contains
+all the needed dictionary bindings.  In particular, in the recursive
+call to spec_imorpts in spec_import, we must include the dict-binds
+from the parent.  Lacking this caused #17151, a really nasty bug.
+
+Here is what happened.
+* Class struture:
+    Source is a superclass of Mut
+    Index is a superclass of Source
+
+* We started with these dict binds
+    dSource = $fSourcePix @Int $fIndexInt
+    dIndex  = sc_sel dSource
+    dMut    = $fMutPix @Int dIndex
+  and these calls to specialise
+    $fMutPix @Int dIndex
+    $fSourcePix @Int $fIndexInt
+
+* We specialised the call ($fMutPix @Int dIndex)
+  ==> new call ($fSourcePix @Int dIndex)
+      (because Source is a superclass of Mut)
+
+* We specialised ($fSourcePix @Int dIndex)
+  ==> produces specialised dict $s$fSourcePix,
+      a record with dIndex as a field
+      plus RULE forall d. ($fSourcePix @Int d) = $s$fSourcePix
+  *** This is the bogus step ***
+
+* Now we decide not to specialise the call
+    $fSourcePix @Int $fIndexInt
+  because we alredy have a RULE that matches it
+
+* Finally the simplifer rewrites
+    dSource = $fSourcePix @Int $fIndexInt
+    ==>  dSource = $s$fSourcePix
+
+Disaster. Now we have
+
+Rewrite dSource's RHS to $s$fSourcePix   Disaster
+    dSource = $s$fSourcePix
+    dIndex  = sc_sel dSource
+    $s$fSourcePix = MkSource dIndex ...
+
+Solution: filterCalls should have stopped the bogus step,
+by seeing that dIndex transitively uses $fSourcePix. But
+it can only do that if it sees all the dict_binds.  Wow.
+
+--------------
+Here's another example (#13429).  Suppose we have
+  class Monoid v => C v a where ...
+
+We start with a call
+   f @ [Integer] @ Integer $fC[]Integer
+
+Specialising call to 'f' gives dict bindings
+   $dMonoid_1 :: Monoid [Integer]
+   $dMonoid_1 = M.$p1C @ [Integer] $fC[]Integer
+
+   $dC_1 :: C [Integer] (Node [Integer] Integer)
+   $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1
+
+...plus a recursive call to
+   f @ [Integer] @ (Node [Integer] Integer) $dC_1
+
+Specialising that call gives
+   $dMonoid_2  :: Monoid [Integer]
+   $dMonoid_2  = M.$p1C @ [Integer] $dC_1
+
+   $dC_2 :: C [Integer] (Node [Integer] Integer)
+   $dC_2 = M.$fCvNode @ [Integer] $dMonoid_2
+
+Now we have two calls to the imported function
+  M.$fCvNode :: Monoid v => C v a
+  M.$fCvNode @v @a m = C m some_fun
+
+But we must /not/ use the call (M.$fCvNode @ [Integer] $dMonoid_2)
+for specialisation, else we get:
+
+  $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1
+  $dMonoid_2 = M.$p1C @ [Integer] $dC_1
+  $s$fCvNode = C $dMonoid_2 ...
+    RULE M.$fCvNode [Integer] _ _ = $s$fCvNode
+
+Now use the rule to rewrite the call in the RHS of $dC_1
+and we get a loop!
+
+
+Note [specImport call stack]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When specialising an imports function 'f', we may get new calls
+of an imported fuction 'g', which we want to specialise in turn,
+and similarly specialising 'g' might expose a new call to 'h'.
+
+We track the stack of enclosing functions. So when specialising 'h' we
+haev a specImport call stack of [g,f]. We do this for two reasons:
+* Note [Warning about missed specialisations]
+* Note [Avoiding recursive specialisation]
+
+Note [Warning about missed specialisations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Suppose
  * In module Lib, you carefully mark a function 'foo' INLINABLE
  * Import Lib(foo) into another module M
@@ -807,6 +931,16 @@ is what Opt_WarnAllMissedSpecs does.
 
 ToDo: warn about missed opportunities for local functions.
 
+Note [Avoiding recursive specialisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we specialise 'f' we may find new overloaded calls to 'g', 'h' in
+'f's RHS.  So we want to specialise g,h.  But we don't want to
+specialise f any more!  It's possible that f's RHS might have a
+recursive yet-more-specialised call, so we'd diverge in that case.
+And if the call is to the same type, one specialisation is enough.
+Avoiding this recursive specialisation loop is one reason for the
+'callers' stack passed to specImports and specImport.
+
 Note [Specialise imported INLINABLE things]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 What imported functions do we specialise?  The basic set is
@@ -842,15 +976,6 @@ make sure that f_spec is recursive.  Easiest thing is to make all
 the specialisations for imported bindings recursive.
 
 
-Note [Avoiding recursive specialisation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we specialise 'f' we may find new overloaded calls to 'g', 'h' in
-'f's RHS.  So we want to specialise g,h.  But we don't want to
-specialise f any more!  It's possible that f's RHS might have a
-recursive yet-more-specialised call, so we'd diverge in that case.
-And if the call is to the same type, one specialisation is enough.
-Avoiding this recursive specialisation loop is the reason for the
-'done' VarSet passed to specImports and specImport.
 
 ************************************************************************
 *                                                                      *
@@ -992,7 +1117,8 @@ specCase env scrut' case_bndr [(con, args, rhs)]
        ; (rhs', rhs_uds)   <- specExpr env_rhs' rhs
        ; let scrut_bind    = mkDB (NonRec case_bndr_flt scrut')
              case_bndr_set = unitVarSet case_bndr_flt
-             sc_binds      = [(NonRec sc_arg_flt sc_rhs, case_bndr_set)
+             sc_binds      = [ DB { db_bind = NonRec sc_arg_flt sc_rhs
+                                  , db_fvs  = case_bndr_set }
                              | (sc_arg_flt, sc_rhs) <- sc_args_flt `zip` sc_rhss ]
              flt_binds     = scrut_bind : sc_binds
              (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds
@@ -1115,7 +1241,7 @@ specBind rhs_env (NonRec fn rhs) body_uds
          else
              -- No call in final_uds mentions bound variables,
              -- so we can just leave the binding here
-              return (map fst final_binds, free_uds) }
+              return (map db_bind final_binds, free_uds) }
 
 
 specBind rhs_env (Rec pairs) body_uds
@@ -1142,7 +1268,7 @@ specBind rhs_env (Rec pairs) body_uds
        ; if float_all then
               return ([], final_uds `snocDictBind` final_bind)
          else
-              return ([fst final_bind], final_uds) }
+              return ([db_bind final_bind], final_uds) }
 
 
 ---------------------------
@@ -1621,8 +1747,10 @@ In general, we need only make this Rec if
 Note [Avoiding loops]
 ~~~~~~~~~~~~~~~~~~~~~
 When specialising /dictionary functions/ we must be very careful to
-avoid building loops. Here is an example that bit us badly: #3591
+avoid building loops. Here is an example that bit us badly, on
+several distinct occasions.
 
+Here is one: #3591
      class Eq a => C a
      instance Eq [a] => C [a]
 
@@ -1637,13 +1765,11 @@ This translates to
 
 None of these definitions is recursive. What happened was that we
 generated a specialisation:
-
      RULE forall d. dfun T d = dT  :: C [T]
      dT = (MkD a d (meth d)) [T/a, d1/d]
         = MkD T d1 (meth d1)
 
 But now we use the RULE on the RHS of d2, to get
-
     d2 = dT = MkD d1 (meth d1)
     d1 = $p1 d2
 
@@ -1660,46 +1786,6 @@ Solution:
   (directly or indirectly) on the dfun we are specialising.
   This is done by 'filterCalls'
 
---------------
-Here's another example, this time for an imported dfun, so the call
-to filterCalls is in specImports (#13429). Suppose we have
-  class Monoid v => C v a where ...
-
-We start with a call
-   f @ [Integer] @ Integer $fC[]Integer
-
-Specialising call to 'f' gives dict bindings
-   $dMonoid_1 :: Monoid [Integer]
-   $dMonoid_1 = M.$p1C @ [Integer] $fC[]Integer
-
-   $dC_1 :: C [Integer] (Node [Integer] Integer)
-   $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1
-
-...plus a recursive call to
-   f @ [Integer] @ (Node [Integer] Integer) $dC_1
-
-Specialising that call gives
-   $dMonoid_2  :: Monoid [Integer]
-   $dMonoid_2  = M.$p1C @ [Integer] $dC_1
-
-   $dC_2 :: C [Integer] (Node [Integer] Integer)
-   $dC_2 = M.$fCvNode @ [Integer] $dMonoid_2
-
-Now we have two calls to the imported function
-  M.$fCvNode :: Monoid v => C v a
-  M.$fCvNode @v @a m = C m some_fun
-
-But we must /not/ use the call (M.$fCvNode @ [Integer] $dMonoid_2)
-for specialisation, else we get:
-
-  $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1
-  $dMonoid_2 = M.$p1C @ [Integer] $dC_1
-  $s$fCvNode = C $dMonoid_2 ...
-    RULE M.$fCvNode [Integer] _ _ = $s$fCvNode
-
-Now use the rule to rewrite the call in the RHS of $dC_1
-and we get a loop!
-
 --------------
 Here's yet another example
 
@@ -2227,7 +2313,7 @@ data UsageDetails
 
 -- | A 'DictBind' is a binding along with a cached set containing its free
 -- variables (both type variables and dictionaries)
-type DictBind = (CoreBind, VarSet)
+data DictBind = DB { db_bind :: CoreBind, db_fvs :: VarSet }
 
 {- Note [Floated dictionary bindings]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2256,6 +2342,11 @@ So the DictBinds in (ud_binds :: Bag DictBind) may contain
 non-dictionary bindings too.
 -}
 
+instance Outputable DictBind where
+  ppr (DB { db_bind = bind, db_fvs = fvs })
+    = text "DB" <+> braces (sep [ text "bind:" <+> ppr bind
+                                , text "fvs: " <+> ppr fvs ])
+
 instance Outputable UsageDetails where
   ppr (MkUD { ud_binds = dbs, ud_calls = calls })
         = text "MkUD" <+> braces (sep (punctuate comma
@@ -2304,8 +2395,8 @@ ppr_call_key_ty (SpecDict _)  = Nothing
 ppr_call_key_ty UnspecArg     = Nothing
 
 instance Outputable CallInfo where
-  ppr (CI { ci_key = key, ci_fvs = fvs })
-    = text "CI" <> braces (hsep [ fsep (mapMaybe ppr_call_key_ty key), ppr fvs ])
+  ppr (CI { ci_key = key, ci_fvs = _fvs })
+    = text "CI" <> braces (sep (map ppr key))
 
 unionCalls :: CallDetails -> CallDetails -> CallDetails
 unionCalls c1 c2 = plusDVarEnv_C unionCallInfoSet c1 c2
@@ -2491,11 +2582,11 @@ plusUDs (MkUD {ud_binds = db1, ud_calls = calls1})
 
 -----------------------------
 _dictBindBndrs :: Bag DictBind -> [Id]
-_dictBindBndrs dbs = foldr ((++) . bindersOf . fst) [] dbs
+_dictBindBndrs dbs = foldr ((++) . bindersOf . db_bind) [] dbs
 
 -- | Construct a 'DictBind' from a 'CoreBind'
 mkDB :: CoreBind -> DictBind
-mkDB bind = (bind, bind_fvs bind)
+mkDB bind = DB { db_bind = bind, db_fvs = bind_fvs bind }
 
 -- | Identify the free variables of a 'CoreBind'
 bind_fvs :: CoreBind -> VarSet
@@ -2526,17 +2617,18 @@ pair_fvs (bndr, rhs) = exprSomeFreeVars interesting rhs
 
 -- | Flatten a set of "dumped" 'DictBind's, and some other binding
 -- pairs, into a single recursive binding.
-recWithDumpedDicts :: [(Id,CoreExpr)] -> Bag DictBind ->DictBind
+recWithDumpedDicts :: [(Id,CoreExpr)] -> Bag DictBind -> DictBind
 recWithDumpedDicts pairs dbs
-  = (Rec bindings, fvs)
+  = DB { db_bind = Rec bindings, db_fvs = fvs }
   where
-    (bindings, fvs) = foldr add
-                               ([], emptyVarSet)
-                               (dbs `snocBag` mkDB (Rec pairs))
-    add (NonRec b r, fvs') (pairs, fvs) =
-      ((b,r) : pairs, fvs `unionVarSet` fvs')
-    add (Rec prs1,   fvs') (pairs, fvs) =
-      (prs1 ++ pairs, fvs `unionVarSet` fvs')
+    (bindings, fvs) = foldr add ([], emptyVarSet)
+                                (dbs `snocBag` mkDB (Rec pairs))
+    add (DB { db_bind = bind, db_fvs = fvs }) (prs_acc, fvs_acc)
+      = case bind of
+          NonRec b r -> ((b,r) : prs_acc, fvs')
+          Rec prs1   -> (prs1 ++ prs_acc, fvs')
+      where
+        fvs' = fvs_acc `unionVarSet` fvs
 
 snocDictBinds :: UsageDetails -> [DictBind] -> UsageDetails
 -- Add ud_binds to the tail end of the bindings in uds
@@ -2556,13 +2648,13 @@ wrapDictBinds :: Bag DictBind -> [CoreBind] -> [CoreBind]
 wrapDictBinds dbs binds
   = foldr add binds dbs
   where
-    add (bind,_) binds = bind : binds
+    add (DB { db_bind = bind }) binds = bind : binds
 
 wrapDictBindsE :: Bag DictBind -> CoreExpr -> CoreExpr
 wrapDictBindsE dbs expr
   = foldr add expr dbs
   where
-    add (bind,_) expr = Let bind expr
+    add (DB { db_bind = bind }) expr = Let bind expr
 
 ----------------------
 dumpUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind)
@@ -2624,9 +2716,10 @@ filterCalls (CIS fn call_bag) dbs
       --   (_,_,dump_set) = splitDictBinds dbs {fn}
       -- But this variant is shorter
 
-    go so_far (db,fvs) | fvs `intersectsVarSet` so_far
-                       = extendVarSetList so_far (bindersOf db)
-                       | otherwise = so_far
+    go so_far (DB { db_bind = bind, db_fvs = fvs })
+       | fvs `intersectsVarSet` so_far
+       = extendVarSetList so_far (bindersOf bind)
+       | otherwise = so_far
 
     ok_call (CI { ci_fvs = fvs }) = not (fvs `intersectsVarSet` dump_set)
 
@@ -2643,8 +2736,9 @@ splitDictBinds dbs bndr_set
                 -- Important that it's foldl' not foldr;
                 -- we're accumulating the set of dumped ids in dump_set
    where
-    split_db (free_dbs, dump_dbs, dump_idset) db@(bind, fvs)
-        | dump_idset `intersectsVarSet` fvs     -- Dump it
+    split_db (free_dbs, dump_dbs, dump_idset) db
+        | DB { db_bind = bind, db_fvs = fvs } <- db
+        , dump_idset `intersectsVarSet` fvs     -- Dump it
         = (free_dbs, dump_dbs `snocBag` db,
            extendVarSetList dump_idset (bindersOf bind))
 

compiler/GHC/CoreToIface.hs

@@ -34,13 +34,14 @@ module GHC.CoreToIface
     , toIfaceIdDetails
     , toIfaceIdInfo
     , toIfUnfolding
-    , toIfaceOneShot
     , toIfaceTickish
     , toIfaceBind
     , toIfaceAlt
     , toIfaceCon
     , toIfaceApp
     , toIfaceVar
+      -- * Other stuff
+    , toIfaceLFInfo
     ) where
 
 #include "HsVersions.h"
@@ -51,6 +52,7 @@ import GHC.Iface.Syntax
 import GHC.Core.DataCon
 import GHC.Types.Id
 import GHC.Types.Id.Info
+import GHC.StgToCmm.Types
 import GHC.Core
 import GHC.Core.TyCon hiding ( pprPromotionQuote )
 import GHC.Core.Coercion.Axiom
@@ -74,6 +76,8 @@ import GHC.Types.Demand ( isTopSig )
 import GHC.Types.Cpr ( topCprSig )
 
 import Data.Maybe ( catMaybes )
+import Data.Word
+import Data.Bits
 
 {- Note [Avoiding space leaks in toIface*]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -616,6 +620,43 @@ toIfaceVar v
   where name = idName v
 
 
+---------------------
+toIfaceLFInfo :: LambdaFormInfo -> IfaceLFInfo
+toIfaceLFInfo lfi = case lfi of
+    LFReEntrant _ _ arity _ _ ->
+      IfLFReEntrant arity
+    LFThunk _ _ updatable sfi mb_fun ->
+      IfLFThunk updatable (toIfaceStandardFormInfo sfi) mb_fun
+    LFCon dc ->
+      IfLFCon (dataConName dc)
+    LFUnknown mb_fun ->
+      IfLFUnknown mb_fun
+    LFUnlifted ->
+      IfLFUnlifted
+    LFLetNoEscape ->
+      panic "toIfaceLFInfo: LFLetNoEscape"
+
+toIfaceStandardFormInfo :: StandardFormInfo -> IfaceStandardFormInfo
+toIfaceStandardFormInfo NonStandardThunk = IfStandardFormInfo 1
+toIfaceStandardFormInfo sf =
+    IfStandardFormInfo $!
+      tag sf .|. encodeField (field sf)
+  where
+    tag SelectorThunk{} = 0
+    tag ApThunk{} = setBit 0 1
+    tag NonStandardThunk = panic "toIfaceStandardFormInfo: NonStandardThunk"
+
+    field (SelectorThunk n) = n
+    field (ApThunk n) = n
+    field NonStandardThunk = panic "toIfaceStandardFormInfo: NonStandardThunk"
+
+    encodeField n =
+      let wn = fromIntegral n :: Word
+          shifted = wn `unsafeShiftL` 2
+      in ASSERT(shifted > 0 && shifted < fromIntegral (maxBound :: Word16))
+         (fromIntegral shifted :: Word16)
+
+
 {- Note [Inlining and hs-boot files]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider this example (#10083, #12789):

compiler/GHC/Driver/Hooks.hs

@@ -55,6 +55,7 @@ import GHC.Stg.Syntax
 import Stream
 import GHC.Cmm
 import GHC.Hs.Extension
+import GHC.StgToCmm.Types (ModuleLFInfos)
 
 import Data.Maybe
 
@@ -109,7 +110,7 @@ data Hooks = Hooks
                                                           -> IO (Maybe HValue))
   , createIservProcessHook :: Maybe (CreateProcess -> IO ProcessHandle)
   , stgToCmmHook           :: Maybe (DynFlags -> Module -> [TyCon] -> CollectedCCs
-                                 -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup ())
+                                 -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup ModuleLFInfos)
   , cmmToRawCmmHook        :: forall a . Maybe (DynFlags -> Maybe Module -> Stream IO CmmGroupSRTs a
                                  -> IO (Stream IO RawCmmGroup a))
   }

compiler/GHC/Driver/Main.hs

@@ -132,7 +132,6 @@ import qualified GHC.StgToCmm as StgToCmm ( codeGen )
 import GHC.Types.CostCentre
 import GHC.Core.TyCon
 import GHC.Types.Name
-import GHC.Types.Name.Set
 import GHC.Cmm
 import GHC.Cmm.Parser         ( parseCmmFile )
 import GHC.Cmm.Info.Build
@@ -161,6 +160,7 @@ import Bag
 import Exception
 import qualified Stream
 import Stream (Stream)
+import GHC.StgToCmm.Types (CgInfos (..), ModuleLFInfos)
 
 import Util
 
@@ -175,6 +175,7 @@ import qualified Data.Set as S
 import Data.Set (Set)
 import Data.Functor
 import Control.DeepSeq (force)
+import Data.Bifunctor (first)
 
 import GHC.Iface.Ext.Ast    ( mkHieFile )
 import GHC.Iface.Ext.Types  ( getAsts, hie_asts, hie_module )
@@ -1391,7 +1392,7 @@ hscWriteIface dflags iface no_change mod_location = do
 
 -- | Compile to hard-code.
 hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath
-               -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], NameSet)
+               -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], CgInfos)
                -- ^ @Just f@ <=> _stub.c is f
 hscGenHardCode hsc_env cgguts location output_filename = do
         let CgGuts{ -- This is the last use of the ModGuts in a compilation.
@@ -1450,11 +1451,11 @@ hscGenHardCode hsc_env cgguts location output_filename = do
                   return a
                 rawcmms1 = Stream.mapM dump rawcmms0
 
-            (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, caf_infos)
+            (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cg_infos)
                 <- {-# SCC "codeOutput" #-}
                   codeOutput dflags this_mod output_filename location
                   foreign_stubs foreign_files dependencies rawcmms1
-            return (output_filename, stub_c_exists, foreign_fps, caf_infos)
+            return (output_filename, stub_c_exists, foreign_fps, cg_infos)
 
 
 hscInteractive :: HscEnv
@@ -1548,7 +1549,7 @@ doCodeGen   :: HscEnv -> Module -> [TyCon]
             -> CollectedCCs
             -> [StgTopBinding]
             -> HpcInfo
-            -> IO (Stream IO CmmGroupSRTs NameSet)
+            -> IO (Stream IO CmmGroupSRTs CgInfos)
          -- Note we produce a 'Stream' of CmmGroups, so that the
          -- backend can be run incrementally.  Otherwise it generates all
          -- the C-- up front, which has a significant space cost.
@@ -1560,7 +1561,7 @@ doCodeGen hsc_env this_mod data_tycons
 
     dumpIfSet_dyn dflags Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings stg_binds_w_fvs)
 
-    let cmm_stream :: Stream IO CmmGroup ()
+    let cmm_stream :: Stream IO CmmGroup ModuleLFInfos
         -- See Note [Forcing of stg_binds]
         cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-}
             lookupHook stgToCmmHook StgToCmm.codeGen dflags dflags this_mod data_tycons
@@ -1579,10 +1580,14 @@ doCodeGen hsc_env this_mod data_tycons
 
         ppr_stream1 = Stream.mapM dump1 cmm_stream
 
-        pipeline_stream =
-          {-# SCC "cmmPipeline" #-}
-          Stream.mapAccumL (cmmPipeline hsc_env) (emptySRT this_mod) ppr_stream1
-            <&> (srtMapNonCAFs . moduleSRTMap)
+        pipeline_stream :: Stream IO CmmGroupSRTs CgInfos
+        pipeline_stream = do
+          (non_cafs, lf_infos) <-
+            {-# SCC "cmmPipeline" #-}
+            Stream.mapAccumL_ (cmmPipeline hsc_env) (emptySRT this_mod) ppr_stream1
+              <&> first (srtMapNonCAFs . moduleSRTMap)
+
+          return CgInfos{ cgNonCafs = non_cafs, cgLFInfos = lf_infos }
 
         dump2 a = do
           unless (null a) $

compiler/GHC/Driver/Pipeline.hs

@@ -70,7 +70,7 @@ import Ar
 import Bag              ( unitBag )
 import FastString       ( mkFastString )
 import GHC.Iface.Make   ( mkFullIface )
-import UpdateCafInfos   ( updateModDetailsCafInfos )
+import UpdateIdInfos    ( updateModDetailsIdInfos )
 
 import Exception
 import System.Directory
@@ -1193,12 +1193,12 @@ runPhase (HscOut src_flavour mod_name result) _ dflags = do
 
                     PipeState{hsc_env=hsc_env'} <- getPipeState
 
-                    (outputFilename, mStub, foreign_files, caf_infos) <- liftIO $
+                    (outputFilename, mStub, foreign_files, cg_infos) <- liftIO $
                       hscGenHardCode hsc_env' cgguts mod_location output_fn
 
-                    final_iface <- liftIO (mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface (Just caf_infos))
-                    let final_mod_details = {-# SCC updateModDetailsCafInfos #-}
-                                            updateModDetailsCafInfos iface_dflags caf_infos mod_details
+                    final_iface <- liftIO (mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface (Just cg_infos))
+                    let final_mod_details = {-# SCC updateModDetailsIdInfos #-}
+                                            updateModDetailsIdInfos iface_dflags cg_infos mod_details
                     setIface final_iface final_mod_details
 
                     -- See Note [Writing interface files]

compiler/GHC/Iface/Make.hs

@@ -38,6 +38,7 @@ import GHC.Core.Coercion.Axiom
 import GHC.Core.ConLike
 import GHC.Core.DataCon
 import GHC.Core.Type
+import GHC.StgToCmm.Types (CgInfos (..))
 import TcType
 import GHC.Core.InstEnv
 import GHC.Core.FamInstEnv
@@ -100,13 +101,13 @@ mkPartialIface hsc_env mod_details
 
 -- | Fully instantiate a interface
 -- Adds fingerprints and potentially code generator produced information.
-mkFullIface :: HscEnv -> PartialModIface -> Maybe NameSet -> IO ModIface
-mkFullIface hsc_env partial_iface mb_non_cafs = do
+mkFullIface :: HscEnv -> PartialModIface -> Maybe CgInfos -> IO ModIface
+mkFullIface hsc_env partial_iface mb_cg_infos = do
     let decls
           | gopt Opt_OmitInterfacePragmas (hsc_dflags hsc_env)
           = mi_decls partial_iface
           | otherwise
-          = updateDeclCafInfos (mi_decls partial_iface) mb_non_cafs
+          = updateDecl (mi_decls partial_iface) mb_cg_infos
 
     full_iface <-
       {-# SCC "addFingerprints" #-}
@@ -117,15 +118,23 @@ mkFullIface hsc_env partial_iface mb_non_cafs = do
 
     return full_iface
 
-updateDeclCafInfos :: [IfaceDecl] -> Maybe NameSet -> [IfaceDecl]
-updateDeclCafInfos decls Nothing = decls
-updateDeclCafInfos decls (Just non_cafs) = map update_decl decls
+updateDecl :: [IfaceDecl] -> Maybe CgInfos -> [IfaceDecl]
+updateDecl decls Nothing = decls
+updateDecl decls (Just CgInfos{ cgNonCafs = non_cafs, cgLFInfos = lf_infos }) = map update_decl decls
   where
+    update_decl (IfaceId nm ty details infos)
+      | let not_caffy = elemNameSet nm non_cafs
+      , let mb_lf_info = lookupNameEnv lf_infos nm
+      , WARN( isNothing mb_lf_info, text "Name without LFInfo:" <+> ppr nm ) True
+        -- Only allocate a new IfaceId if we're going to update the infos
+      , isJust mb_lf_info || not_caffy
+      = IfaceId nm ty details $
+          (if not_caffy then (HsNoCafRefs :) else id)
+          (case mb_lf_info of
+             Nothing -> infos
+             Just lf_info -> HsLFInfo (toIfaceLFInfo lf_info) : infos)
+
     update_decl decl
-      | IfaceId nm ty details infos <- decl
-      , elemNameSet nm non_cafs
-      = IfaceId nm ty details (HsNoCafRefs : infos)
-      | otherwise
       = decl
 
 -- | Make an interface from the results of typechecking only.  Useful

compiler/GHC/Iface/Syntax.hs

@@ -22,6 +22,8 @@ module GHC.Iface.Syntax (
         IfaceAxBranch(..),
         IfaceTyConParent(..),
         IfaceCompleteMatch(..),
+        IfaceLFInfo(..),
+        IfaceStandardFormInfo(..),
 
         -- * Binding names
         IfaceTopBndr,
@@ -30,6 +32,7 @@ module GHC.Iface.Syntax (
         -- Misc
         ifaceDeclImplicitBndrs, visibleIfConDecls,
         ifaceDeclFingerprints,
+        tcStandardFormInfo,
 
         -- Free Names
         freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst,
@@ -72,10 +75,13 @@ import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..))
 import GHC.Utils.Lexeme (isLexSym)
 import TysWiredIn ( constraintKindTyConName )
 import Util (seqList)
+import GHC.StgToCmm.Types
 
 import Control.Monad
 import System.IO.Unsafe
 import Control.DeepSeq
+import Data.Word
+import Data.Bits
 
 infixl 3 &&&
 
@@ -114,7 +120,8 @@ data IfaceDecl
   = IfaceId { ifName      :: IfaceTopBndr,
               ifType      :: IfaceType,
               ifIdDetails :: IfaceIdDetails,
-              ifIdInfo    :: IfaceIdInfo }
+              ifIdInfo    :: IfaceIdInfo
+              }
 
   | IfaceData { ifName       :: IfaceTopBndr,   -- Type constructor
                 ifBinders    :: [IfaceTyConBinder],
@@ -348,6 +355,7 @@ data IfaceInfoItem
                     IfaceUnfolding   -- See Note [Expose recursive functions]
   | HsNoCafRefs
   | HsLevity                         -- Present <=> never levity polymorphic
+  | HsLFInfo        IfaceLFInfo
 
 -- NB: Specialisations and rules come in separately and are
 -- only later attached to the Id.  Partial reason: some are orphans.
@@ -379,6 +387,74 @@ data IfaceIdDetails
   | IfRecSelId (Either IfaceTyCon IfaceDecl) Bool
   | IfDFunId
 
+-- | Iface type for LambdaFormInfo. Fields not relevant for imported Ids are
+-- omitted in this type.
+data IfaceLFInfo
+  = IfLFReEntrant !RepArity
+  | IfLFThunk !Bool !IfaceStandardFormInfo !Bool
+  | IfLFCon !Name
+  | IfLFUnknown !Bool
+  | IfLFUnlifted
+
+tcStandardFormInfo :: IfaceStandardFormInfo -> StandardFormInfo
+tcStandardFormInfo (IfStandardFormInfo w)
+  | testBit w 0 = NonStandardThunk
+  | otherwise = con field
+  where
+    field = fromIntegral (w `unsafeShiftR` 2)
+    con
+      | testBit w 1 = ApThunk
+      | otherwise = SelectorThunk
+
+instance Outputable IfaceLFInfo where
+    ppr (IfLFReEntrant arity) =
+      text "LFReEntrant" <+> ppr arity
+
+    ppr (IfLFThunk updatable sfi mb_fun) =
+      text "LFThunk" <+> ppr (updatable, tcStandardFormInfo sfi, mb_fun)
+
+    ppr (IfLFCon con) =
+      text "LFCon" <> brackets (ppr con)
+
+    ppr IfLFUnlifted =
+      text "LFUnlifted"
+
+    ppr (IfLFUnknown fun_flag) =
+      text "LFUnknown" <+> ppr fun_flag
+
+newtype IfaceStandardFormInfo = IfStandardFormInfo Word16
+
+instance Binary IfaceStandardFormInfo where
+    put_ bh (IfStandardFormInfo w) = put_ bh (w :: Word16)
+    get bh = IfStandardFormInfo <$> (get bh :: IO Word16)
+
+instance Binary IfaceLFInfo where
+    put_ bh (IfLFReEntrant arity) = do
+        putByte bh 0
+        put_ bh arity
+    put_ bh (IfLFThunk updatable sfi mb_fun) = do
+        putByte bh 1
+        put_ bh updatable
+        put_ bh sfi
+        put_ bh mb_fun
+    put_ bh (IfLFCon con_name) = do
+        putByte bh 2
+        put_ bh con_name
+    put_ bh (IfLFUnknown fun_flag) = do
+        putByte bh 3
+        put_ bh fun_flag
+    put_ bh IfLFUnlifted =
+        putByte bh 4
+    get bh = do
+        tag <- getByte bh
+        case tag of
+            0 -> IfLFReEntrant <$> get bh
+            1 -> IfLFThunk <$> get bh <*> get bh <*> get bh
+            2 -> IfLFCon <$> get bh
+            3 -> IfLFUnknown <$> get bh
+            4 -> pure IfLFUnlifted
+            _ -> panic "Invalid byte"
+
 {-
 Note [Versioning of instances]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1393,6 +1469,7 @@ instance Outputable IfaceInfoItem where
   ppr (HsCpr cpr)           = text "CPR:" <+> ppr cpr
   ppr HsNoCafRefs           = text "HasNoCafRefs"
   ppr HsLevity              = text "Never levity-polymorphic"
+  ppr (HsLFInfo lf_info)    = text "LambdaFormInfo:" <+> ppr lf_info
 
 instance Outputable IfaceJoinInfo where
   ppr IfaceNotJoinPoint   = empty
@@ -1853,7 +1930,7 @@ instance Binary IfaceDecl where
     get bh = do
         h <- getByte bh
         case h of
-            0 -> do name    <- get bh
+            0 -> do name <- get bh
                     ~(ty, details, idinfo) <- lazyGet bh
                     -- See Note [Lazy deserialization of IfaceId]
                     return (IfaceId name ty details idinfo)
@@ -2153,6 +2230,8 @@ instance Binary IfaceInfoItem where
     put_ bh HsNoCafRefs           = putByte bh 4
     put_ bh HsLevity              = putByte bh 5
     put_ bh (HsCpr cpr)           = putByte bh 6 >> put_ bh cpr
+    put_ bh (HsLFInfo lf_info)    = putByte bh 7 >> put_ bh lf_info
+
     get bh = do
         h <- getByte bh
         case h of
@@ -2164,7 +2243,8 @@ instance Binary IfaceInfoItem where
             3 -> liftM HsInline $ get bh
             4 -> return HsNoCafRefs
             5 -> return HsLevity
-            _ -> HsCpr <$> get bh
+            6 -> HsCpr <$> get bh
+            _ -> HsLFInfo <$> get bh
 
 instance Binary IfaceUnfolding where
     put_ bh (IfCoreUnfold s e) = do
@@ -2495,6 +2575,7 @@ instance NFData IfaceInfoItem where
     HsNoCafRefs -> ()
     HsLevity -> ()
     HsCpr cpr -> cpr `seq` ()
+    HsLFInfo lf_info -> lf_info `seq` () -- TODO: seq further?
 
 instance NFData IfaceUnfolding where
   rnf = \case

compiler/GHC/Iface/Type.hs

@@ -122,6 +122,9 @@ data IfaceOneShot    -- See Note [Preserve OneShotInfo] in CoreTicy
   = IfaceNoOneShot   -- and Note [The oneShot function] in GHC.Types.Id.Make
   | IfaceOneShot
 
+instance Outputable IfaceOneShot where
+  ppr IfaceNoOneShot = text "NoOneShotInfo"
+  ppr IfaceOneShot = text "OneShot"
 
 {-
 %************************************************************************

compiler/GHC/IfaceToCore.hs

@@ -19,7 +19,8 @@ module GHC.IfaceToCore (
         tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
         tcIfaceAnnotations, tcIfaceCompleteSigs,
         tcIfaceExpr,    -- Desired by HERMIT (#7683)
-        tcIfaceGlobal
+        tcIfaceGlobal,
+        tcIfaceOneShot
  ) where
 
 #include "HsVersions.h"
@@ -30,6 +31,7 @@ import TcTypeNats(typeNatCoAxiomRules)
 import GHC.Iface.Syntax
 import GHC.Iface.Load
 import GHC.Iface.Env
+import GHC.StgToCmm.Types
 import BuildTyCl
 import TcRnMonad
 import TcType
@@ -1464,8 +1466,7 @@ tcIdInfo ignore_prags toplvl name ty info = do
     let init_info | if_boot lcl_env = vanillaIdInfo `setUnfoldingInfo` BootUnfolding
                   | otherwise       = vanillaIdInfo
 
-    let needed = needed_prags info
-    foldlM tcPrag init_info needed
+    foldlM tcPrag init_info (needed_prags info)
   where
     needed_prags :: [IfaceInfoItem] -> [IfaceInfoItem]
     needed_prags items
@@ -1485,6 +1486,9 @@ tcIdInfo ignore_prags toplvl name ty info = do
     tcPrag info (HsCpr cpr)        = return (info `setCprInfo` cpr)
     tcPrag info (HsInline prag)    = return (info `setInlinePragInfo` prag)
     tcPrag info HsLevity           = return (info `setNeverLevPoly` ty)
+    tcPrag info (HsLFInfo lf_info) = do
+      lf_info <- tcLFInfo lf_info
+      return (info `setLFInfo` lf_info)
 
         -- The next two are lazy, so they don't transitively suck stuff in
     tcPrag info (HsUnfold lb if_unf)
@@ -1497,6 +1501,23 @@ tcJoinInfo :: IfaceJoinInfo -> Maybe JoinArity
 tcJoinInfo (IfaceJoinPoint ar) = Just ar
 tcJoinInfo IfaceNotJoinPoint   = Nothing
 
+tcLFInfo :: IfaceLFInfo -> IfL LambdaFormInfo
+tcLFInfo lfi = case lfi of
+    IfLFReEntrant rep_arity ->
+      return (LFReEntrant TopLevel NoOneShotInfo rep_arity True ArgUnknown)
+
+    IfLFThunk updatable sfi mb_fun ->
+      return (LFThunk TopLevel True updatable (tcStandardFormInfo sfi) mb_fun)
+
+    IfLFUnlifted ->
+      return LFUnlifted
+
+    IfLFCon con_name ->
+      LFCon <$!> tcIfaceDataCon con_name
+
+    IfLFUnknown fun_flag ->
+      return (LFUnknown fun_flag)
+
 tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
 tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr)
   = do  { dflags <- getDynFlags
@@ -1583,6 +1604,10 @@ tcPragExpr is_compulsory toplvl name expr
       -- It's OK to use nonDetEltsUFM here because we immediately forget
       -- the ordering by creating a set
 
+tcIfaceOneShot :: IfaceOneShot -> OneShotInfo
+tcIfaceOneShot IfaceNoOneShot = NoOneShotInfo
+tcIfaceOneShot IfaceOneShot = OneShotLam
+
 {-
 ************************************************************************
 *                                                                      *

compiler/GHC/Runtime/Heap/Layout.hs

@@ -51,6 +51,7 @@ import GHC.Driver.Session
 import Outputable
 import GHC.Platform
 import FastString
+import GHC.StgToCmm.Types
 
 import Data.Word
 import Data.Bits
@@ -64,9 +65,6 @@ import Data.ByteString (ByteString)
 ************************************************************************
 -}
 
--- | Word offset, or word count
-type WordOff = Int
-
 -- | Byte offset, or byte count
 type ByteOff = Int
 
@@ -196,29 +194,6 @@ type ConstrDescription = ByteString -- result of dataConIdentity
 type FunArity          = Int
 type SelectorOffset    = Int
 
--------------------------
--- We represent liveness bitmaps as a Bitmap (whose internal
--- representation really is a bitmap).  These are pinned onto case return
--- vectors to indicate the state of the stack for the garbage collector.
---
--- In the compiled program, liveness bitmaps that fit inside a single
--- word (StgWord) are stored as a single word, while larger bitmaps are
--- stored as a pointer to an array of words.
-
-type Liveness = [Bool]   -- One Bool per word; True  <=> non-ptr or dead
-                         --                    False <=> ptr
-
--------------------------
--- An ArgDescr describes the argument pattern of a function
-
-data ArgDescr
-  = ArgSpec             -- Fits one of the standard patterns
-        !Int            -- RTS type identifier ARG_P, ARG_N, ...
-
-  | ArgGen              -- General case
-        Liveness        -- Details about the arguments
-
-
 -----------------------------------------------------------------------------
 -- Construction
 
@@ -545,10 +520,6 @@ instance Outputable SMRep where
 
    ppr (RTSRep ty rep) = text "tag:" <> ppr ty <+> ppr rep
 
-instance Outputable ArgDescr where
-  ppr (ArgSpec n) = text "ArgSpec" <+> ppr n
-  ppr (ArgGen ls) = text "ArgGen" <+> ppr ls
-
 pprTypeInfo :: ClosureTypeInfo -> SDoc
 pprTypeInfo (Constr tag descr)
   = text "Con" <+>

compiler/GHC/StgToCmm.hs

 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE BangPatterns #-}
 
 -----------------------------------------------------------------------------
 --
@@ -25,6 +26,7 @@ import GHC.StgToCmm.Utils
 import GHC.StgToCmm.Closure
 import GHC.StgToCmm.Hpc
 import GHC.StgToCmm.Ticky
+import GHC.StgToCmm.Types (ModuleLFInfos)
 
 import GHC.Cmm
 import GHC.Cmm.Utils
@@ -47,6 +49,8 @@ import Stream
 import GHC.Types.Basic
 import GHC.Types.Var.Set ( isEmptyDVarSet )
 import FileCleanup
+import GHC.Types.Unique.FM
+import GHC.Types.Name.Env
 
 import OrdList
 import GHC.Cmm.Graph
@@ -63,7 +67,8 @@ codeGen :: DynFlags
         -> CollectedCCs                -- (Local/global) cost-centres needing declaring/registering.
         -> [CgStgTopBinding]           -- Bindings to convert
         -> HpcInfo
-        -> Stream IO CmmGroup ()       -- Output as a stream, so codegen can
+        -> Stream IO CmmGroup ModuleLFInfos
+                                       -- Output as a stream, so codegen can
                                        -- be interleaved with output
 
 codeGen dflags this_mod data_tycons
@@ -105,6 +110,18 @@ codeGen dflags this_mod data_tycons
                  mapM_ (cg . cgDataCon) (tyConDataCons tycon)
 
         ; mapM_ do_tycon data_tycons
+
+        ; cg_id_infos <- cgs_binds <$> liftIO (readIORef cgref)
+
+        ; let extractInfo info = (name, lf)
+                where
+                  !id = cg_id info
+                  !name = idName id
+                  !lf = cg_lf info
+
+        ; let !generatedInfo = mkNameEnv (Prelude.map extractInfo (eltsUFM cg_id_infos))
+
+        ; return generatedInfo
         }
 
 ---------------------------------------------------------------

compiler/GHC/StgToCmm/Closure.hs

@@ -70,6 +70,7 @@ import GHC.Stg.Syntax
 import GHC.Runtime.Heap.Layout
 import GHC.Cmm
 import GHC.Cmm.Ppr.Expr() -- For Outputable instances
+import GHC.StgToCmm.Types
 
 import GHC.Types.CostCentre
 import GHC.Cmm.BlockId
@@ -188,77 +189,6 @@ addArgReps = map (\arg -> let arg' = fromNonVoid arg
 argPrimRep :: StgArg -> PrimRep
 argPrimRep arg = typePrimRep1 (stgArgType arg)
 
-
------------------------------------------------------------------------------
---                LambdaFormInfo
------------------------------------------------------------------------------
-
--- Information about an identifier, from the code generator's point of
--- view.  Every identifier is bound to a LambdaFormInfo in the
--- environment, which gives the code generator enough info to be able to
--- tail call or return that identifier.
-
-data LambdaFormInfo
-  = LFReEntrant         -- Reentrant closure (a function)
-        TopLevelFlag    -- True if top level
-        OneShotInfo
-        !RepArity       -- Arity. Invariant: always > 0
-        !Bool           -- True <=> no fvs
-        ArgDescr        -- Argument descriptor (should really be in ClosureInfo)
-
-  | LFThunk             -- Thunk (zero arity)
-        TopLevelFlag
-        !Bool           -- True <=> no free vars
-        !Bool           -- True <=> updatable (i.e., *not* single-entry)
-        StandardFormInfo
-        !Bool           -- True <=> *might* be a function type
-
-  | LFCon               -- A saturated constructor application
-        DataCon         -- The constructor
-
-  | LFUnknown           -- Used for function arguments and imported things.
-                        -- We know nothing about this closure.
-                        -- Treat like updatable "LFThunk"...
-                        -- Imported things which we *do* know something about use
-                        -- one of the other LF constructors (eg LFReEntrant for
-                        -- known functions)
-        !Bool           -- True <=> *might* be a function type
-                        --      The False case is good when we want to enter it,
-                        --        because then we know the entry code will do
-                        --        For a function, the entry code is the fast entry point
-
-  | LFUnlifted          -- A value of unboxed type;
-                        -- always a value, needs evaluation
-
-  | LFLetNoEscape       -- See LetNoEscape module for precise description
-
-
--------------------------
--- StandardFormInfo tells whether this thunk has one of
--- a small number of standard forms
-
-data StandardFormInfo
-  = NonStandardThunk
-        -- The usual case: not of the standard forms
-
-  | SelectorThunk
-        -- A SelectorThunk is of form
-        --      case x of
-        --           con a1,..,an -> ak
-        -- and the constructor is from a single-constr type.
-       WordOff          -- 0-origin offset of ak within the "goods" of
-                        -- constructor (Recall that the a1,...,an may be laid
-                        -- out in the heap in a non-obvious order.)
-
-  | ApThunk
-        -- An ApThunk is of form
-        --        x1 ... xn
-        -- The code for the thunk just pushes x2..xn on the stack and enters x1.
-        -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled
-        -- in the RTS to save space.
-        RepArity                -- Arity, n
-
-
 ------------------------------------------------------
 --                Building LambdaFormInfo
 ------------------------------------------------------
@@ -327,18 +257,22 @@ mkApLFInfo id upd_flag arity
 
 -------------
 mkLFImported :: Id -> LambdaFormInfo
-mkLFImported id
-  | Just con <- isDataConWorkId_maybe id
-  , isNullaryRepDataCon con
-  = LFCon con   -- An imported nullary constructor
-                -- We assume that the constructor is evaluated so that
-                -- the id really does point directly to the constructor
-
-  | arity > 0
-  = LFReEntrant TopLevel noOneShotInfo arity True (panic "arg_descr")
-
-  | otherwise
-  = mkLFArgument id -- Not sure of exact arity
+mkLFImported id =
+    case idLFInfo_maybe id of
+      Just lf_info ->
+        lf_info
+      Nothing
+        | Just con <- isDataConWorkId_maybe id
+        , isNullaryRepDataCon con
+        -> LFCon con   -- An imported nullary constructor
+                       -- We assume that the constructor is evaluated so that
+                       -- the id really does point directly to the constructor
+
+        | arity > 0
+        -> LFReEntrant TopLevel noOneShotInfo arity True ArgUnknown
+
+        | otherwise
+        -> mkLFArgument id -- Not sure of exact arity
   where
     arity = idFunRepArity id
 

compiler/GHC/StgToCmm/Types.hs

+{-# LANGUAGE CPP #-}
+
+module GHC.StgToCmm.Types
+  ( CgInfos (..)
+  , LambdaFormInfo (..)
+  , ModuleLFInfos
+  , Liveness
+  , ArgDescr (..)
+  , StandardFormInfo (..)
+  , WordOff
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import GHC.Types.Basic
+import GHC.Core.DataCon
+import GHC.Types.Name.Env
+import GHC.Types.Name.Set
+import Outputable
+
+-- | Codegen-generated Id infos, to be passed to downstream via interfaces.
+--
+-- This stuff is for optimization purposes only, they're not compulsory.
+--
+-- * When CafInfo of an imported Id is not known it's safe to treat it as CAFFY.
+-- * When LambdaFormInfo of an imported Id is not known it's safe to treat it as
+--   `LFUnknown True` (which just says "it could be anything" and we do slow
+--   entry).
+--
+data CgInfos = CgInfos
+  { cgNonCafs :: !NameSet
+      -- ^ Exported Non-CAFFY closures in the current module. Everything else is
+      -- either not exported of CAFFY.
+  , cgLFInfos :: !ModuleLFInfos
+      -- ^ LambdaFormInfos of exported closures in the current module.
+  }
+
+--------------------------------------------------------------------------------
+--                LambdaFormInfo
+--------------------------------------------------------------------------------
+
+-- | Maps names in the current module to their LambdaFormInfos
+type ModuleLFInfos = NameEnv LambdaFormInfo
+
+-- | Information about an identifier, from the code generator's point of view.
+-- Every identifier is bound to a LambdaFormInfo in the environment, which gives
+-- the code generator enough info to be able to tail call or return that
+-- identifier.
+data LambdaFormInfo
+  = LFReEntrant         -- Reentrant closure (a function)
+        !TopLevelFlag   -- True if top level
+        !OneShotInfo
+        !RepArity       -- Arity. Invariant: always > 0
+        !Bool           -- True <=> no fvs
+        !ArgDescr       -- Argument descriptor (should really be in ClosureInfo)
+
+  | LFThunk             -- Thunk (zero arity)
+        !TopLevelFlag
+        !Bool           -- True <=> no free vars
+        !Bool           -- True <=> updatable (i.e., *not* single-entry)
+        !StandardFormInfo
+        !Bool           -- True <=> *might* be a function type
+
+  | LFCon               -- A saturated constructor application
+        !DataCon        -- The constructor
+
+  | LFUnknown           -- Used for function arguments and imported things.
+                        -- We know nothing about this closure.
+                        -- Treat like updatable "LFThunk"...
+                        -- Imported things which we *do* know something about use
+                        -- one of the other LF constructors (eg LFReEntrant for
+                        -- known functions)
+        !Bool           -- True <=> *might* be a function type
+                        --      The False case is good when we want to enter it,
+                        --        because then we know the entry code will do
+                        --        For a function, the entry code is the fast entry point
+
+  | LFUnlifted          -- A value of unboxed type;
+                        -- always a value, needs evaluation
+
+  | LFLetNoEscape       -- See LetNoEscape module for precise description
+
+instance Outputable LambdaFormInfo where
+    ppr (LFReEntrant top oneshot rep fvs argdesc) =
+        text "LFReEntrant" <> brackets (ppr top <+> ppr oneshot <+>
+                                        ppr rep <+> pprFvs fvs <+> ppr argdesc)
+    ppr (LFThunk top hasfv updateable sfi m_function) =
+        text "LFThunk" <> brackets (ppr top <+> pprFvs hasfv <+> pprUpdateable updateable <+>
+                                    ppr sfi <+> pprFuncFlag m_function)
+    ppr (LFCon con) = text "LFCon" <> brackets (ppr con)
+    ppr (LFUnknown m_func) = text "LFUnknown" <> brackets (pprFuncFlag m_func)
+    ppr LFUnlifted = text "LFUnlifted"
+    ppr LFLetNoEscape = text "LFLetNoEscape"
+
+pprFvs :: Bool -> SDoc
+pprFvs True = text "no-fvs"
+pprFvs False = text "fvs"
+
+pprFuncFlag :: Bool -> SDoc
+pprFuncFlag True = text "mFunc"
+pprFuncFlag False = text "value"
+
+pprUpdateable :: Bool -> SDoc
+pprUpdateable True = text "updateable"
+pprUpdateable False = text "oneshot"
+
+--------------------------------------------------------------------------------
+
+-- | We represent liveness bitmaps as a Bitmap (whose internal representation
+-- really is a bitmap).  These are pinned onto case return vectors to indicate
+-- the state of the stack for the garbage collector.
+--
+-- In the compiled program, liveness bitmaps that fit inside a single word
+-- (StgWord) are stored as a single word, while larger bitmaps are stored as a
+-- pointer to an array of words.
+
+type Liveness = [Bool]   -- One Bool per word; True  <=> non-ptr or dead
+                         --                    False <=> ptr
+
+--------------------------------------------------------------------------------
+-- | An ArgDescr describes the argument pattern of a function
+
+data ArgDescr
+  = ArgSpec             -- Fits one of the standard patterns
+        !Int            -- RTS type identifier ARG_P, ARG_N, ...
+
+  | ArgGen              -- General case
+        Liveness        -- Details about the arguments
+
+  | ArgUnknown          -- For imported binds.
+                        -- Invariant: Never Unknown for binds of the module
+                        -- we are compiling.
+  deriving (Eq)
+
+instance Outputable ArgDescr where
+  ppr (ArgSpec n) = text "ArgSpec" <+> ppr n
+  ppr (ArgGen ls) = text "ArgGen" <+> ppr ls
+  ppr ArgUnknown = text "ArgUnknown"
+
+--------------------------------------------------------------------------------
+-- | StandardFormInfo tells whether this thunk has one of a small number of
+-- standard forms
+
+data StandardFormInfo
+  = NonStandardThunk
+        -- The usual case: not of the standard forms
+
+  | SelectorThunk
+        -- A SelectorThunk is of form
+        --      case x of
+        --           con a1,..,an -> ak
+        -- and the constructor is from a single-constr type.
+       !WordOff         -- 0-origin offset of ak within the "goods" of
+                        -- constructor (Recall that the a1,...,an may be laid
+                        -- out in the heap in a non-obvious order.)
+
+  | ApThunk
+        -- An ApThunk is of form
+        --        x1 ... xn
+        -- The code for the thunk just pushes x2..xn on the stack and enters x1.
+        -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled
+        -- in the RTS to save space.
+        !RepArity       -- Arity, n
+  deriving (Eq)
+
+-- | Word offset, or word count
+type WordOff = Int
+
+instance Outputable StandardFormInfo where
+  ppr NonStandardThunk = text "RegThunk"
+  ppr (SelectorThunk w) = text "SelThunk:" <> ppr w
+  ppr (ApThunk n) = text "ApThunk:" <> ppr n

compiler/GHC/Types/Id.hs

@@ -92,7 +92,7 @@ module GHC.Types.Id (
         idCallArity, idFunRepArity,
         idUnfolding, realIdUnfolding,
         idSpecialisation, idCoreRules, idHasRules,
-        idCafInfo,
+        idCafInfo, idLFInfo_maybe,
         idOneShotInfo, idStateHackOneShotInfo,
         idOccInfo,
         isNeverLevPolyId,
@@ -105,6 +105,7 @@ module GHC.Types.Id (
         setIdSpecialisation,
         setIdCafInfo,
         setIdOccInfo, zapIdOccInfo,
+        setIdLFInfo,
 
         setIdDemandInfo,
         setIdStrictness,
@@ -731,6 +732,15 @@ idCafInfo id = cafInfo (idInfo id)
 setIdCafInfo :: Id -> CafInfo -> Id
 setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id
 
+        ---------------------------------
+        -- Lambda form info
+
+idLFInfo_maybe :: Id -> Maybe LambdaFormInfo
+idLFInfo_maybe = lfInfo . idInfo
+
+setIdLFInfo :: Id -> LambdaFormInfo -> Id
+setIdLFInfo id lf = modifyIdInfo (`setLFInfo` lf) id
+
         ---------------------------------
         -- Occurrence INFO
 idOccInfo :: Id -> OccInfo

compiler/GHC/Types/Id/Info.hs

@@ -74,6 +74,10 @@ module GHC.Types.Id.Info (
         ppCafInfo, mayHaveCafRefs,
         cafInfo, setCafInfo,
 
+        -- ** The LambdaFormInfo type
+        LambdaFormInfo(..),
+        lfInfo, setLFInfo,
+
         -- ** Tick-box Info
         TickBoxOp(..), TickBoxId,
 
@@ -105,6 +109,8 @@ import GHC.Types.Demand
 import GHC.Types.Cpr
 import Util
 
+import GHC.StgToCmm.Types (LambdaFormInfo (..))
+
 -- infixl so you can say (id `set` a `set` b)
 infixl  1 `setRuleInfo`,
           `setArityInfo`,
@@ -251,7 +257,7 @@ data IdInfo
         -- See Note [Specialisations and RULES in IdInfo]
         unfoldingInfo   :: Unfolding,
         -- ^ The 'Id's unfolding
-        cafInfo         :: CafInfo,
+        cafInfo         :: !CafInfo,
         -- ^ 'Id' CAF info
         oneShotInfo     :: OneShotInfo,
         -- ^ Info about a lambda-bound variable, if the 'Id' is one
@@ -271,8 +277,9 @@ data IdInfo
         -- ^ How this is called. This is the number of arguments to which a
         -- binding can be eta-expanded without losing any sharing.
         -- n <=> all calls have at least n arguments
-        levityInfo      :: LevityInfo
+        levityInfo      :: LevityInfo,
         -- ^ when applied, will this Id ever have a levity-polymorphic type?
+        lfInfo          :: !(Maybe LambdaFormInfo)
     }
 
 -- Setters
@@ -295,13 +302,18 @@ setUnfoldingInfo info uf
 
 setArityInfo :: IdInfo -> ArityInfo -> IdInfo
 setArityInfo      info ar  = info { arityInfo = ar  }
+
 setCallArityInfo :: IdInfo -> ArityInfo -> IdInfo
 setCallArityInfo info ar  = info { callArityInfo = ar  }
+
 setCafInfo :: IdInfo -> CafInfo -> IdInfo
-setCafInfo        info caf = info { cafInfo = caf }
+setCafInfo info caf = info { cafInfo = caf }
+
+setLFInfo :: IdInfo -> LambdaFormInfo -> IdInfo
+setLFInfo info lf = info { lfInfo = Just lf }
 
 setOneShotInfo :: IdInfo -> OneShotInfo -> IdInfo
-setOneShotInfo      info lb = {-lb `seq`-} info { oneShotInfo = lb }
+setOneShotInfo info lb = {-lb `seq`-} info { oneShotInfo = lb }
 
 setDemandInfo :: IdInfo -> Demand -> IdInfo
 setDemandInfo info dd = dd `seq` info { demandInfo = dd }
@@ -327,7 +339,8 @@ vanillaIdInfo
             strictnessInfo      = nopSig,
             cprInfo             = topCprSig,
             callArityInfo       = unknownArity,
-            levityInfo          = NoLevityInfo
+            levityInfo          = NoLevityInfo,
+            lfInfo              = Nothing
            }
 
 -- | More informative 'IdInfo' we can use when we know the 'Id' has no CAF references

compiler/ghc.cabal.in

@@ -226,7 +226,7 @@ Library
         GHC.Types.SrcLoc
         GHC.Types.Unique.Supply
         GHC.Types.Unique
-        UpdateCafInfos
+        UpdateIdInfos
         GHC.Types.Var
         GHC.Types.Var.Env
         GHC.Types.Var.Set
@@ -295,6 +295,7 @@ Library
         GHC.StgToCmm.Ticky
         GHC.StgToCmm.Utils
         GHC.StgToCmm.ExtCode
+        GHC.StgToCmm.Types
         GHC.Runtime.Heap.Layout
         GHC.Core.Arity
         GHC.Core.FVs

compiler/main/UpdateCafInfos.hs → compiler/main/UpdateIdInfos.hs

 {-# LANGUAGE CPP, BangPatterns, Strict, RecordWildCards #-}
 
-module UpdateCafInfos
-  ( updateModDetailsCafInfos
+module UpdateIdInfos
+  ( updateModDetailsIdInfos
   ) where
 
 import GhcPrelude
@@ -17,22 +17,22 @@ import GHC.Types.Name.Set
 import Util
 import GHC.Types.Var
 import Outputable
+import GHC.StgToCmm.Types (CgInfos (..))
 
 #include "HsVersions.h"
 
--- | Update CafInfos of all occurences (in rules, unfoldings, class instances)
-updateModDetailsCafInfos
+-- | Update CafInfos and LFInfos of all occurences (in rules, unfoldings, class instances)
+updateModDetailsIdInfos
   :: DynFlags
-  -> NameSet -- ^ Non-CAFFY names in the module. Names not in this set are CAFFY.
+  -> CgInfos
   -> ModDetails -- ^ ModDetails to update
   -> ModDetails
 
-updateModDetailsCafInfos dflags _ mod_details
+updateModDetailsIdInfos dflags _ mod_details
   | gopt Opt_OmitInterfacePragmas dflags
   = mod_details
 
-updateModDetailsCafInfos _ non_cafs mod_details =
-  {- pprTrace "updateModDetailsCafInfos" (text "non_cafs:" <+> ppr non_cafs) $ -}
+updateModDetailsIdInfos _ cg_infos mod_details =
   let
     ModDetails{ md_types = type_env -- for unfoldings
               , md_insts = insts
@@ -40,11 +40,11 @@ updateModDetailsCafInfos _ non_cafs mod_details =
               } = mod_details
 
     -- type TypeEnv = NameEnv TyThing
-    ~type_env' = mapNameEnv (updateTyThingCafInfos type_env' non_cafs) type_env
+    ~type_env' = mapNameEnv (updateTyThingCafInfos type_env' cg_infos) type_env
     -- Not strict!
 
-    !insts' = strictMap (updateInstCafInfos type_env' non_cafs) insts
-    !rules' = strictMap (updateRuleCafInfos type_env') rules
+    !insts' = strictMap (updateInstIdInfos type_env' cg_infos) insts
+    !rules' = strictMap (updateRuleIdInfos type_env') rules
   in
     mod_details{ md_types = type_env'
                , md_insts = insts'
@@ -55,26 +55,26 @@ updateModDetailsCafInfos _ non_cafs mod_details =
 -- Rules
 --------------------------------------------------------------------------------
 
-updateRuleCafInfos :: TypeEnv -> CoreRule -> CoreRule
-updateRuleCafInfos _ rule@BuiltinRule{} = rule
-updateRuleCafInfos type_env Rule{ .. } = Rule { ru_rhs = updateGlobalIds type_env ru_rhs, .. }
+updateRuleIdInfos :: TypeEnv -> CoreRule -> CoreRule
+updateRuleIdInfos _ rule@BuiltinRule{} = rule
+updateRuleIdInfos type_env Rule{ .. } = Rule { ru_rhs = updateGlobalIds type_env ru_rhs, .. }
 
 --------------------------------------------------------------------------------
 -- Instances
 --------------------------------------------------------------------------------
 
-updateInstCafInfos :: TypeEnv -> NameSet -> ClsInst -> ClsInst
-updateInstCafInfos type_env non_cafs =
-    updateClsInstDFun (updateIdUnfolding type_env . updateIdCafInfo non_cafs)
+updateInstIdInfos :: TypeEnv -> CgInfos -> ClsInst -> ClsInst
+updateInstIdInfos type_env cg_infos =
+    updateClsInstDFun (updateIdUnfolding type_env . updateIdInfo cg_infos)
 
 --------------------------------------------------------------------------------
 -- TyThings
 --------------------------------------------------------------------------------
 
-updateTyThingCafInfos :: TypeEnv -> NameSet -> TyThing -> TyThing
+updateTyThingCafInfos :: TypeEnv -> CgInfos -> TyThing -> TyThing
 
-updateTyThingCafInfos type_env non_cafs (AnId id) =
-    AnId (updateIdUnfolding type_env (updateIdCafInfo non_cafs id))
+updateTyThingCafInfos type_env cg_infos (AnId id) =
+    AnId (updateIdUnfolding type_env (updateIdInfo cg_infos id))
 
 updateTyThingCafInfos _ _ other = other -- AConLike, ATyCon, ACoAxiom
 
@@ -95,13 +95,18 @@ updateIdUnfolding type_env id =
 -- Expressions
 --------------------------------------------------------------------------------
 
-updateIdCafInfo :: NameSet -> Id -> Id
-updateIdCafInfo non_cafs id
-  | idName id `elemNameSet` non_cafs
-  = -- pprTrace "updateIdCafInfo" (text "Marking" <+> ppr id <+> parens (ppr (idName id)) <+> text "as non-CAFFY") $
-    id `setIdCafInfo` NoCafRefs
-  | otherwise
-  = id
+updateIdInfo :: CgInfos -> Id -> Id
+updateIdInfo CgInfos{ cgNonCafs = non_cafs, cgLFInfos = lf_infos } id =
+    let
+      not_caffy = elemNameSet (idName id) non_cafs
+      mb_lf_info = lookupNameEnv lf_infos (idName id)
+
+      id1 = if not_caffy then setIdCafInfo id NoCafRefs else id
+      id2 = case mb_lf_info of
+              Nothing -> id1
+              Just lf_info -> setIdLFInfo id1 lf_info
+    in
+      id2
 
 --------------------------------------------------------------------------------
 

libraries/base/GHC/Exts.hs

@@ -56,7 +56,7 @@ module GHC.Exts
         breakpoint, breakpointCond,
 
         -- * Ids with special behaviour
-        lazy, inline, oneShot,
+        inline, noinline, lazy, oneShot,
 
         -- * Running 'RealWorld' state thread
         runRW#,