diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/GHC/CoreToIface.hs | 29 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Hooks.hs | 3 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Main.hs | 25 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Pipeline.hs | 10 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Make.hs | 37 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Syntax.hs | 73 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Type.hs | 3 | ||||
| -rw-r--r-- | compiler/GHC/Iface/UpdateIdInfos.hs (renamed from compiler/GHC/Iface/UpdateCafInfos.hs) | 71 | ||||
| -rw-r--r-- | compiler/GHC/IfaceToCore.hs | 48 | ||||
| -rw-r--r-- | compiler/GHC/Runtime/Heap/Layout.hs | 31 | ||||
| -rw-r--r-- | compiler/GHC/StgToCmm.hs | 24 | ||||
| -rw-r--r-- | compiler/GHC/StgToCmm/Closure.hs | 104 | ||||
| -rw-r--r-- | compiler/GHC/StgToCmm/Types.hs | 229 | ||||
| -rw-r--r-- | compiler/GHC/Types/Id.hs | 12 | ||||
| -rw-r--r-- | compiler/GHC/Types/Id/Info.hs | 15 | ||||
| -rw-r--r-- | compiler/ghc.cabal.in | 3 |
16 files changed, 531 insertions, 186 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 |