diff options
| author | Ömer Sinan Ağacan <omeragacan@gmail.com> | 2020-02-26 13:31:46 +0300 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-06-10 04:14:58 -0400 |
| commit | 7a737e898014d92bdbeed2e1cf5c35fc0a91a547 (patch) | |
| tree | a32caaed3dc85b853e0a0d9584a3938b00d4f0d2 | |
| parent | ccd6843d4a39920b4fa02badbe82e529390d4a74 (diff) | |
| download | haskell-7a737e898014d92bdbeed2e1cf5c35fc0a91a547.tar.gz | |
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)
| | GHC HEAD | This patch | Diff |
|-----|----------|------------|----------------|
| -O0 | 0:35.89 | 0:34.10 | -1.78s, -4.98% |
| -O1 | 2:24.01 | 2:23.62 | -0.39s, -0.27% |
| -O2 | 2:52.23 | 2:51.35 | -0.88s, -0.51% |
| | GHC HEAD | This patch | Diff |
|-----|-----------------|-----------------|----------------------------|
| -O0 | 54,843,608,416 | 54,878,769,544 | +35,161,128 bytes, +0.06% |
| -O1 | 227,136,076,400 | 227,569,045,168 | +432,968,768 bytes, +0.19% |
| -O2 | 266,147,063,296 | 266,749,643,440 | +602,580,144 bytes, +0.22% |
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 | 410,284,000 (910 samples) | 411,745,008 (906 samples) | +1,461,008 bytes, +0.35% |
| -O1 | 928,580,856 (2109 samples) | 943,506,552 (2103 samples) | +14,925,696 bytes, +1.60% |
| -O2 | 993,951,352 (2549 samples) | 1,010,156,328 (2545 samples) | +16,204,9760 bytes, +1.63% |
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
T9233
Co-authored-by: Andreas Klebinger <klebinger.andreas@gmx.at>
28 files changed, 580 insertions, 190 deletions
diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs index 3e997e8df7..1c6b09e669 100644 --- a/compiler/GHC/CoreToIface.hs +++ b/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 @@ -616,6 +618,31 @@ toIfaceVar v where name = idName v +--------------------- +toIfaceLFInfo :: Name -> LambdaFormInfo -> IfaceLFInfo +toIfaceLFInfo nm lfi = case lfi of + LFReEntrant top_lvl arity no_fvs _arg_descr -> + -- Exported LFReEntrant closures are top level, and top-level closures + -- don't have free variables + ASSERT2(isTopLevel top_lvl, ppr nm) + ASSERT2(no_fvs, ppr nm) + IfLFReEntrant arity + LFThunk top_lvl no_fvs updatable sfi mb_fun -> + -- Exported LFThunk closures are top level (which don't have free + -- variables) and non-standard (see cgTopRhsClosure) + 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): diff --git a/compiler/GHC/Driver/Hooks.hs b/compiler/GHC/Driver/Hooks.hs index 474b30aa77..3871fd5aa1 100644 --- a/compiler/GHC/Driver/Hooks.hs +++ b/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)) } diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 4c86f17ac1..b850502a8c 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/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 ) @@ -1384,7 +1385,7 @@ hscWriteIface dflags iface no_change mod_location = do -- | Compile to hard-code. hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath - -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], NonCaffySet) + -> 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. @@ -1443,11 +1444,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 @@ -1541,7 +1542,7 @@ doCodeGen :: HscEnv -> Module -> [TyCon] -> CollectedCCs -> [StgTopBinding] -> HpcInfo - -> IO (Stream IO CmmGroupSRTs NonCaffySet) + -> 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. @@ -1553,7 +1554,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 @@ -1572,10 +1573,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) $ diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index 9732dd9e4d..5d39436f3b 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -71,7 +71,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 @@ -1180,12 +1180,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] diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs index 89253a33c2..38e8e94be7 100644 --- a/compiler/GHC/Iface/Make.hs +++ b/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 @@ -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 NonCaffySet -> 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 NonCaffySet -> [IfaceDecl] -updateDeclCafInfos decls Nothing = decls -updateDeclCafInfos decls (Just (NonCaffySet non_cafs)) = map update_decl decls +updateDecl :: [IfaceDecl] -> Maybe CgInfos -> [IfaceDecl] +updateDecl decls Nothing = decls +updateDecl decls (Just CgInfos{ cgNonCafs = NonCaffySet 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 diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs index a1ed078b5f..84e96f0706 100644 --- a/compiler/GHC/Iface/Syntax.hs +++ b/compiler/GHC/Iface/Syntax.hs @@ -22,6 +22,7 @@ module GHC.Iface.Syntax ( IfaceAxBranch(..), IfaceTyConParent(..), IfaceCompleteMatch(..), + IfaceLFInfo(..), -- * Binding names IfaceTopBndr, @@ -67,11 +68,11 @@ import GHC.Utils.Binary import GHC.Data.BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue ) import GHC.Types.Var( VarBndr(..), binderVar, tyVarSpecToBinders ) 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 Control.Monad import System.IO.Unsafe @@ -114,7 +115,8 @@ data IfaceDecl = IfaceId { ifName :: IfaceTopBndr, ifType :: IfaceType, ifIdDetails :: IfaceIdDetails, - ifIdInfo :: IfaceIdInfo } + ifIdInfo :: IfaceIdInfo + } | IfaceData { ifName :: IfaceTopBndr, -- Type constructor ifBinders :: [IfaceTyConBinder], @@ -348,6 +350,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 +382,61 @@ 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 + +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 + +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 +1451,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 +1912,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 +2212,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 +2225,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 +2557,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 diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs index 4d64a5d579..2b7802a544 100644 --- a/compiler/GHC/Iface/Type.hs +++ b/compiler/GHC/Iface/Type.hs @@ -133,6 +133,9 @@ data IfaceOneShot -- See Note [Preserve OneShotInfo] in "GHC.Core.Tidy" = IfaceNoOneShot -- and Note [The oneShot function] in "GHC.Types.Id.Make" | IfaceOneShot +instance Outputable IfaceOneShot where + ppr IfaceNoOneShot = text "NoOneShotInfo" + ppr IfaceOneShot = text "OneShot" {- %************************************************************************ diff --git a/compiler/GHC/Iface/UpdateCafInfos.hs b/compiler/GHC/Iface/UpdateIdInfos.hs index 1abe2ee659..b4a6acfc67 100644 --- a/compiler/GHC/Iface/UpdateCafInfos.hs +++ b/compiler/GHC/Iface/UpdateIdInfos.hs @@ -1,38 +1,42 @@ {-# 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 - -> NonCaffySet -- ^ 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 _ (NonCaffySet 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 _ (NonCaffySet 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 _ (NonCaffySet 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 = NonCaffySet 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 "UpdateIdInfos.updateGlobalIds" $ text "Found a non-Id for Id Name" <+> ppr (varName var) $$ nest 4 (text "Id:" <+> ppr var $$ text "TyThing:" <+> ppr other) diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index b84fe1619d..7767f50e2e 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/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 @@ -1485,8 +1487,7 @@ tcIdInfo ignore_prags toplvl name ty info = do then vanillaIdInfo `setUnfoldingInfo` BootUnfolding else 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 @@ -1506,6 +1507,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) @@ -1518,6 +1522,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 @@ -1529,7 +1565,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) @@ -1604,6 +1640,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 + {- ************************************************************************ * * diff --git a/compiler/GHC/Runtime/Heap/Layout.hs b/compiler/GHC/Runtime/Heap/Layout.hs index 7436cbefd8..4f32cec7c4 100644 --- a/compiler/GHC/Runtime/Heap/Layout.hs +++ b/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" <+> diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs index 1a4bd47439..43b3cfc635 100644 --- a/compiler/GHC/StgToCmm.hs +++ b/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,23 @@ codeGen dflags this_mod data_tycons mapM_ (cg . cgDataCon) (tyConDataCons tycon) ; mapM_ do_tycon data_tycons + + ; cg_id_infos <- cgs_binds <$> liftIO (readIORef cgref) + + -- See Note [Conveying CAF-info and LFInfo between modules] in + -- GHC.StgToCmm.Types + ; let extractInfo info = (name, lf) + where + !name = idName (cg_id info) + !lf = cg_lf info + + !generatedInfo + | gopt Opt_OmitInterfacePragmas dflags + = emptyNameEnv + | otherwise + = mkNameEnv (Prelude.map extractInfo (eltsUFM cg_id_infos)) + + ; return generatedInfo } --------------------------------------------------------------- diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs index 2c1176c197..fc4b79d71f 100644 --- a/compiler/GHC/StgToCmm/Closure.hs +++ b/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,76 +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 - !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 ------------------------------------------------------ @@ -325,18 +256,27 @@ 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 arity True (panic "arg_descr") - - | otherwise - = mkLFArgument id -- Not sure of exact arity +mkLFImported id = + -- See Note [Conveying CAF-info and LFInfo between modules] in + -- GHC.StgToCmm.Types + case idLFInfo_maybe id of + Just lf_info -> + -- Use the LambdaFormInfo from the interface + lf_info + Nothing + -- Interface doesn't have a LambdaFormInfo, make a conservative one from + -- the type. + | 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 arity True ArgUnknown + + | otherwise + -> mkLFArgument id -- Not sure of exact arity where arity = idFunRepArity id diff --git a/compiler/GHC/StgToCmm/Types.hs b/compiler/GHC/StgToCmm/Types.hs new file mode 100644 index 0000000000..6d54cdfdaa --- /dev/null +++ b/compiler/GHC/StgToCmm/Types.hs @@ -0,0 +1,229 @@ +{-# 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 + +{- +Note [Conveying CAF-info and LFInfo between modules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Some information about an Id is generated in the code generator, and is not +available earlier. Namely: + +* CAF info. Code motion in Cmm or earlier phases may move references around so + we compute information about which bits of code refer to which CAF late in the + Cmm pipeline. + +* LambdaFormInfo. This records the details of a closure representation, + including + - the final arity (for functions) + - whether it is a data constructor, and if so its tag + +Collectively we call this CgInfo (see GHC.StgToCmm.Types). + +It's very useful for importing modules to have this information. We can always +make a conservative assumption, but that is bad: e.g. + +* For CAF info, if we know nothing we have to assume it is a CAF which bloats + the SRTs of the importing module. + + Conservative assumption here is made when creating new Ids. + +* For data constructors, we really like having well-tagged pointers. See #14677, + #16559, #15155, and wiki: commentary/rts/haskell-execution/pointer-tagging + + Conservative assumption here is made when we import an Id without a + LambdaFormInfo in the interface, in GHC.StgToCmm.Closure.mkLFImported. + +So we arrange to always serialise this information into the interface file. The +moving parts are: + +* We record the CgInfo in the IdInfo of the Id. + +* GHC.Driver.Pipeline: the call to updateModDetailsIdInfos augments the + ModDetails constructed at the end of the Core pipeline, with with CgInfo + gleaned from the back end. The hard work is done in GHC.Iface.UpdateIdInfos. + +* For ModIface we generate the final ModIface with CgInfo in + GHC.Iface.Make.mkFullIface. + +* We don't absolutely guarantee to serialise the CgInfo: we won't if you have + -fomit-interface-pragmas or -fno-code; and we won't read it in if you have + -fignore-interface-pragmas. (We could revisit this decision.) +-} + +-- | 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). +-- +-- See also Note [Conveying CAF-info and LFInfo between modules] above. +-- +data CgInfos = CgInfos + { cgNonCafs :: !NonCaffySet + -- ^ 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 + !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 rep fvs argdesc) = + text "LFReEntrant" <> brackets + (ppr top <+> 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 diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs index 598f42e366..4395ce7fd9 100644 --- a/compiler/GHC/Types/Id.hs +++ b/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, @@ -725,6 +726,15 @@ 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 idOccInfo id = occInfo (idInfo id) diff --git a/compiler/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs index 42a042d481..69a6eeeb2b 100644 --- a/compiler/GHC/Types/Id/Info.hs +++ b/compiler/GHC/Types/Id/Info.hs @@ -75,6 +75,10 @@ module GHC.Types.Id.Info ( ppCafInfo, mayHaveCafRefs, cafInfo, setCafInfo, + -- ** The LambdaFormInfo type + LambdaFormInfo(..), + lfInfo, setLFInfo, + -- ** Tick-box Info TickBoxOp(..), TickBoxId, @@ -109,6 +113,8 @@ import GHC.Utils.Misc import Data.Word import Data.Bits +import GHC.StgToCmm.Types (LambdaFormInfo (..)) + -- infixl so you can say (id `set` a `set` b) infixl 1 `setRuleInfo`, `setArityInfo`, @@ -263,13 +269,14 @@ data IdInfo -- freshly allocated constructor. demandInfo :: Demand, -- ^ ID demand information - bitfield :: {-# UNPACK #-} !BitField + bitfield :: {-# UNPACK #-} !BitField, -- ^ Bitfield packs CafInfo, OneShotInfo, arity info, LevityInfo, and -- call arity info in one 64-bit word. Packing these fields reduces size -- of `IdInfo` from 12 words to 7 words and reduces residency by almost -- 4% in some programs. See #17497 and associated MR. -- -- See documentation of the getters for what these packed fields mean. + lfInfo :: !(Maybe LambdaFormInfo) } -- | Encodes arities, OneShotInfo, CafInfo and LevityInfo. @@ -390,6 +397,9 @@ setCafInfo :: IdInfo -> CafInfo -> IdInfo setCafInfo info caf = info { bitfield = bitfieldSetCafInfo caf (bitfield info) } +setLFInfo :: IdInfo -> LambdaFormInfo -> IdInfo +setLFInfo info lf = info { lfInfo = Just lf } + setOneShotInfo :: IdInfo -> OneShotInfo -> IdInfo setOneShotInfo info lb = info { bitfield = bitfieldSetOneShotInfo lb (bitfield info) } @@ -419,7 +429,8 @@ vanillaIdInfo bitfieldSetCallArityInfo unknownArity $ bitfieldSetOneShotInfo NoOneShotInfo $ bitfieldSetLevityInfo NoLevityInfo $ - emptyBitField + emptyBitField, + lfInfo = Nothing } -- | More informative 'IdInfo' we can use when we know the 'Id' has no CAF references diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 78e94225ef..e3fb339d4d 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -241,7 +241,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 @@ -308,6 +308,7 @@ Library GHC.StgToCmm.Ticky GHC.StgToCmm.Utils GHC.StgToCmm.ExtCode + GHC.StgToCmm.Types GHC.Runtime.Heap.Layout GHC.Core.Opt.Arity GHC.Core.FVs diff --git a/testsuite/tests/codeGen/should_compile/Makefile b/testsuite/tests/codeGen/should_compile/Makefile index ead93e20cb..448331fc38 100644 --- a/testsuite/tests/codeGen/should_compile/Makefile +++ b/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 diff --git a/testsuite/tests/codeGen/should_compile/cg009/A.hs b/testsuite/tests/codeGen/should_compile/cg009/A.hs new file mode 100644 index 0000000000..caa017f78f --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/cg009/A.hs @@ -0,0 +1,5 @@ +module A where + +newtype A = A Int + +val = A 42 diff --git a/testsuite/tests/codeGen/should_compile/cg009/Main.hs b/testsuite/tests/codeGen/should_compile/cg009/Main.hs new file mode 100644 index 0000000000..7f68351e29 --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/cg009/Main.hs @@ -0,0 +1,7 @@ +module Main where + +import A + +main = return () + +a = val diff --git a/testsuite/tests/codeGen/should_compile/cg009/Makefile b/testsuite/tests/codeGen/should_compile/cg009/Makefile new file mode 100644 index 0000000000..33280ab07a --- /dev/null +++ b/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 diff --git a/testsuite/tests/codeGen/should_compile/cg009/all.T b/testsuite/tests/codeGen/should_compile/cg009/all.T new file mode 100644 index 0000000000..95080a6fd8 --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/cg009/all.T @@ -0,0 +1 @@ +test('cg009', [extra_files(['A.hs','Main.hs'])], makefile_test, ['cg009']) diff --git a/testsuite/tests/codeGen/should_compile/cg010/A.hs b/testsuite/tests/codeGen/should_compile/cg010/A.hs new file mode 100644 index 0000000000..1a4dee32ca --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/cg010/A.hs @@ -0,0 +1,4 @@ +module A where + +{-# NOINLINE val #-} +val = Just 42 diff --git a/testsuite/tests/codeGen/should_compile/cg010/Main.hs b/testsuite/tests/codeGen/should_compile/cg010/Main.hs new file mode 100644 index 0000000000..7f68351e29 --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/cg010/Main.hs @@ -0,0 +1,7 @@ +module Main where + +import A + +main = return () + +a = val diff --git a/testsuite/tests/codeGen/should_compile/cg010/Makefile b/testsuite/tests/codeGen/should_compile/cg010/Makefile new file mode 100644 index 0000000000..4e53d8b28f --- /dev/null +++ b/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 diff --git a/testsuite/tests/codeGen/should_compile/cg010/all.T b/testsuite/tests/codeGen/should_compile/cg010/all.T new file mode 100644 index 0000000000..7ce20471be --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/cg010/all.T @@ -0,0 +1 @@ +test('cg010', [extra_files(['A.hs','Main.hs'])], makefile_test, ['cg010']) diff --git a/testsuite/tests/codeGen/should_compile/cg010/cg010.stdout b/testsuite/tests/codeGen/should_compile/cg010/cg010.stdout new file mode 100644 index 0000000000..0ff17525d6 --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/cg010/cg010.stdout @@ -0,0 +1 @@ + const A.val_closure+2; diff --git a/testsuite/tests/simplCore/should_compile/Makefile b/testsuite/tests/simplCore/should_compile/Makefile index bc96b8f124..a1155d678e 100644 --- a/testsuite/tests/simplCore/should_compile/Makefile +++ b/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 diff --git a/testsuite/tests/simplCore/should_compile/T4201.stdout b/testsuite/tests/simplCore/should_compile/T4201.stdout index 9d13fc2b4d..ac8cb0b275 100644 --- a/testsuite/tests/simplCore/should_compile/T4201.stdout +++ b/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)] |