[Git][ghc/ghc][wip/osa1/lfinfo] Cross-module LambdaFormInfo passing

Ömer Sinan Ağacan gitlab at gitlab.haskell.org
Thu Mar 19 13:17:11 UTC 2020



Ömer Sinan Ağacan pushed to branch wip/osa1/lfinfo at Glasgow Haskell Compiler / GHC


Commits:
99b0c93a by Ömer Sinan Ağacan at 2020-03-19T13:16:52Z
Cross-module LambdaFormInfo passing

- Store LambdaFormInfos of exported Ids in interface files
- Use them in importing modules

- - - - -


29 changed files:

- compiler/GHC/CoreToIface.hs
- compiler/GHC/Driver/Hooks.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Runtime/Heap/Layout.hs
- compiler/GHC/StgToCmm.hs
- compiler/GHC/StgToCmm/Closure.hs
- compiler/GHC/StgToCmm/Env.hs
- + compiler/GHC/StgToCmm/Types.hs
- compiler/basicTypes/Id.hs
- compiler/basicTypes/IdInfo.hs
- compiler/ghc.cabal.in
- compiler/main/UpdateCafInfos.hs
- testsuite/tests/codeGen/should_compile/Makefile
- + testsuite/tests/codeGen/should_compile/cg009/A.hs
- + testsuite/tests/codeGen/should_compile/cg009/Main.hs
- + testsuite/tests/codeGen/should_compile/cg009/Makefile
- + testsuite/tests/codeGen/should_compile/cg009/all.T
- + testsuite/tests/codeGen/should_compile/cg010/A.hs
- + testsuite/tests/codeGen/should_compile/cg010/Main.hs
- + testsuite/tests/codeGen/should_compile/cg010/Makefile
- + testsuite/tests/codeGen/should_compile/cg010/all.T
- + testsuite/tests/codeGen/should_compile/cg010/cg010.stdout
- testsuite/tests/simplCore/should_compile/Makefile
- testsuite/tests/simplCore/should_compile/T4201.stdout


Changes:

=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -41,6 +41,8 @@ module GHC.CoreToIface
     , toIfaceCon
     , toIfaceApp
     , toIfaceVar
+      -- * Other stuff
+    , toIfaceLFInfo
     ) where
 
 #include "HsVersions.h"
@@ -49,6 +51,7 @@ import GhcPrelude
 
 import GHC.Iface.Syntax
 import GHC.Core.DataCon
+import GHC.StgToCmm.Types
 import Id
 import IdInfo
 import GHC.Core
@@ -74,6 +77,8 @@ import Demand ( isTopSig )
 import Cpr ( topCprSig )
 
 import Data.Maybe ( catMaybes )
+import Data.Word
+import Data.Bits
 
 {- Note [Avoiding space leaks in toIface*]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -534,7 +539,7 @@ toIfaceExpr (Var v)         = toIfaceVar v
 toIfaceExpr (Lit l)         = IfaceLit l
 toIfaceExpr (Type ty)       = IfaceType (toIfaceType ty)
 toIfaceExpr (Coercion co)   = IfaceCo   (toIfaceCoercion co)
-toIfaceExpr (Lam x b)       = IfaceLam (toIfaceBndr x, toIfaceOneShot x) (toIfaceExpr b)
+toIfaceExpr (Lam x b)       = IfaceLam (toIfaceBndr x, toIdIfaceOneShot x) (toIfaceExpr b)
 toIfaceExpr (App f a)       = toIfaceApp f [a]
 toIfaceExpr (Case s x ty as)
   | null as                 = IfaceECase (toIfaceExpr s) (toIfaceType ty)
@@ -545,12 +550,16 @@ toIfaceExpr (Tick t e)
   | Just t' <- toIfaceTickish t = IfaceTick t' (toIfaceExpr e)
   | otherwise                   = toIfaceExpr e
 
-toIfaceOneShot :: Id -> IfaceOneShot
-toIfaceOneShot id | isId id
-                  , OneShotLam <- oneShotInfo (idInfo id)
-                  = IfaceOneShot
-                  | otherwise
-                  = IfaceNoOneShot
+toIdIfaceOneShot :: Id -> IfaceOneShot
+toIdIfaceOneShot id
+  | isId id
+  = toIfaceOneShot (oneShotInfo (idInfo id))
+  | otherwise
+  = IfaceNoOneShot
+
+toIfaceOneShot :: OneShotInfo -> IfaceOneShot
+toIfaceOneShot OneShotLam = IfaceOneShot
+toIfaceOneShot NoOneShotInfo = IfaceNoOneShot
 
 ---------------------
 toIfaceTickish :: Tickish Id -> Maybe IfaceTickish
@@ -616,6 +625,41 @@ toIfaceVar v
   where name = idName v
 
 
+---------------------
+toIfaceLFInfo :: LambdaFormInfo -> IfaceLFInfo
+toIfaceLFInfo (LFReEntrant TopLevel oneshot rep fvs_flag _argdesc) =
+    IfLFReEntrant (toIfaceOneShot oneshot) rep fvs_flag
+toIfaceLFInfo (LFThunk TopLevel hasfv updateable sfi m_function) =
+   -- Assert that arity fits in 14 bits
+   ASSERT(fromEnum hasfv <= 1 && fromEnum updateable <= 1 && fromEnum m_function <= 1)
+   IfLFThunk hasfv updateable (toIfaceStandardFormInfo sfi) m_function
+toIfaceLFInfo LFUnlifted = IfLFUnlifted
+toIfaceLFInfo (LFCon con) = IfLFCon (dataConName con)
+-- All other cases are not possible at the top level.
+toIfaceLFInfo lf = pprPanic "Invalid IfaceLFInfo conversion:"
+                   (ppr lf <+> text "should not be exported")
+
+toIfaceStandardFormInfo :: StandardFormInfo -> IfaceStandardFormInfo
+toIfaceStandardFormInfo NonStandardThunk = IfStandardFormInfo 1
+toIfaceStandardFormInfo sf =
+    IfStandardFormInfo $!
+      tag sf .|. encodeField (field sf)
+  where
+    tag SelectorThunk{} = 0
+    tag ApThunk{} = 2 -- == setBit 0 1
+    tag _ = panic "Impossible"
+
+    field (SelectorThunk n) = n
+    field (ApThunk n) = n
+    field _ = panic "Impossible"
+
+    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
=====================================
@@ -162,6 +162,7 @@ import Bag
 import Exception
 import qualified Stream
 import Stream (Stream)
+import GHC.StgToCmm.Types (ModuleLFInfos)
 
 import Util
 
@@ -176,6 +177,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 )
@@ -1392,7 +1394,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)], NameSet, ModuleLFInfos)
                -- ^ @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.
@@ -1451,11 +1453,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, (caf_infos, lf_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, caf_infos, lf_infos)
 
 
 hscInteractive :: HscEnv
@@ -1549,7 +1551,7 @@ doCodeGen   :: HscEnv -> Module -> [TyCon]
             -> CollectedCCs
             -> [StgTopBinding]
             -> HpcInfo
-            -> IO (Stream IO CmmGroupSRTs NameSet)
+            -> IO (Stream IO CmmGroupSRTs (NameSet, ModuleLFInfos))
          -- 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.
@@ -1561,7 +1563,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
@@ -1580,10 +1582,11 @@ doCodeGen hsc_env this_mod data_tycons
 
         ppr_stream1 = Stream.mapM dump1 cmm_stream
 
+        pipeline_stream :: Stream IO CmmGroupSRTs (NameSet, ModuleLFInfos)
         pipeline_stream =
           {-# SCC "cmmPipeline" #-}
-          Stream.mapAccumL (cmmPipeline hsc_env) (emptySRT this_mod) ppr_stream1
-            <&> (srtMapNonCAFs . moduleSRTMap)
+          Stream.mapAccumL_ (cmmPipeline hsc_env) (emptySRT this_mod) ppr_stream1
+            <&> (first (srtMapNonCAFs . moduleSRTMap))
 
         dump2 a = do
           unless (null a) $


=====================================
compiler/GHC/Driver/Pipeline.hs
=====================================
@@ -1192,12 +1192,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, caf_infos, lf_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))
+                    final_iface <- liftIO (mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface (Just (caf_infos, lf_infos)))
                     let final_mod_details = {-# SCC updateModDetailsCafInfos #-}
-                                            updateModDetailsCafInfos iface_dflags caf_infos mod_details
+                                            updateModDetailsCafInfos iface_dflags caf_infos lf_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 (ModuleLFInfos)
 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 (NameSet, ModuleLFInfos) -> IO ModIface
+mkFullIface hsc_env partial_iface mb_id_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_id_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 (NameSet, ModuleLFInfos) -> [IfaceDecl]
+updateDecl decls Nothing = decls
+updateDecl decls (Just (non_cafs, 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 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,71 @@ data IfaceIdDetails
   | IfRecSelId (Either IfaceTyCon IfaceDecl) Bool
   | IfDFunId
 
+-- Lambda form info
+data IfaceLFInfo
+  = IfLFReEntrant !IfaceOneShot !RepArity !Bool
+  | IfLFThunk !Bool !Bool !IfaceStandardFormInfo !Bool
+  | IfLFCon              -- A saturated constructor application
+        !Name            -- The constructor 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 oneshot rep fvs_flag) =
+        text "LFReEntrant" <+> ppr (oneshot, rep, fvs_flag)
+    ppr (IfLFThunk fvs_flag upd_flag sfi fun_flag) =
+        text "LFThunk" <+> ppr (fvs_flag, upd_flag, fun_flag) <+> ppr (tcStandardFormInfo sfi)
+    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
+    -- TODO: We could pack the bytes somewhat
+    put_ bh (IfLFReEntrant oneshot rep fvs_flag) = do
+        putByte bh 0
+        put_ bh oneshot
+        put_ bh rep
+        put_ bh fvs_flag
+    put_ bh (IfLFThunk top_lvl no_fvs std_form maybe_fun) = do
+        putByte bh 1
+        put_ bh top_lvl
+        put_ bh no_fvs
+        put_ bh std_form
+        put_ bh maybe_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 <*> get bh <*> get bh
+            1 -> IfLFThunk <$> get bh <*> 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 +1466,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 +1927,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 +2227,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 +2240,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 +2572,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 MkId
   | 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,9 @@ import TcTypeNats(typeNatCoAxiomRules)
 import GHC.Iface.Syntax
 import GHC.Iface.Load
 import GHC.Iface.Env
+import GHC.StgToCmm.Types
+import GHC.StgToCmm.Closure
+import GHC.Types.RepType
 import BuildTyCl
 import TcRnMonad
 import TcType
@@ -641,7 +645,7 @@ tc_iface_decl _ ignore_prags (IfaceId {ifName = name, ifType = iface_type,
   = do  { ty <- tcIfaceType iface_type
         ; details <- tcIdDetails ty details
         ; info <- tcIdInfo ignore_prags TopLevel name ty info
-        ; return (AnId (mkGlobalId details name ty info)) }
+        ; return (AnId (addIdLFInfo (mkGlobalId details name ty info))) }
 
 tc_iface_decl _ _ (IfaceData {ifName = tc_name,
                           ifCType = cType,
@@ -1340,7 +1344,8 @@ tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body)
         ; ty'     <- tcIfaceType ty
         ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
                               NotTopLevel name ty' info
-        ; let id = mkLocalIdWithInfo name ty' id_info
+        ; let id = addIdLFInfo $
+                   mkLocalIdWithInfo name ty' id_info
                      `asJoinId_maybe` tcJoinInfo ji
         ; rhs' <- tcIfaceExpr rhs
         ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)
@@ -1361,7 +1366,7 @@ tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
      = do { rhs' <- tcIfaceExpr rhs
           ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
                                 NotTopLevel (idName id) (idType id) info
-          ; return (setIdInfo id id_info, rhs') }
+          ; return (addIdLFInfo (setIdInfo id id_info), rhs') }
 
 tcIfaceExpr (IfaceTick tickish expr) = do
     expr' <- tcIfaceExpr expr
@@ -1465,8 +1470,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
@@ -1486,6 +1490,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)
@@ -1494,10 +1501,51 @@ tcIdInfo ignore_prags toplvl name ty info = do
                        | otherwise = info
            ; return (info1 `setUnfoldingInfo` unf) }
 
+addIdLFInfo :: Id -> Id
+addIdLFInfo id = case idLFInfo_maybe id of
+                   Nothing -> setIdLFInfo id (mkLFImported (idDetails id) (idInfo id) (idType id))
+                   Just _  -> id
+
+-- Make a LambdaFormInfo for the Ids without a LFInfo in the iface file
+mkLFImported :: IdDetails -> IdInfo -> Type -> LambdaFormInfo
+mkLFImported details info ty
+  | DataConWorkId con <- details
+  , 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
+
+  | isUnliftedType ty
+  = LFUnlifted
+
+  | mightBeAFunction ty
+  = LFUnknown True
+
+  | otherwise
+  = LFUnknown False
+  where
+    arity = countFunRepArgs (arityInfo info) ty
+
 tcJoinInfo :: IfaceJoinInfo -> Maybe JoinArity
 tcJoinInfo (IfaceJoinPoint ar) = Just ar
 tcJoinInfo IfaceNotJoinPoint   = Nothing
 
+tcLFInfo :: IfaceLFInfo -> IfL LambdaFormInfo
+tcLFInfo (IfLFReEntrant oneshot rep fvs_flag) =
+    return (LFReEntrant TopLevel (tcIfaceOneShot oneshot) rep fvs_flag ArgUnknown)
+
+tcLFInfo (IfLFThunk fvs_flag upd_flag sfi fun_flag ) = do
+    return (LFThunk TopLevel fvs_flag upd_flag (tcStandardFormInfo sfi) fun_flag)
+
+tcLFInfo IfLFUnlifted = return LFUnlifted
+
+tcLFInfo (IfLFCon con_name) = LFCon <$!> tcIfaceDataCon con_name
+
+tcLFInfo (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
@@ -1586,6 +1634,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
 
@@ -540,10 +515,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
=====================================
@@ -1,5 +1,6 @@
 {-# 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.CLabel
@@ -45,6 +47,8 @@ import Outputable
 import Stream
 import BasicTypes
 import VarSet ( isEmptyDVarSet )
+import UniqFM
+import NameEnv
 
 import OrdList
 import GHC.Cmm.Graph
@@ -52,6 +56,7 @@ import GHC.Cmm.Graph
 import Data.IORef
 import Control.Monad (when,void)
 import Util
+import Data.Maybe
 
 codeGen :: DynFlags
         -> Module
@@ -59,7 +64,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
@@ -101,6 +107,20 @@ codeGen dflags this_mod data_tycons
                  mapM_ (cg . cgDataCon) (tyConDataCons tycon)
 
         ; mapM_ do_tycon data_tycons
+
+        ; cg_id_infos <- cgs_binds <$> liftIO (readIORef cgref)
+
+        -- Only external names are actually visible to codeGen. So they are the
+        -- only ones we care about.
+        ; let extractInfo info = lf `seq` Just (name,lf)
+                where
+                  id = cg_id info
+                  !name = idName id
+                  lf = cg_lf info
+
+        ; let !generatedInfo = mkNameEnv (mapMaybe extractInfo (eltsUFM cg_id_infos))
+
+        ; return $! generatedInfo
         }
 
 ---------------------------------------------------------------


=====================================
compiler/GHC/StgToCmm/Closure.hs
=====================================
@@ -24,7 +24,7 @@ module GHC.StgToCmm.Closure (
         LambdaFormInfo,         -- Abstract
         StandardFormInfo,        -- ...ditto...
         mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo,
-        mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
+        mkApLFInfo, mkLFArgument, mkLFLetNoEscape,
         mkLFStringLit,
         lfDynTag,
         isLFThunk, isLFReEntrant, lfUpdatable,
@@ -51,6 +51,7 @@ module GHC.StgToCmm.Closure (
         closureUpdReqd, closureSingleEntry,
         closureReEntrant, closureFunInfo,
         isToplevClosure,
+        mightBeAFunction,
 
         blackHoleOnEntry,  -- Needs LambdaFormInfo and SMRep
         isStaticClosure,   -- Needs SMPre
@@ -70,6 +71,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 CostCentre
 import GHC.Cmm.BlockId
@@ -188,86 +190,15 @@ 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
 ------------------------------------------------------
 
 mkLFArgument :: Id -> LambdaFormInfo
 mkLFArgument id
-  | isUnliftedType ty      = LFUnlifted
-  | might_be_a_function ty = LFUnknown True
-  | otherwise              = LFUnknown False
+  | isUnliftedType ty   = LFUnlifted
+  | mightBeAFunction ty = LFUnknown True
+  | otherwise           = LFUnknown False
   where
     ty = idType id
 
@@ -295,13 +226,13 @@ mkLFThunk thunk_ty top fvs upd_flag
     LFThunk top (null fvs)
             (isUpdatable upd_flag)
             NonStandardThunk
-            (might_be_a_function thunk_ty)
+            (mightBeAFunction thunk_ty)
 
 --------------
-might_be_a_function :: Type -> Bool
+mightBeAFunction :: Type -> Bool
 -- Return False only if we are *sure* it's a data type
 -- Look through newtypes etc as much as poss
-might_be_a_function ty
+mightBeAFunction ty
   | [LiftedRep] <- typePrimRep ty
   , Just tc <- tyConAppTyCon_maybe (unwrapType ty)
   , isDataTyCon tc
@@ -317,30 +248,13 @@ mkConLFInfo con = LFCon con
 mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo
 mkSelectorLFInfo id offset updatable
   = LFThunk NotTopLevel False updatable (SelectorThunk offset)
-        (might_be_a_function (idType id))
+        (mightBeAFunction (idType id))
 
 -------------
 mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo
 mkApLFInfo id upd_flag arity
   = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)
-        (might_be_a_function (idType id))
-
--------------
-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
-  where
-    arity = idFunRepArity id
+        (mightBeAFunction (idType id))
 
 -------------
 mkLFStringLit :: LambdaFormInfo


=====================================
compiler/GHC/StgToCmm/Env.hs
=====================================
@@ -30,6 +30,7 @@ import GHC.Core.TyCon
 import GHC.StgToCmm.Monad
 import GHC.StgToCmm.Utils
 import GHC.StgToCmm.Closure
+import GHC.StgToCmm.Types
 
 import GHC.Cmm.CLabel
 
@@ -47,6 +48,8 @@ import TysPrim
 import UniqFM
 import Util
 import VarEnv
+import GHC.Core.DataCon
+import BasicTypes
 
 -------------------------------------
 --        Manipulating CgIdInfo
@@ -143,6 +146,26 @@ getCgIdInfo id
               cgLookupPanic id -- Bug
         }}}
 
+mkLFImported :: Id -> LambdaFormInfo
+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 (panic "arg_descr")
+
+        | otherwise
+        -> mkLFArgument id -- Not sure of exact arity
+  where
+    arity = idFunRepArity id
+
 cgLookupPanic :: Id -> FCode a
 cgLookupPanic id
   = do  local_binds <- getBinds


=====================================
compiler/GHC/StgToCmm/Types.hs
=====================================
@@ -0,0 +1,157 @@
+{-# LANGUAGE CPP #-}
+
+module GHC.StgToCmm.Types
+  ( WordOff
+  , LambdaFormInfo (..)
+  , ModuleLFInfos
+  , Liveness
+  , ArgDescr (..)
+  , StandardFormInfo (..)
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import BasicTypes
+import GHC.Core.DataCon
+import NameEnv
+import Outputable
+
+-- | Word offset, or word count
+type WordOff = Int
+
+--------------------------------------------------------------------------------
+--                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)
+
+instance Outputable StandardFormInfo where
+  ppr NonStandardThunk = text "RegThunk"
+  ppr (SelectorThunk w) = text "SelThunk:" <> ppr w
+  ppr (ApThunk n) = text "ApThunk:" <> ppr n


=====================================
compiler/basicTypes/Id.hs
=====================================
@@ -92,7 +92,7 @@ module Id (
         idCallArity, idFunRepArity,
         idUnfolding, realIdUnfolding,
         idSpecialisation, idCoreRules, idHasRules,
-        idCafInfo,
+        idCafInfo, idLFInfo, idLFInfo_maybe,
         idOneShotInfo, idStateHackOneShotInfo,
         idOccInfo,
         isNeverLevPolyId,
@@ -105,6 +105,7 @@ module Id (
         setIdSpecialisation,
         setIdCafInfo,
         setIdOccInfo, zapIdOccInfo,
+        setIdLFInfo,
 
         setIdDemandInfo,
         setIdStrictness,
@@ -731,6 +732,19 @@ idCafInfo id = cafInfo (idInfo id)
 setIdCafInfo :: Id -> CafInfo -> Id
 setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id
 
+        ---------------------------------
+        -- Lambda form info
+idLFInfo :: HasCallStack => Id -> LambdaFormInfo
+idLFInfo id = case lfInfo (idInfo id) of
+                Nothing -> pprPanic "idLFInfo" (text "LFInfo not available for Id" <+> ppr id)
+                Just lf_info -> lf_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/basicTypes/IdInfo.hs
=====================================
@@ -74,6 +74,10 @@ module IdInfo (
         ppCafInfo, mayHaveCafRefs,
         cafInfo, setCafInfo,
 
+        -- ** The LambdaFormInfo type
+        LambdaFormInfo(..),
+        lfInfo, setLFInfo,
+
         -- ** Tick-box Info
         TickBoxOp(..), TickBoxId,
 
@@ -104,6 +108,8 @@ import Demand
 import Cpr
 import Util
 
+import GHC.StgToCmm.Types (LambdaFormInfo (..))
+
 -- infixl so you can say (id `set` a `set` b)
 infixl  1 `setRuleInfo`,
           `setArityInfo`,
@@ -270,8 +276,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
@@ -294,13 +301,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 }
@@ -326,7 +338,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
=====================================
@@ -298,6 +298,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
=====================================
@@ -17,6 +17,7 @@ import NameSet
 import Util
 import Var
 import Outputable
+import GHC.StgToCmm.Types (ModuleLFInfos)
 
 #include "HsVersions.h"
 
@@ -24,14 +25,15 @@ import Outputable
 updateModDetailsCafInfos
   :: DynFlags
   -> NameSet -- ^ Non-CAFFY names in the module. Names not in this set are CAFFY.
+  -> ModuleLFInfos
   -> ModDetails -- ^ ModDetails to update
   -> ModDetails
 
-updateModDetailsCafInfos dflags _ mod_details
+updateModDetailsCafInfos dflags _ _ mod_details
   | gopt Opt_OmitInterfacePragmas dflags
   = mod_details
 
-updateModDetailsCafInfos _ non_cafs mod_details =
+updateModDetailsCafInfos _ non_cafs lf_infos mod_details =
   {- pprTrace "updateModDetailsCafInfos" (text "non_cafs:" <+> ppr non_cafs) $ -}
   let
     ModDetails{ md_types = type_env -- for unfoldings
@@ -40,10 +42,10 @@ 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' non_cafs lf_infos) type_env
     -- Not strict!
 
-    !insts' = strictMap (updateInstCafInfos type_env' non_cafs) insts
+    !insts' = strictMap (updateInstCafInfos type_env' non_cafs lf_infos) insts
     !rules' = strictMap (updateRuleCafInfos type_env') rules
   in
     mod_details{ md_types = type_env'
@@ -63,20 +65,20 @@ updateRuleCafInfos type_env Rule{ .. } = Rule { ru_rhs = updateGlobalIds type_en
 -- Instances
 --------------------------------------------------------------------------------
 
-updateInstCafInfos :: TypeEnv -> NameSet -> ClsInst -> ClsInst
-updateInstCafInfos type_env non_cafs =
-    updateClsInstDFun (updateIdUnfolding type_env . updateIdCafInfo non_cafs)
+updateInstCafInfos :: TypeEnv -> NameSet -> ModuleLFInfos -> ClsInst -> ClsInst
+updateInstCafInfos type_env non_cafs lf_infos =
+    updateClsInstDFun (updateIdUnfolding type_env . updateIdCafInfo non_cafs lf_infos)
 
 --------------------------------------------------------------------------------
 -- TyThings
 --------------------------------------------------------------------------------
 
-updateTyThingCafInfos :: TypeEnv -> NameSet -> TyThing -> TyThing
+updateTyThingCafInfos :: TypeEnv -> NameSet -> ModuleLFInfos -> TyThing -> TyThing
 
-updateTyThingCafInfos type_env non_cafs (AnId id) =
-    AnId (updateIdUnfolding type_env (updateIdCafInfo non_cafs id))
+updateTyThingCafInfos type_env non_cafs lf_infos (AnId id) =
+    AnId (updateIdUnfolding type_env (updateIdCafInfo non_cafs lf_infos id))
 
-updateTyThingCafInfos _ _ other = other -- AConLike, ATyCon, ACoAxiom
+updateTyThingCafInfos _ _ _ other = other -- AConLike, ATyCon, ACoAxiom
 
 --------------------------------------------------------------------------------
 -- Unfoldings
@@ -95,13 +97,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
+updateIdCafInfo :: NameSet -> ModuleLFInfos -> Id -> Id
+updateIdCafInfo non_cafs 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
 
 --------------------------------------------------------------------------------
 


=====================================
testsuite/tests/codeGen/should_compile/Makefile
=====================================
@@ -64,10 +64,10 @@ T17648:
 	#  NoCafRefs) to the interface files.
 	'$(TEST_HC)' $(TEST_HC_OPTS) -dno-typeable-binds -O T17648.hs -v0
 	'$(TEST_HC)' --show-iface T17648.hi | tr -d '\n' | \
-		grep -F 'f :: T GHC.Types.Int -> ()  [HasNoCafRefs, Arity' >/dev/null
+		grep -F 'f :: T GHC.Types.Int -> ()  [HasNoCafRefs,   LambdaFormInfo' >/dev/null
 
 	# Second compilation with -fcatch-bottoms, f should be CAFFY
 	'$(TEST_HC)' $(TEST_HC_OPTS) -dno-typeable-binds -O \
 		-fcatch-bottoms T17648.hs -v0 -fforce-recomp
 	'$(TEST_HC)' --show-iface T17648.hi | tr -d '\n' | \
-		grep -F 'f :: T GHC.Types.Int -> ()  [Arity: 1, Strictness' >/dev/null
+		grep -F 'f :: T GHC.Types.Int -> ()  [LambdaFormInfo' >/dev/null


=====================================
testsuite/tests/codeGen/should_compile/cg009/A.hs
=====================================
@@ -0,0 +1,5 @@
+module A where
+
+newtype A = A Int
+
+val = A 42


=====================================
testsuite/tests/codeGen/should_compile/cg009/Main.hs
=====================================
@@ -0,0 +1,7 @@
+module Main where
+
+import A
+
+main = return ()
+
+a = val


=====================================
testsuite/tests/codeGen/should_compile/cg009/Makefile
=====================================
@@ -0,0 +1,9 @@
+TOP=../../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+# Make sure the LFInfo for an exported, but not directly used newtype
+# constructors does not trip up the compiler.
+cg009:
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c -O A.hs -fforce-recomp
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c -O0 Main.hs -fforce-recomp


=====================================
testsuite/tests/codeGen/should_compile/cg009/all.T
=====================================
@@ -0,0 +1 @@
+test('cg009', [extra_files(['A.hs','Main.hs'])], makefile_test, ['cg009'])


=====================================
testsuite/tests/codeGen/should_compile/cg010/A.hs
=====================================
@@ -0,0 +1,4 @@
+module A where
+
+{-# NOINLINE val #-}
+val = Just 42


=====================================
testsuite/tests/codeGen/should_compile/cg010/Main.hs
=====================================
@@ -0,0 +1,8 @@
+module Main where
+
+import A
+
+main = return ()
+
+a = val
+


=====================================
testsuite/tests/codeGen/should_compile/cg010/Makefile
=====================================
@@ -0,0 +1,9 @@
+TOP=../../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+# Make sure LFInfo causes the imported reference to val to get tagged.
+cg010:
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c -O A.hs -fforce-recomp
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c -O Main.hs -fforce-recomp -ddump-cmm -ddump-to-file
+	grep "A.val_closure+2" Main.dump-cmm


=====================================
testsuite/tests/codeGen/should_compile/cg010/all.T
=====================================
@@ -0,0 +1 @@
+test('cg010', [extra_files(['A.hs','Main.hs'])], makefile_test, ['cg010'])


=====================================
testsuite/tests/codeGen/should_compile/cg010/cg010.stdout
=====================================
@@ -0,0 +1 @@
+         const A.val_closure+2;


=====================================
testsuite/tests/simplCore/should_compile/Makefile
=====================================
@@ -102,7 +102,7 @@ T4201:
 	'$(TEST_HC)' $(TEST_HC_OPTS) -c -O T4201.hs
 	'$(TEST_HC)' $(TEST_HC_OPTS) --show-iface T4201.hi > T4201.list
 	# poor man idea about how to replace GNU grep -B2 "Sym" invocation with pure POSIX tools
-	for i in `grep -n "Sym" T4201.list |cut -d ':' -f -1`; do head -$$i T4201.list | tail -3 ; done
+	for i in `grep -n "Sym" T4201.list | cut -d ':' -f -1`; do head -$$i T4201.list | tail -5; done
 	$(RM) -f T4201.list
 
 # This one looped as a result of bogus specialisation


=====================================
testsuite/tests/simplCore/should_compile/T4201.stdout
=====================================
@@ -1,3 +1,5 @@
-  [HasNoCafRefs, Arity: 1, Strictness: <S,1*H>, CPR: m1,
+  [HasNoCafRefs,
+   LambdaFormInfo: LFReEntrant (NoOneShotInfo, 1, True), Arity: 1,
+   Strictness: <S,1*H>, CPR: m1,
    Unfolding: InlineRule (0, True, True)
               bof `cast` (Sym (N:Foo[0]) ->_R <T>_R)]



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/99b0c93a180a623e3447073f52f92e7650349e89

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/99b0c93a180a623e3447073f52f92e7650349e89
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200319/97b13aed/attachment-0001.html>


More information about the ghc-commits mailing list