Commit 96eb36f9 authored by Ömer Sinan Ağacan's avatar Ömer Sinan Ağacan

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's avatarAndreas Klebinger <klebinger.andreas@gmx.at>
parent a43620c6
......@@ -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
......@@ -616,6 +618,27 @@ toIfaceVar v
where name = idName v
---------------------
toIfaceLFInfo :: Name -> LambdaFormInfo -> IfaceLFInfo
toIfaceLFInfo nm lfi = case lfi of
LFReEntrant top_lvl arity no_fvs _arg_descr ->
ASSERT2(isTopLevel top_lvl, ppr nm)
ASSERT2(no_fvs, ppr nm)
IfLFReEntrant arity
LFThunk top_lvl no_fvs updatable sfi mb_fun ->
ASSERT2(isTopLevel top_lvl, ppr nm)
ASSERT2(no_fvs, ppr nm)
ASSERT2(sfi == NonStandardThunk, ppr nm)
IfLFThunk updatable mb_fun
LFCon dc ->
IfLFCon (dataConName dc)
LFUnknown mb_fun ->
IfLFUnknown mb_fun
LFUnlifted ->
IfLFUnlifted
LFLetNoEscape ->
panic "toIfaceLFInfo: LFLetNoEscape"
{- Note [Inlining and hs-boot files]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this example (#10083, #12789):
......
......@@ -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))
}
......
......@@ -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) $
......
......@@ -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]
......
......@@ -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
......@@ -98,15 +99,19 @@ mkPartialIface hsc_env mod_details
= mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust
safe_mode usages doc_hdr decl_docs arg_docs 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
-- | Fully instantiate an interface. Adds fingerprints and potentially code
-- generator produced information.
--
-- CgInfos is not available when not generating code (-fno-code), or when not
-- generating interface pragmas (-fomit-interface-pragmas). See also
-- Note [Conveying CAF-info and LFInfo between modules] in GHC.StgToCmm.Types.
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 +122,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 -- LFInfos not available when building .cmm files
Just lf_info -> HsLFInfo (toIfaceLFInfo nm 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
......
......@@ -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,77 @@ 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 -- True <=> updatable
!Bool -- True <=> might be a function type
| 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 mb_fun) =
text "LFThunk" <+> parens
(text "updatable=" <> ppr updatable <+>
text "might_be_function=" <+> ppr 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 mb_fun) = do
putByte bh 1
put_ bh updatable
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
2 -> IfLFCon <$> get bh
3 -> IfLFUnknown <$> get bh
4 -> pure IfLFUnlifted
_ -> panic "Invalid byte"
{-
Note [Versioning of instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -1393,6 +1472,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 +1933,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 +2233,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 +2246,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 +2578,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
......
......@@ -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"
{-
%************************************************************************
......
{-# 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).
--
-- See Note [Conveying CAF-info and LFInfo between modules] in
-- GHC.StgToCmm.Types.
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 +44,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 (updateTyThingIdInfos 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,28 +59,28 @@ updateModDetailsCafInfos _ non_cafs mod_details =
-- Rules
--------------------------------------------------------------------------------
updateRuleCafInfos :: TypeEnv -> CoreRule -> CoreRule
updateRuleCafInfos _ rule@BuiltinRule{} = rule
updateRuleCafInfos type_env Rule{ .. } = Rule { ru_rhs = updateGlobalIds type_env ru_rhs, .. }
updateRuleIdInfos :: TypeEnv -> CoreRule -> CoreRule
updateRuleIdInfos _ rule@BuiltinRule{} = rule
updateRuleIdInfos type_env Rule{ .. } = Rule { ru_rhs = updateGlobalIds type_env ru_rhs, .. }
--------------------------------------------------------------------------------
-- Instances
--------------------------------------------------------------------------------
updateInstCafInfos :: TypeEnv -> NameSet -> ClsInst -> ClsInst
updateInstCafInfos type_env non_cafs =
updateClsInstDFun (updateIdUnfolding type_env . updateIdCafInfo non_cafs)
updateInstIdInfos :: TypeEnv -> CgInfos -> ClsInst -> ClsInst
updateInstIdInfos type_env cg_infos =
updateClsInstDFun (updateIdUnfolding type_env . updateIdInfo cg_infos)
--------------------------------------------------------------------------------
-- TyThings
--------------------------------------------------------------------------------
updateTyThingCafInfos :: TypeEnv -> NameSet -> TyThing -> TyThing
updateTyThingIdInfos :: TypeEnv -> CgInfos -> TyThing -> TyThing
updateTyThingCafInfos type_env non_cafs (AnId id) =
AnId (updateIdUnfolding type_env (updateIdCafInfo non_cafs id))
updateTyThingIdInfos type_env cg_infos (AnId id) =
AnId (updateIdUnfolding type_env (updateIdInfo cg_infos id))
updateTyThingCafInfos _ _ other = other -- AConLike, ATyCon, ACoAxiom
updateTyThingIdInfos _ _ other = other -- AConLike, ATyCon, ACoAxiom
--------------------------------------------------------------------------------
-- Unfoldings
......@@ -95,13 +99,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 +125,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)
......
......@@ -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,38 @@ tcJoinInfo :: IfaceJoinInfo -> Maybe JoinArity
tcJoinInfo (IfaceJoinPoint ar) = Just ar
tcJoinInfo IfaceNotJoinPoint = Nothing
tcLFInfo :: IfaceLFInfo -> IfL LambdaFormInfo
tcLFInfo lfi = case lfi of
IfLFReEntrant rep_arity ->
-- LFReEntrant closures in interface files are guaranteed to
--
-- - Be top-level, as only top-level closures are exported.
-- - Have no free variables, as only non-top-level closures have free
-- variables
-- - Don't have ArgDescrs, as ArgDescr is used when generating code for
-- the closure
--
-- These invariants are checked when generating LFInfos in toIfaceLFInfo.
return (LFReEntrant TopLevel rep_arity True ArgUnknown)
IfLFThunk updatable mb_fun ->
-- LFThunk closure in interface files are guaranteed to
--
-- - Be top-level
-- - No have free variables
--
-- These invariants are checked when generating LFInfos in toIfaceLFInfo.
return (LFThunk TopLevel True updatable NonStandardThunk 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
......@@ -1508,7 +1544,7 @@ tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr)
Just expr -> mkFinalUnfolding dflags unf_src strict_sig expr
}
where
-- Strictness should occur before unfolding!
-- Strictness should occur before unfolding!
strict_sig = strictnessInfo info
tcUnfolding toplvl name _ _ (IfCompulsory if_expr)
......@@ -1583,6 +1619,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
{-
************************************************************************
* *
......
......@@ -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, ...