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

Ömer Sinan Ağacan gitlab at gitlab.haskell.org
Tue Apr 28 13:26:07 UTC 2020



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


Commits:
792c78a2 by Ömer Sinan Ağacan at 2020-04-28T16:25:49+03:00
Cross-module LambdaFormInfo passing

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

This is for optimization purposes: if we know LambdaFormInfo of imported
Ids we can generate more efficient calling code, see `getCallMethod`.

Exporting (putting them in interface files or in ModDetails) and
importing (reading them from interface files) are both optional. We
don't assume known LambdaFormInfos anywhere and do not change how we
call Ids with unknown LambdaFormInfos.

Runtime, allocation, and residency numbers when building
Cabal-the-library (commit 0d4ee7ba3).

(Log and .hp files are in the MR: !2842)

Runtime:

|     | GHC HEAD | This patch | Diff           |
|-----|----------|------------|----------------|
| -O0 |  0:35.70 |    0:34.75 | -0.95s, -2.66% |
| -O1 |  2:25.21 |    2:25.16 | -0.05s, -0.03% |
| -O2 |  2:52.89 |    2:51.25 | -1.63s, -0.9%  |

Allocations:

|     | GHC HEAD        | This patch      | Diff                 |
|-----|-----------------|-----------------|----------------------|
| -O0 |  54,872,673,008 |  54,917,849,488 | +45,176,480, +0.08%  |
| -O1 | 227,080,315,016 | 227,584,483,224 | +504,168,208, +0.22% |
| -O2 | 266,085,969,832 | 266,710,115,472 | +624,145,640, +0.23% |

Max. residency:

NOTE: Residency is measured with extra runtime args: `-i0 -h` which effectively
turn all GCs into major GCs, and do GC more often.

|     | GHC HEAD                   | This patch                   | Diff                 |
|-----|----------------------------|------------------------------|----------------------|
| -O0 | 416,350,080 (894 samples)  | 417,733,152 (892 samples)    | +1,383,072, +0.33%   |
| -O1 | 928,484,840 (2101 samples) | 945,624,664 (2098 samples)   | +17,139,824, +1.84%  |
| -O2 | 991,311,896 (2548 samples) | 1,010,647,088 (2536 samples) | +19,335,192, +1.95%  |

NoFib results:

--------------------------------------------------------------------------------
        Program           Size    Allocs    Instrs     Reads    Writes
--------------------------------------------------------------------------------
             CS           0.0%      0.0%     +0.0%     +0.0%     +0.0%
            CSD           0.0%      0.0%      0.0%     +0.0%     +0.0%
             FS           0.0%      0.0%     +0.0%     +0.0%     +0.0%
              S           0.0%      0.0%     +0.0%     +0.0%     +0.0%
             VS           0.0%      0.0%     +0.0%     +0.0%     +0.0%
            VSD           0.0%      0.0%     +0.0%     +0.0%     +0.1%
            VSM           0.0%      0.0%     +0.0%     +0.0%     +0.0%
           anna           0.0%      0.0%     -0.3%     -0.8%     -0.0%
           ansi           0.0%      0.0%     -0.0%     -0.0%      0.0%
           atom           0.0%      0.0%     -0.0%     -0.0%      0.0%
         awards           0.0%      0.0%     -0.1%     -0.3%      0.0%
         banner           0.0%      0.0%     -0.0%     -0.0%     -0.0%
     bernouilli           0.0%      0.0%     -0.0%     -0.0%     -0.0%
   binary-trees           0.0%      0.0%     -0.0%     -0.0%     +0.0%
          boyer           0.0%      0.0%     -0.0%     -0.0%      0.0%
         boyer2           0.0%      0.0%     -0.0%     -0.0%      0.0%
           bspt           0.0%      0.0%     -0.0%     -0.2%      0.0%
      cacheprof           0.0%      0.0%     -0.1%     -0.4%     +0.0%
       calendar           0.0%      0.0%     -0.0%     -0.0%      0.0%
       cichelli           0.0%      0.0%     -0.9%     -2.4%      0.0%
        circsim           0.0%      0.0%     -0.0%     -0.0%      0.0%
       clausify           0.0%      0.0%     -0.1%     -0.3%      0.0%
  comp_lab_zift           0.0%      0.0%     -0.0%     -0.0%     +0.0%
       compress           0.0%      0.0%     -0.0%     -0.0%     -0.0%
      compress2           0.0%      0.0%     -0.0%     -0.0%      0.0%
    constraints           0.0%      0.0%     -0.1%     -0.2%     -0.0%
   cryptarithm1           0.0%      0.0%     -0.0%     -0.0%      0.0%
   cryptarithm2           0.0%      0.0%     -1.4%     -4.1%     -0.0%
            cse           0.0%      0.0%     -0.0%     -0.0%     -0.0%
   digits-of-e1           0.0%      0.0%     -0.0%     -0.0%     -0.0%
   digits-of-e2           0.0%      0.0%     -0.0%     -0.0%     -0.0%
         dom-lt           0.0%      0.0%     -0.1%     -0.2%      0.0%
          eliza           0.0%      0.0%     -0.5%     -1.5%      0.0%
          event           0.0%      0.0%     -0.0%     -0.0%     -0.0%
    exact-reals           0.0%      0.0%     -0.1%     -0.3%     +0.0%
         exp3_8           0.0%      0.0%     -0.0%     -0.0%     -0.0%
         expert           0.0%      0.0%     -0.3%     -1.0%     -0.0%
 fannkuch-redux           0.0%      0.0%     +0.0%     +0.0%     +0.0%
          fasta           0.0%      0.0%     -0.0%     -0.0%     +0.0%
            fem           0.0%      0.0%     -0.0%     -0.0%      0.0%
            fft           0.0%      0.0%     -0.0%     -0.0%      0.0%
           fft2           0.0%      0.0%     -0.0%     -0.0%      0.0%
       fibheaps           0.0%      0.0%     -0.0%     -0.0%     +0.0%
           fish           0.0%      0.0%      0.0%     -0.0%     +0.0%
          fluid           0.0%      0.0%     -0.4%     -1.2%     +0.0%
         fulsom           0.0%      0.0%     -0.0%     -0.0%      0.0%
         gamteb           0.0%      0.0%     -0.1%     -0.3%      0.0%
            gcd           0.0%      0.0%     -0.0%     -0.0%      0.0%
    gen_regexps           0.0%      0.0%     -0.0%     -0.0%     -0.0%
         genfft           0.0%      0.0%     -0.0%     -0.0%      0.0%
             gg           0.0%      0.0%     -0.0%     -0.0%     +0.0%
           grep           0.0%      0.0%     -0.0%     -0.0%     -0.0%
         hidden           0.0%      0.0%     -0.1%     -0.4%     -0.0%
            hpg           0.0%      0.0%     -0.2%     -0.5%     +0.0%
            ida           0.0%      0.0%     -0.0%     -0.0%     +0.0%
          infer           0.0%      0.0%     -0.3%     -0.8%     -0.0%
        integer           0.0%      0.0%     -0.0%     -0.0%     +0.0%
      integrate           0.0%      0.0%     -0.0%     -0.0%      0.0%
   k-nucleotide           0.0%      0.0%     -0.0%     -0.0%     +0.0%
          kahan           0.0%      0.0%     -0.0%     -0.0%     +0.0%
        knights           0.0%      0.0%     -2.2%     -5.4%      0.0%
         lambda           0.0%      0.0%     -0.6%     -1.8%      0.0%
     last-piece           0.0%      0.0%     -0.0%     -0.0%      0.0%
           lcss           0.0%      0.0%     -0.0%     -0.1%      0.0%
           life           0.0%      0.0%     -0.0%     -0.1%      0.0%
           lift           0.0%      0.0%     -0.2%     -0.6%     +0.0%
         linear           0.0%      0.0%     -0.0%     -0.0%     -0.0%
      listcompr           0.0%      0.0%     -0.0%     -0.0%      0.0%
       listcopy           0.0%      0.0%     -0.0%     -0.0%      0.0%
       maillist           0.0%      0.0%     -0.1%     -0.3%     +0.0%
         mandel           0.0%      0.0%     -0.0%     -0.0%      0.0%
        mandel2           0.0%      0.0%     -0.0%     -0.0%     -0.0%
           mate          +0.0%      0.0%     -0.0%     -0.0%     -0.0%
        minimax           0.0%      0.0%     -0.2%     -1.0%      0.0%
        mkhprog           0.0%      0.0%     -0.1%     -0.2%     -0.0%
     multiplier           0.0%      0.0%     -0.0%     -0.0%     -0.0%
         n-body           0.0%      0.0%     -0.0%     -0.0%     +0.0%
       nucleic2           0.0%      0.0%     -0.1%     -0.2%      0.0%
           para           0.0%      0.0%     -0.0%     -0.0%     -0.0%
      paraffins           0.0%      0.0%     -0.0%     -0.0%      0.0%
         parser           0.0%      0.0%     -0.2%     -0.7%      0.0%
        parstof           0.0%      0.0%     -0.0%     -0.0%     +0.0%
            pic           0.0%      0.0%     -0.0%     -0.0%      0.0%
       pidigits           0.0%      0.0%     +0.0%     +0.0%     +0.0%
          power           0.0%      0.0%     -0.2%     -0.6%     +0.0%
         pretty           0.0%      0.0%     -0.0%     -0.0%     -0.0%
         primes           0.0%      0.0%     -0.0%     -0.0%      0.0%
      primetest           0.0%      0.0%     -0.0%     -0.0%     -0.0%
         prolog           0.0%      0.0%     -0.3%     -1.1%      0.0%
         puzzle           0.0%      0.0%     -0.0%     -0.0%      0.0%
         queens           0.0%      0.0%     -0.0%     -0.0%     +0.0%
        reptile           0.0%      0.0%     -0.0%     -0.0%      0.0%
reverse-complem           0.0%      0.0%     -0.0%     -0.0%     +0.0%
        rewrite           0.0%      0.0%     -0.7%     -2.5%     -0.0%
           rfib           0.0%      0.0%     -0.0%     -0.0%      0.0%
            rsa           0.0%      0.0%     -0.0%     -0.0%      0.0%
            scc           0.0%      0.0%     -0.1%     -0.2%     -0.0%
          sched           0.0%      0.0%     -0.0%     -0.0%     -0.0%
            scs           0.0%      0.0%     -1.0%     -2.6%     +0.0%
         simple           0.0%      0.0%     +0.0%     -0.0%     +0.0%
          solid           0.0%      0.0%     -0.0%     -0.0%      0.0%
        sorting           0.0%      0.0%     -0.6%     -1.6%      0.0%
  spectral-norm           0.0%      0.0%     +0.0%      0.0%     +0.0%
         sphere           0.0%      0.0%     -0.0%     -0.0%     -0.0%
         symalg           0.0%      0.0%     -0.0%     -0.0%     +0.0%
            tak           0.0%      0.0%     -0.0%     -0.0%      0.0%
      transform           0.0%      0.0%     -0.0%     -0.0%      0.0%
       treejoin           0.0%      0.0%     -0.0%     -0.0%      0.0%
      typecheck           0.0%      0.0%     -0.0%     -0.0%     +0.0%
        veritas          +0.0%      0.0%     -0.2%     -0.4%     +0.0%
           wang           0.0%      0.0%     -0.0%     -0.0%      0.0%
      wave4main           0.0%      0.0%     -0.0%     -0.0%     -0.0%
   wheel-sieve1           0.0%      0.0%     -0.0%     -0.0%     -0.0%
   wheel-sieve2           0.0%      0.0%     -0.0%     -0.0%     +0.0%
           x2n1           0.0%      0.0%     -0.0%     -0.0%     -0.0%
--------------------------------------------------------------------------------
            Min           0.0%      0.0%     -2.2%     -5.4%     -0.0%
            Max          +0.0%      0.0%     +0.0%     +0.0%     +0.1%
 Geometric Mean          -0.0%     -0.0%     -0.1%     -0.3%     +0.0%

Metric increases micro benchmarks tracked in #17686:

Metric Increase:
    T12150
    T12234
    T12425
    T13035
    T5837
    T6048

Co-authored-by: Andreas Klebinger <klebinger.andreas at gmx.at>

- - - - -


28 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/Iface/UpdateCafInfos.hs → compiler/GHC/Iface/UpdateIdInfos.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Runtime/Heap/Layout.hs
- compiler/GHC/StgToCmm.hs
- compiler/GHC/StgToCmm/Closure.hs
- + compiler/GHC/StgToCmm/Types.hs
- compiler/GHC/Types/Id.hs
- compiler/GHC/Types/Id/Info.hs
- compiler/ghc.cabal.in
- 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
=====================================
@@ -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 GHC.Data.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
@@ -147,6 +146,7 @@ import GHC.Tc.Utils.Env
 import GHC.Builtin.Names
 import GHC.Driver.Plugins
 import GHC.Runtime.Loader   ( initializePlugins )
+import GHC.StgToCmm.Types (CgInfos (..), ModuleLFInfos)
 
 import GHC.Driver.Session
 import GHC.Utils.Error
@@ -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 )
@@ -1385,7 +1386,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.
@@ -1444,11 +1445,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
@@ -1542,7 +1543,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.
@@ -1554,7 +1555,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
@@ -1573,10 +1574,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 GHC.Settings
 import GHC.Data.Bag             ( unitBag )
 import GHC.Data.FastString      ( mkFastString )
 import GHC.Iface.Make           ( mkFullIface )
-import GHC.Iface.UpdateCafInfos ( updateModDetailsCafInfos )
+import GHC.Iface.UpdateIdInfos  ( updateModDetailsIdInfos )
 
 import GHC.Utils.Exception as Exception
 import System.Directory
@@ -1178,12 +1178,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 GHC.Tc.Utils.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,
@@ -67,15 +70,18 @@ import GHC.Utils.Binary
 import GHC.Data.BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue )
 import GHC.Types.Var( VarBndr(..), binderVar )
 import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisArgFlag )
-import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith, debugIsOn )
+import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith, debugIsOn,
+                       seqList )
 import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..))
 import GHC.Utils.Lexeme (isLexSym)
 import GHC.Builtin.Types ( constraintKindTyConName )
-import GHC.Utils.Misc (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
=====================================
@@ -123,6 +123,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/Iface/UpdateCafInfos.hs → compiler/GHC/Iface/UpdateIdInfos.hs
=====================================
@@ -1,38 +1,38 @@
 {-# LANGUAGE CPP, BangPatterns, Strict, RecordWildCards #-}
 
-module GHC.Iface.UpdateCafInfos
-  ( updateModDetailsCafInfos
+module GHC.Iface.UpdateIdInfos
+  ( updateModDetailsIdInfos
   ) where
 
 import GHC.Prelude
 
 import GHC.Core
+import GHC.Core.InstEnv
 import GHC.Driver.Session
 import GHC.Driver.Types
+import GHC.StgToCmm.Types (CgInfos (..))
 import GHC.Types.Id
 import GHC.Types.Id.Info
-import GHC.Core.InstEnv
 import GHC.Types.Name.Env
 import GHC.Types.Name.Set
-import GHC.Utils.Misc
 import GHC.Types.Var
+import GHC.Utils.Misc
 import GHC.Utils.Outputable
 
 #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 at BuiltinRule{} = rule
-updateRuleCafInfos type_env Rule{ .. } = Rule { ru_rhs = updateGlobalIds type_env ru_rhs, .. }
+updateRuleIdInfos :: TypeEnv -> CoreRule -> CoreRule
+updateRuleIdInfos _ rule at 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
 
 --------------------------------------------------------------------------------
 
@@ -116,7 +121,7 @@ updateGlobalIds env e = go env e
       case lookupNameEnv env (varName var) of
         Nothing -> var
         Just (AnId id) -> id
-        Just other -> pprPanic "GHC.Iface.UpdateCafInfos.updateGlobalIds" $
+        Just other -> pprPanic "UpdateCafInfos.updateGlobalIds" $
           text "Found a non-Id for Id Name" <+> ppr (varName var) $$
           nest 4 (text "Id:" <+> ppr var $$
                   text "TyThing:" <+> ppr other)


=====================================
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 GHC.Builtin.Types.Literals(typeNatCoAxiomRules)
 import GHC.Iface.Syntax
 import GHC.Iface.Load
 import GHC.Iface.Env
+import GHC.StgToCmm.Types
 import GHC.Tc.TyCl.Build
 import GHC.Tc.Utils.Monad
 import GHC.Tc.Utils.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 GHC.Utils.Outputable
 import GHC.Platform
 import GHC.Data.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
=====================================
@@ -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.Utils
@@ -47,6 +49,8 @@ import GHC.Data.Stream
 import GHC.Types.Basic
 import GHC.Types.Var.Set ( isEmptyDVarSet )
 import GHC.SysTools.FileCleanup
+import GHC.Types.Unique.FM
+import GHC.Types.Name.Env
 
 import GHC.Data.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
=====================================
@@ -0,0 +1,174 @@
+{-# LANGUAGE CPP #-}
+
+module GHC.StgToCmm.Types
+  ( CgInfos (..)
+  , LambdaFormInfo (..)
+  , ModuleLFInfos
+  , Liveness
+  , ArgDescr (..)
+  , StandardFormInfo (..)
+  , WordOff
+  ) where
+
+#include "HsVersions.h"
+
+import GHC.Prelude
+
+import GHC.Types.Basic
+import GHC.Core.DataCon
+import GHC.Types.Name.Env
+import GHC.Types.Name.Set
+import GHC.Utils.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 GHC.Utils.Misc
 
+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
=====================================
@@ -220,7 +220,7 @@ Library
         GHC.Types.SrcLoc
         GHC.Types.Unique.Supply
         GHC.Types.Unique
-        GHC.Iface.UpdateCafInfos
+        GHC.Iface.UpdateIdInfos
         GHC.Types.Var
         GHC.Types.Var.Env
         GHC.Types.Var.Set
@@ -287,6 +287,7 @@ Library
         GHC.StgToCmm.Ticky
         GHC.StgToCmm.Utils
         GHC.StgToCmm.ExtCode
+        GHC.StgToCmm.Types
         GHC.Runtime.Heap.Layout
         GHC.Core.Arity
         GHC.Core.FVs


=====================================
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\r' | \
-		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\r' | \
-		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
=====================================
@@ -107,7 +107,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 -4; done
 	$(RM) -f T4201.list
 
 # This one looped as a result of bogus specialisation


=====================================
testsuite/tests/simplCore/should_compile/T4201.stdout
=====================================
@@ -1,3 +1,4 @@
-  [HasNoCafRefs, Arity: 1, Strictness: <S,1*U>,
+  [HasNoCafRefs, LambdaFormInfo: LFReEntrant 1, Arity: 1,
+   Strictness: <S,1*U>,
    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/792c78a2447579f4a140bccf08b82095a60f7248

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/792c78a2447579f4a140bccf08b82095a60f7248
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/20200428/194cff82/attachment-0001.html>


More information about the ghc-commits mailing list