[Git][ghc/ghc][master] Linker: some refactoring to prepare for #24886
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri Aug 16 16:48:24 UTC 2024
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
4bee377c by Sylvain Henry at 2024-08-16T12:47:53-04:00
Linker: some refactoring to prepare for #24886
- Rename LoadedBCOs into LazyBCOs
- Bundle SptEntries with CompiledByteCode and removed [SptEntry] field
from the BCOs constructor
- Rename Linkable's LM constructor into Linkable: in the past we had LM
and LP for Module and Package, now we only have the former.
- Rename Unlinked into LinkablePart (and linkableUnlinked into
linkableParts)
- Use NonEmpty to encode invariant in Linkable's linkableParts type
- Add helpers: linkableLibs, linkableBCOs, etc.
- Add documentation
- Remove partial nameOfObject
- Rename nameOfObject_maybe into linkablePartPath
- Rename byteCodeOfObject into linkablePartAllBCOs.
- Refactor linkablePartAllBCOs to avoid a panic if a LazyBCO has a C
stub. Document the fact that LazyBCOs are returned in this case
(contrary to linkableBCOs which only returns non-lazy ones)
Refactoring done while trying to understand how to adapt the linker code
to support the JS backend too (cf #24886).
- - - - -
20 changed files:
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/HsToCore/Usage.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Linker/Types.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
- + compiler/GHC/Types/SptEntry.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Home/ModInfo.hs
- compiler/GHC/Unit/Module/WholeCoreBindings.hs
- compiler/ghc.cabal.in
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
Changes:
=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -28,6 +28,7 @@ import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Literal
import GHC.Types.Unique.DSet
+import GHC.Types.SptEntry
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -94,8 +95,9 @@ assembleBCOs
-> [TyCon]
-> AddrEnv
-> Maybe ModBreaks
+ -> [SptEntry]
-> IO CompiledByteCode
-assembleBCOs interp profile proto_bcos tycons top_strs modbreaks = do
+assembleBCOs interp profile proto_bcos tycons top_strs modbreaks spt_entries = do
-- TODO: the profile should be bundled with the interpreter: the rts ways are
-- fixed for an interpreter
itblenv <- mkITbls interp profile tycons
@@ -107,6 +109,7 @@ assembleBCOs interp profile proto_bcos tycons top_strs modbreaks = do
, bc_ffis = concatMap protoBCOFFIs proto_bcos
, bc_strs = top_strs
, bc_breaks = modbreaks
+ , bc_spt_entries = spt_entries
}
-- Note [Allocating string literals]
=====================================
compiler/GHC/ByteCode/Types.hs
=====================================
@@ -32,6 +32,7 @@ import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Utils.Outputable
import GHC.Builtin.PrimOps
+import GHC.Types.SptEntry
import GHC.Types.SrcLoc
import GHCi.BreakArray
import GHCi.RemoteTypes
@@ -54,12 +55,25 @@ import Language.Haskell.Syntax.Module.Name (ModuleName)
-- Compiled Byte Code
data CompiledByteCode = CompiledByteCode
- { bc_bcos :: FlatBag UnlinkedBCO -- Bunch of interpretable bindings
- , bc_itbls :: ItblEnv -- A mapping from DataCons to their itbls
- , bc_ffis :: [FFIInfo] -- ffi blocks we allocated
- , bc_strs :: AddrEnv -- malloc'd top-level strings
- , bc_breaks :: Maybe ModBreaks -- breakpoint info (Nothing if we're not
- -- creating breakpoints, for some reason)
+ { bc_bcos :: FlatBag UnlinkedBCO
+ -- ^ Bunch of interpretable bindings
+
+ , bc_itbls :: ItblEnv
+ -- ^ Mapping from DataCons to their info tables
+
+ , bc_ffis :: [FFIInfo]
+ -- ^ ffi blocks we allocated
+
+ , bc_strs :: AddrEnv
+ -- ^ top-level strings (heap allocated)
+
+ , bc_breaks :: Maybe ModBreaks
+ -- ^ breakpoint info (Nothing if breakpoints are disabled)
+
+ , bc_spt_entries :: ![SptEntry]
+ -- ^ Static pointer table entries which should be loaded along with the
+ -- BCOs. See Note [Grand plan for static forms] in
+ -- "GHC.Iface.Tidy.StaticPtrTable".
}
-- ToDo: we're not tracking strings that we malloc'd
newtype FFIInfo = FFIInfo (RemotePtr C_ffi_cif)
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -346,8 +346,7 @@ buildUnit session cid insts lunit = do
linkables = map (expectJust "bkp link" . homeModInfoObject)
. filter ((==HsSrcFile) . mi_hsc_src . hm_iface)
$ home_mod_infos
- getOfiles LM{ linkableUnlinked = us } = map nameOfObject (filter isObject us)
- obj_files = concatMap getOfiles linkables
+ obj_files = concatMap linkableFiles linkables
state = hsc_units hsc_env
let compat_fs = unitIdFS cid
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -944,7 +944,7 @@ checkObjects dflags mb_old_linkable summary = do
| obj_date >= if_date ->
case mb_old_linkable of
Just old_linkable
- | isObjectLinkable old_linkable, linkableTime old_linkable == obj_date
+ | linkableIsNativeCodeOnly old_linkable, linkableTime old_linkable == obj_date
-> return $ UpToDateItem old_linkable
_ -> UpToDateItem <$> findObjectLinkable this_mod obj_fn obj_date
_ -> return $ outOfDateItemBecause MissingObjectFile Nothing
@@ -956,7 +956,7 @@ checkByteCode :: ModIface -> ModSummary -> Maybe Linkable -> IO (MaybeValidated
checkByteCode iface mod_sum mb_old_linkable =
case mb_old_linkable of
Just old_linkable
- | not (isObjectLinkable old_linkable)
+ | not (linkableIsNativeCodeOnly old_linkable)
-> return $ (UpToDateItem old_linkable)
_ -> loadByteCode iface mod_sum
@@ -968,7 +968,7 @@ loadByteCode iface mod_sum = do
case mi_extra_decls iface of
Just extra_decls -> do
let fi = WholeCoreBindings extra_decls this_mod (ms_location mod_sum)
- return (UpToDateItem (LM if_date this_mod [CoreBindings fi]))
+ return (UpToDateItem (Linkable if_date this_mod (NE.singleton (CoreBindings fi))))
_ -> return $ outOfDateItemBecause MissingBytecode Nothing
--------------------------------------------------------------
-- Compilers
@@ -991,7 +991,7 @@ initModDetails hsc_env iface =
-- Hydrate any WholeCoreBindings linkables into BCOs
initWholeCoreBindings :: HscEnv -> ModIface -> ModDetails -> Linkable -> IO Linkable
-initWholeCoreBindings hsc_env mod_iface details (LM utc_time this_mod uls) = LM utc_time this_mod <$> mapM go uls
+initWholeCoreBindings hsc_env mod_iface details (Linkable utc_time this_mod uls) = Linkable utc_time this_mod <$> mapM go uls
where
go (CoreBindings fi) = do
let act hpt = addToHpt hpt (moduleName $ mi_module mod_iface)
@@ -1003,7 +1003,7 @@ initWholeCoreBindings hsc_env mod_iface details (LM utc_time this_mod uls) = LM
-- recompilation checking the bytecode will be generated (which slows things down a lot)
-- the laziness is OK because generateByteCode just depends on things already loaded
-- in the interface file.
- LoadedBCOs <$> (unsafeInterleaveIO $ do
+ LazyBCOs <$> (unsafeInterleaveIO $ do
core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckWholeCoreBindings types_var fi
-- MP: The NoStubs here is only from (I think) the TH `qAddForeignFilePath` feature but it's a bit unclear what to do
-- with these files, do we have to read and serialise the foreign file? I will leave it for now until someone
@@ -1990,7 +1990,7 @@ mkCgInteractiveGuts CgGuts{cg_module, cg_binds, cg_tycons, cg_foreign, cg_modBre
hscInteractive :: HscEnv
-> CgInteractiveGuts
-> ModLocation
- -> IO (Maybe FilePath, CompiledByteCode, [SptEntry])
+ -> IO (Maybe FilePath, CompiledByteCode) -- ^ .c stub path (if any) and ByteCode
hscInteractive hsc_env cgguts location = do
let dflags = hsc_dflags hsc_env
let logger = hsc_logger hsc_env
@@ -2028,18 +2028,19 @@ hscInteractive hsc_env cgguts location = do
let (stg_binds,_stg_deps) = unzip stg_binds_with_deps
----------------- Generate byte code ------------------
- comp_bc <- byteCodeGen hsc_env this_mod stg_binds data_tycons mod_breaks
+ comp_bc <- byteCodeGen hsc_env this_mod stg_binds data_tycons mod_breaks spt_entries
+
------------------ Create f-x-dynamic C-side stuff -----
(_istub_h_exists, istub_c_exists)
<- outputForeignStubs logger tmpfs dflags (hsc_units hsc_env) this_mod location foreign_stubs
- return (istub_c_exists, comp_bc, spt_entries)
+ return (istub_c_exists, comp_bc)
generateByteCode :: HscEnv
-> CgInteractiveGuts
-> ModLocation
- -> IO [Unlinked]
+ -> IO (NonEmpty LinkablePart)
generateByteCode hsc_env cgguts mod_location = do
- (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env cgguts mod_location
+ (hasStub, comp_bc) <- hscInteractive hsc_env cgguts mod_location
stub_o <- case hasStub of
Nothing -> return []
@@ -2047,8 +2048,7 @@ generateByteCode hsc_env cgguts mod_location = do
stub_o <- compileForeign hsc_env LangC stub_c
return [DotO stub_o]
- let hs_unlinked = [BCOs comp_bc spt_entries]
- return (hs_unlinked ++ stub_o)
+ return (BCOs comp_bc :| stub_o)
generateFreshByteCode :: HscEnv
-> ModuleName
@@ -2056,10 +2056,9 @@ generateFreshByteCode :: HscEnv
-> ModLocation
-> IO Linkable
generateFreshByteCode hsc_env mod_name cgguts mod_location = do
- ul <- generateByteCode hsc_env cgguts mod_location
- unlinked_time <- getCurrentTime
- let !linkable = LM unlinked_time (mkHomeModule (hsc_home_unit hsc_env) mod_name) ul
- return linkable
+ bco_time <- getCurrentTime
+ bco <- generateByteCode hsc_env cgguts mod_location
+ return $! Linkable bco_time (mkHomeModule (hsc_home_unit hsc_env) mod_name) bco
------------------------------
hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> FilePath -> IO (Maybe FilePath)
@@ -2381,7 +2380,9 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
let !CgGuts{ cg_module = this_mod,
cg_binds = core_binds,
cg_tycons = tycons,
- cg_modBreaks = mod_breaks } = tidy_cg
+ cg_modBreaks = mod_breaks,
+ cg_spt_entries = spt_entries
+ } = tidy_cg
!ModDetails { md_insts = cls_insts
, md_fam_insts = fam_insts } = mod_details
@@ -2413,7 +2414,7 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
{- Generate byte code -}
cbc <- liftIO $ byteCodeGen hsc_env this_mod
- stg_binds data_tycons mod_breaks
+ stg_binds data_tycons mod_breaks spt_entries
let src_span = srcLocSpan interactiveSrcLoc
_ <- liftIO $ loadDecls interp hsc_env src_span cbc
@@ -2690,7 +2691,9 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr = do
bcos <- byteCodeGen hsc_env
this_mod
stg_binds
- [] Nothing
+ []
+ Nothing -- modbreaks
+ [] -- spt entries
{- load it -}
(fv_hvs, mods_needed, units_needed) <- loadDecls interp hsc_env srcspan bcos
@@ -2749,7 +2752,7 @@ jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id = do
deps <- getLinkDeps link_opts interp pls srcspan needed_mods
-- We update the LinkerState even if the JS interpreter maintains its linker
-- state independently to load new objects here.
- let (objs, _bcos) = partition isObjectLinkable
+ let (objs, _bcos) = partition linkableIsNativeCodeOnly
(concatMap partitionLinkable (ldNeededLinkables deps))
let (objs_loaded', _new_objs) = rmDupLinkables (objs_loaded pls) objs
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -68,6 +68,7 @@ import GHC.Driver.Main
import GHC.Driver.MakeSem
import GHC.Parser.Header
+import GHC.ByteCode.Types
import GHC.Iface.Load ( cannotFindModule )
import GHC.IfaceToCore ( typecheckIface )
@@ -1322,10 +1323,9 @@ addSptEntries :: HscEnv -> Maybe Linkable -> IO ()
addSptEntries hsc_env mlinkable =
hscAddSptEntries hsc_env
[ spt
- | Just linkable <- [mlinkable]
- , unlinked <- linkableUnlinked linkable
- , BCOs _ spts <- pure unlinked
- , spt <- spts
+ | linkable <- maybeToList mlinkable
+ , bco <- linkableBCOs linkable
+ , spt <- bc_spt_entries bco
]
{- Note [-fno-code mode]
=====================================
compiler/GHC/Driver/Pipeline.hs
=====================================
@@ -117,6 +117,8 @@ import Control.Monad
import qualified Control.Monad.Catch as MC (handle)
import Data.Maybe
import qualified Data.Set as Set
+import qualified Data.List.NonEmpty as NE
+import Data.List.NonEmpty (NonEmpty(..))
import Data.Time ( getCurrentTime )
import GHC.Iface.Recomp
@@ -421,8 +423,7 @@ link' logger tmpfs fc dflags unit_env batch_attempt_linking mHscMessager hpt
return Succeeded
else do
- let getOfiles LM{ linkableUnlinked } = map nameOfObject (filter isObject linkableUnlinked)
- obj_files = concatMap getOfiles linkables
+ let obj_files = concatMap linkableObjs linkables
platform = targetPlatform dflags
arch_os = platformArchOS platform
exe_file = exeFileName arch_os staticLink (outputFile_ dflags)
@@ -815,9 +816,9 @@ hscGenBackendPipeline pipe_env hsc_env mod_sum result = do
-- No object file produced, bytecode or NoBackend
Nothing -> return mlinkable
Just o_fp -> do
- unlinked_time <- liftIO (liftIO getCurrentTime)
- final_unlinked <- DotO <$> use (T_MergeForeign pipe_env hsc_env o_fp fos)
- let !linkable = LM unlinked_time (ms_mod mod_sum) [final_unlinked]
+ part_time <- liftIO (liftIO getCurrentTime)
+ final_part <- DotO <$> use (T_MergeForeign pipe_env hsc_env o_fp fos)
+ let !linkable = Linkable part_time (ms_mod mod_sum) (NE.singleton final_part)
-- Add the object linkable to the potential bytecode linkable which was generated in HscBackend.
return (mlinkable { homeMod_object = Just linkable })
return (miface, final_linkable)
@@ -929,7 +930,7 @@ pipelineStart pipe_env hsc_env input_fn mb_phase =
as :: P m => Bool -> m (Maybe FilePath)
as use_cpp = asPipeline use_cpp pipe_env hsc_env Nothing input_fn
- objFromLinkable (_, homeMod_object -> Just (LM _ _ [DotO lnk])) = Just lnk
+ objFromLinkable (_, homeMod_object -> Just (Linkable _ _ (DotO lnk :| []))) = Just lnk
objFromLinkable _ = Nothing
fromPhase :: P m => Phase -> m (Maybe FilePath)
=====================================
compiler/GHC/HsToCore/Usage.hs
=====================================
@@ -42,6 +42,7 @@ import Data.List (sortBy)
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Set as Set
+import qualified Data.List.NonEmpty as NE
import GHC.Linker.Types
import GHC.Unit.Finder
@@ -171,14 +172,14 @@ mkObjectUsage pit plugins fc hug th_links_needed th_pkgs_needed = do
(plugins_links_needed, plugin_pkgs_needed) = loadedPluginDeps plugins
concat <$> sequence (map linkableToUsage ls ++ map librarySpecToUsage ds)
where
- linkableToUsage (LM _ m uls) = mapM (unlinkedToUsage m) uls
+ linkableToUsage (Linkable _ m uls) = mapM (partToUsage m) (NE.toList uls)
msg m = moduleNameString (moduleName m) ++ "[TH] changed"
fing mmsg fn = UsageFile (mkFastString fn) <$> lookupFileCache fc fn <*> pure mmsg
- unlinkedToUsage m ul =
- case nameOfObject_maybe ul of
+ partToUsage m part =
+ case linkablePartPath part of
Just fn -> fing (Just (msg m)) fn
Nothing -> do
-- This should only happen for home package things but oneshot puts
=====================================
compiler/GHC/Linker/Deps.hs
=====================================
@@ -293,13 +293,14 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
adjust_linkable lnk
| Just new_osuf <- maybe_normal_osuf = do
- new_uls <- mapM (adjust_ul new_osuf)
- (linkableUnlinked lnk)
- return lnk{ linkableUnlinked=new_uls }
+ new_parts <- mapM (adjust_part new_osuf)
+ (linkableParts lnk)
+ return lnk{ linkableParts=new_parts }
| otherwise =
return lnk
- adjust_ul new_osuf (DotO file) = do
+ adjust_part new_osuf part = case part of
+ DotO file -> do
massert (osuf `isSuffixOf` file)
let file_base = fromJust (stripExtension osuf file)
new_file = file_base <.> new_osuf
@@ -309,11 +310,11 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
text "cannot find object file "
<> quotes (text new_file) $$ while_linking_expr
else return (DotO new_file)
- adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp)
- adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp)
- adjust_ul _ l@(BCOs {}) = return l
- adjust_ul _ l at LoadedBCOs{} = return l
- adjust_ul _ (CoreBindings (WholeCoreBindings _ mod _)) = pprPanic "Unhydrated core bindings" (ppr mod)
+ DotA fp -> panic ("adjust_ul DotA " ++ show fp)
+ DotDLL fp -> panic ("adjust_ul DotDLL " ++ show fp)
+ BCOs {} -> pure part
+ LazyBCOs{} -> pure part
+ CoreBindings (WholeCoreBindings _ mod _) -> pprPanic "Unhydrated core bindings" (ppr mod)
{-
Note [Using Byte Code rather than Object Code for Template Haskell]
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -99,6 +99,8 @@ import Data.List (intercalate, isPrefixOf, nub, partition)
import Data.Maybe
import Control.Concurrent.MVar
import qualified Control.Monad.Catch as MC
+import qualified Data.List.NonEmpty as NE
+import Data.List.NonEmpty (NonEmpty(..))
import System.FilePath
import System.Directory
@@ -725,7 +727,7 @@ loadModuleLinkables :: Interp -> HscEnv -> LoaderState -> [Linkable] -> IO (Load
loadModuleLinkables interp hsc_env pls linkables
= mask_ $ do -- don't want to be interrupted by ^C in here
- let (objs, bcos) = partition isObjectLinkable
+ let (objs, bcos) = partition linkableIsNativeCodeOnly
(concatMap partitionLinkable linkables)
-- Load objects first; they can't depend on BCOs
@@ -740,15 +742,11 @@ loadModuleLinkables interp hsc_env pls linkables
-- HACK to support f-x-dynamic in the interpreter; no other purpose
partitionLinkable :: Linkable -> [Linkable]
-partitionLinkable li
- = let li_uls = linkableUnlinked li
- li_uls_obj = filter isObject li_uls
- li_uls_bco = filter isInterpretable li_uls
- in
- case (li_uls_obj, li_uls_bco) of
- (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj},
- li {linkableUnlinked=li_uls_bco}]
- _ -> [li]
+partitionLinkable li = case linkablePartitionParts li of
+ (o:os, bco:bcos) -> [ li { linkableParts = o :| os }
+ , li { linkableParts = bco :| bcos }
+ ]
+ _ -> [li]
linkableInSet :: Linkable -> LinkableSet -> Bool
linkableInSet l objs_loaded =
@@ -776,8 +774,7 @@ loadObjects
loadObjects interp hsc_env pls objs = do
let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
pls1 = pls { objs_loaded = objs_loaded' }
- unlinkeds = concatMap linkableUnlinked new_objs
- wanted_objs = map nameOfObject unlinkeds
+ wanted_objs = concatMap linkableFiles new_objs
if interpreterDynamic interp
then do pls2 <- dynLoadObjs interp hsc_env pls1 wanted_objs
@@ -893,11 +890,12 @@ dynLinkBCOs interp pls bcos = do
let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
pls1 = pls { bcos_loaded = bcos_loaded' }
- unlinkeds :: [Unlinked]
- unlinkeds = concatMap linkableUnlinked new_bcos
+
+ parts :: [LinkablePart]
+ parts = concatMap (NE.toList . linkableParts) new_bcos
cbcs :: [CompiledByteCode]
- cbcs = concatMap byteCodeOfObject unlinkeds
+ cbcs = concatMap linkablePartAllBCOs parts
le1 = linker_env pls
@@ -1004,7 +1002,7 @@ unload_wkr interp keep_linkables pls at LoaderState{..} = do
-- we're unloading some code. -fghci-leak-check with the tests in
-- testsuite/ghci can detect space leaks here.
- let (objs_to_keep', bcos_to_keep') = partition isObjectLinkable keep_linkables
+ let (objs_to_keep', bcos_to_keep') = partition linkableIsNativeCodeOnly keep_linkables
objs_to_keep = mkLinkableSet objs_to_keep'
bcos_to_keep = mkLinkableSet bcos_to_keep'
@@ -1045,9 +1043,9 @@ unload_wkr interp keep_linkables pls at LoaderState{..} = do
-- not much benefit.
| otherwise
- = mapM_ (unloadObj interp) [f | DotO f <- linkableUnlinked lnk]
+ = mapM_ (unloadObj interp) (linkableObjs lnk)
-- The components of a BCO linkable may contain
- -- dot-o files. Which is very confusing.
+ -- dot-o files (generated from C stubs).
--
-- But the BCO parts can be unlinked just by
-- letting go of them (plus of course depopulating
=====================================
compiler/GHC/Linker/Types.hs
=====================================
@@ -1,3 +1,6 @@
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE LambdaCase #-}
+
-----------------------------------------------------------------------------
--
-- Types for the linkers and the loader
@@ -5,7 +8,6 @@
-- (c) The University of Glasgow 2019
--
-----------------------------------------------------------------------------
-{-# LANGUAGE TypeApplications #-}
module GHC.Linker.Types
( Loader (..)
, LoaderState (..)
@@ -16,47 +18,54 @@ module GHC.Linker.Types
, ClosureEnv
, emptyClosureEnv
, extendClosureEnv
- , Linkable(..)
, LinkableSet
, mkLinkableSet
, unionLinkableSet
, ObjFile
- , Unlinked(..)
, SptEntry(..)
- , isObjectLinkable
- , linkableObjs
- , isObject
- , nameOfObject
- , nameOfObject_maybe
- , isInterpretable
- , byteCodeOfObject
, LibrarySpec(..)
, LoadedPkgInfo(..)
, PkgsLoaded
+
+ -- * Linkable
+ , Linkable(..)
+ , LinkablePart(..)
+ , linkableIsNativeCodeOnly
+ , linkableObjs
+ , linkableLibs
+ , linkableFiles
+ , linkableBCOs
+ , linkableNativeParts
+ , linkablePartitionParts
+ , linkablePartPath
+ , linkablePartAllBCOs
+ , isNativeCode
+ , isNativeLib
+ , isInterpretable
)
where
import GHC.Prelude
import GHC.Unit ( UnitId, Module )
import GHC.ByteCode.Types ( ItblEnv, AddrEnv, CompiledByteCode )
-import GHC.Fingerprint.Type ( Fingerprint )
import GHCi.RemoteTypes ( ForeignHValue, RemotePtr )
import GHCi.Message ( LoadedDLL )
-import GHC.Types.Var ( Id )
import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnvList, filterNameEnv )
import GHC.Types.Name ( Name )
+import GHC.Types.SptEntry
import GHC.Utils.Outputable
-import GHC.Utils.Panic
import Control.Concurrent.MVar
import Data.Time ( UTCTime )
-import Data.Maybe
import GHC.Unit.Module.Env
import GHC.Types.Unique.DSet
import GHC.Types.Unique.DFM
import GHC.Unit.Module.WholeCoreBindings
+import Data.List.NonEmpty (NonEmpty)
+import Data.Maybe (mapMaybe)
+import qualified Data.List.NonEmpty as NE
{- **********************************************************************
@@ -162,7 +171,7 @@ data LinkerEnv = LinkerEnv
, itbl_env :: !ItblEnv
-- ^ The current global mapping from RdrNames of DataCons to
-- info table addresses.
- -- When a new Unlinked is linked into the running image, or an existing
+ -- When a new LinkablePart is linked into the running image, or an existing
-- module in the image is replaced, the itbl_env must be updated
-- appropriately.
@@ -208,15 +217,17 @@ instance Outputable LoadedPkgInfo where
-- | Information we can use to dynamically link modules into the compiler
-data Linkable = LM {
- linkableTime :: !UTCTime, -- ^ Time at which this linkable was built
- -- (i.e. when the bytecodes were produced,
- -- or the mod date on the files)
- linkableModule :: !Module, -- ^ The linkable module itself
- linkableUnlinked :: [Unlinked]
- -- ^ Those files and chunks of code we have yet to link.
- --
- -- INVARIANT: A valid linkable always has at least one 'Unlinked' item.
+data Linkable = Linkable
+ { linkableTime :: !UTCTime
+ -- ^ Time at which this linkable was built
+ -- (i.e. when the bytecodes were produced,
+ -- or the mod date on the files)
+
+ , linkableModule :: !Module
+ -- ^ The linkable module itself
+
+ , linkableParts :: NonEmpty LinkablePart
+ -- ^ Files and chunks of code to link.
}
type LinkableSet = ModuleEnv Linkable
@@ -224,6 +235,9 @@ type LinkableSet = ModuleEnv Linkable
mkLinkableSet :: [Linkable] -> LinkableSet
mkLinkableSet ls = mkModuleEnv [(linkableModule l, l) | l <- ls]
+-- | Union of LinkableSets.
+--
+-- In case of conflict, keep the most recent Linkable (as per linkableTime)
unionLinkableSet :: LinkableSet -> LinkableSet -> LinkableSet
unionLinkableSet = plusModuleEnv_C go
where
@@ -232,85 +246,122 @@ unionLinkableSet = plusModuleEnv_C go
| otherwise = l2
instance Outputable Linkable where
- ppr (LM when_made mod unlinkeds)
- = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod)
- $$ nest 3 (ppr unlinkeds)
+ ppr (Linkable when_made mod parts)
+ = (text "Linkable" <+> parens (text (show when_made)) <+> ppr mod)
+ $$ nest 3 (ppr parts)
type ObjFile = FilePath
-- | Objects which have yet to be linked by the compiler
-data Unlinked
- = DotO ObjFile -- ^ An object file (.o)
- | DotA FilePath -- ^ Static archive file (.a)
- | DotDLL FilePath -- ^ Dynamically linked library file (.so, .dll, .dylib)
- | CoreBindings WholeCoreBindings -- ^ Serialised core which we can turn into BCOs (or object files), or used by some other backend
- -- See Note [Interface Files with Core Definitions]
- | LoadedBCOs [Unlinked] -- ^ A list of BCOs, but hidden behind extra indirection to avoid
- -- being too strict.
+data LinkablePart
+ = DotO ObjFile
+ -- ^ An object file (.o)
+
+ | DotA FilePath
+ -- ^ Static archive file (.a)
+
+ | DotDLL FilePath
+ -- ^ Dynamically linked library file (.so, .dll, .dylib)
+
+ | CoreBindings WholeCoreBindings
+ -- ^ Serialised core which we can turn into BCOs (or object files), or
+ -- used by some other backend See Note [Interface Files with Core
+ -- Definitions]
+
+ | LazyBCOs (NonEmpty LinkablePart)
+ -- ^ Some BCOs generated on-demand when forced. This is used for
+ -- WholeCoreBindings, see Note [Interface Files with Core Definitions]
+ --
+ -- We use `NonEmpty LinkablePart` instead of `CompiledByteCode` because the list
+ -- also contains the stubs objects (DotO) for the BCOs.
+
| BCOs CompiledByteCode
- [SptEntry] -- ^ A byte-code object, lives only in memory. Also
- -- carries some static pointer table entries which
- -- should be loaded along with the BCOs.
- -- See Note [Grand plan for static forms] in
- -- "GHC.Iface.Tidy.StaticPtrTable".
-
-instance Outputable Unlinked where
- ppr (DotO path) = text "DotO" <+> text path
- ppr (DotA path) = text "DotA" <+> text path
- ppr (DotDLL path) = text "DotDLL" <+> text path
- ppr (BCOs bcos spt) = text "BCOs" <+> ppr bcos <+> ppr spt
- ppr (LoadedBCOs{}) = text "LoadedBCOs"
- ppr (CoreBindings {}) = text "FI"
-
--- | An entry to be inserted into a module's static pointer table.
--- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable".
-data SptEntry = SptEntry Id Fingerprint
-
-instance Outputable SptEntry where
- ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr
-
-
-isObjectLinkable :: Linkable -> Bool
-isObjectLinkable l = not (null unlinked) && all isObject unlinked
- where unlinked = linkableUnlinked l
- -- A linkable with no Unlinked's is treated as a BCO. We can
- -- generate a linkable with no Unlinked's as a result of
- -- compiling a module in NoBackend mode, and this choice
- -- happens to work well with checkStability in module GHC.
+ -- ^ A byte-code object, lives only in memory.
+
+instance Outputable LinkablePart where
+ ppr (DotO path) = text "DotO" <+> text path
+ ppr (DotA path) = text "DotA" <+> text path
+ ppr (DotDLL path) = text "DotDLL" <+> text path
+ ppr (BCOs bco) = text "BCOs" <+> ppr bco
+ ppr (LazyBCOs{}) = text "LazyBCOs"
+ ppr (CoreBindings {}) = text "CoreBindings"
+-- | Return true if the linkable only consists of native code (no BCO)
+linkableIsNativeCodeOnly :: Linkable -> Bool
+linkableIsNativeCodeOnly l = all isNativeCode (NE.toList (linkableParts l))
+
+-- | List the BCOs parts of a linkable.
+--
+-- This excludes the LazyBCOs and the CoreBindings parts
+linkableBCOs :: Linkable -> [CompiledByteCode]
+linkableBCOs l = [ cbc | BCOs cbc <- NE.toList (linkableParts l) ]
+
+-- | List the native linkable parts (.o/.so/.dll) of a linkable
+linkableNativeParts :: Linkable -> [LinkablePart]
+linkableNativeParts l = NE.filter isNativeCode (linkableParts l)
+
+-- | Split linkable parts into (native code parts, BCOs parts)
+linkablePartitionParts :: Linkable -> ([LinkablePart],[LinkablePart])
+linkablePartitionParts l = NE.partition isNativeCode (linkableParts l)
+
+-- | List the native objects (.o) of a linkable
linkableObjs :: Linkable -> [FilePath]
-linkableObjs l = [ f | DotO f <- linkableUnlinked l ]
+linkableObjs l = [ f | DotO f <- NE.toList (linkableParts l) ]
+
+-- | List the native libraries (.so/.dll) of a linkable
+linkableLibs :: Linkable -> [LinkablePart]
+linkableLibs l = NE.filter isNativeLib (linkableParts l)
+
+-- | List the paths of the native objects and libraries (.o/.so/.dll)
+linkableFiles :: Linkable -> [FilePath]
+linkableFiles l = mapMaybe linkablePartPath (NE.toList (linkableParts l))
-------------------------------------------
--- | Is this an actual file on disk we can link in somehow?
-isObject :: Unlinked -> Bool
-isObject (DotO _) = True
-isObject (DotA _) = True
-isObject (DotDLL _) = True
-isObject _ = False
+-- | Is the part a native object or library? (.o/.so/.dll)
+isNativeCode :: LinkablePart -> Bool
+isNativeCode = \case
+ DotO {} -> True
+ DotA {} -> True
+ DotDLL {} -> True
+ BCOs {} -> False
+ LazyBCOs{} -> False
+ CoreBindings {} -> False
+
+-- | Is the part a native library? (.so/.dll)
+isNativeLib :: LinkablePart -> Bool
+isNativeLib = \case
+ DotO {} -> False
+ DotA {} -> True
+ DotDLL {} -> True
+ BCOs {} -> False
+ LazyBCOs{} -> False
+ CoreBindings {} -> False
-- | Is this a bytecode linkable with no file on disk?
-isInterpretable :: Unlinked -> Bool
-isInterpretable = not . isObject
-
-nameOfObject_maybe :: Unlinked -> Maybe FilePath
-nameOfObject_maybe (DotO fn) = Just fn
-nameOfObject_maybe (DotA fn) = Just fn
-nameOfObject_maybe (DotDLL fn) = Just fn
-nameOfObject_maybe (CoreBindings {}) = Nothing
-nameOfObject_maybe (LoadedBCOs{}) = Nothing
-nameOfObject_maybe (BCOs {}) = Nothing
-
--- | Retrieve the filename of the linkable if possible. Panic if it is a byte-code object
-nameOfObject :: Unlinked -> FilePath
-nameOfObject o = fromMaybe (pprPanic "nameOfObject" (ppr o)) (nameOfObject_maybe o)
-
--- | Retrieve the compiled byte-code if possible. Panic if it is a file-based linkable
-byteCodeOfObject :: Unlinked -> [CompiledByteCode]
-byteCodeOfObject (BCOs bc _) = [bc]
-byteCodeOfObject (LoadedBCOs ul) = concatMap byteCodeOfObject ul
-byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other)
+isInterpretable :: LinkablePart -> Bool
+isInterpretable = not . isNativeCode
+
+-- | Get the FilePath of linkable part (if applicable)
+linkablePartPath :: LinkablePart -> Maybe FilePath
+linkablePartPath = \case
+ DotO fn -> Just fn
+ DotA fn -> Just fn
+ DotDLL fn -> Just fn
+ CoreBindings {} -> Nothing
+ LazyBCOs {} -> Nothing
+ BCOs {} -> Nothing
+
+-- | Retrieve the compiled byte-code from the linkable part.
+--
+-- Contrary to linkableBCOs, this includes byte-code from LazyBCOs.
+--
+-- Warning: this may force byte-code for LazyBCOs.
+linkablePartAllBCOs :: LinkablePart -> [CompiledByteCode]
+linkablePartAllBCOs = \case
+ BCOs bco -> [bco]
+ LazyBCOs ps -> concatMap linkablePartAllBCOs (NE.toList ps)
+ _ -> []
{- **********************************************************************
=====================================
compiler/GHC/Runtime/Interpreter.hs
=====================================
@@ -685,15 +685,11 @@ fromEvalResult (EvalSuccess a) = return a
getModBreaks :: HomeModInfo -> ModBreaks
getModBreaks hmi
| Just linkable <- homeModInfoByteCode hmi,
- [cbc] <- mapMaybe onlyBCOs $ linkableUnlinked linkable
+ -- The linkable may have 'DotO's as well; only consider BCOs. See #20570.
+ [cbc] <- linkableBCOs linkable
= fromMaybe emptyModBreaks (bc_breaks cbc)
| otherwise
= emptyModBreaks -- probably object code
- where
- -- The linkable may have 'DotO's as well; only consider BCOs. See #20570.
- onlyBCOs :: Unlinked -> Maybe CompiledByteCode
- onlyBCOs (BCOs cbc _) = Just cbc
- onlyBCOs _ = Nothing
-- | Interpreter uses Profiling way
interpreterProfiled :: Interp -> Bool
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -66,6 +66,7 @@ import GHC.Data.OrdList
import GHC.Data.Maybe
import GHC.Types.Name.Env (mkNameEnv)
import GHC.Types.Tickish
+import GHC.Types.SptEntry
import Data.List ( genericReplicate, genericLength, intersperse
, partition, scanl', sortBy, zip4, zip6 )
@@ -99,8 +100,9 @@ byteCodeGen :: HscEnv
-> [CgStgTopBinding]
-> [TyCon]
-> Maybe ModBreaks
+ -> [SptEntry]
-> IO CompiledByteCode
-byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
+byteCodeGen hsc_env this_mod binds tycs mb_modBreaks spt_entries
= withTiming logger
(text "GHC.StgToByteCode"<+>brackets (ppr this_mod))
(const ()) $ do
@@ -127,10 +129,10 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
"Proto-BCOs" FormatByteCode
(vcat (intersperse (char ' ') (map ppr $ elemsFlatBag proto_bcos)))
- cbc <- assembleBCOs interp profile proto_bcos tycs stringPtrs
- (case modBreaks of
+ let mod_breaks = case modBreaks of
Nothing -> Nothing
- Just mb -> Just mb{ modBreaks_breakInfo = breakInfo })
+ Just mb -> Just mb{ modBreaks_breakInfo = breakInfo }
+ cbc <- assembleBCOs interp profile proto_bcos tycs stringPtrs mod_breaks spt_entries
-- Squash space leaks in the CompiledByteCode. This is really
-- important, because when loading a set of modules into GHCi
=====================================
compiler/GHC/StgToJS/Linker/Linker.hs
=====================================
@@ -56,7 +56,7 @@ import GHC.SysTools.Cpp
import GHC.SysTools
import GHC.Linker.Static.Utils (exeFileName)
-import GHC.Linker.Types (Unlinked(..), linkableUnlinked)
+import GHC.Linker.Types (linkableObjs)
import GHC.Linker.External
import GHC.StgToJS.Linker.Types
@@ -506,17 +506,13 @@ computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache ar_cache
Nothing -> pprPanic "getDeps: Couldn't find object file for home-module: " (pprModule mod)
Just lnk -> pure lnk
- case linkableUnlinked linkable of
- [DotO p] -> do
- (bis, req_b) <- loadObjBlockInfo [p]
- -- Store new required blocks in IORef
- modifyIORef new_required_blocks_var ((++) req_b)
- case M.lookup mod bis of
- Nothing -> pprPanic "getDeps: Didn't load any block info for home-module: " (pprModule mod)
- Just bi -> pure bi
- ul -> pprPanic "getDeps: Unrecognized linkable for home-module: "
- (vcat [ pprModule mod
- , ppr ul])
+ -- load block infos from the object files
+ (bis, req_b) <- loadObjBlockInfo (linkableObjs linkable)
+ -- Store new required blocks in IORef
+ modifyIORef new_required_blocks_var ((++) req_b)
+ case M.lookup mod bis of
+ Nothing -> pprPanic "getDeps: Didn't load any block info for home-module: " (pprModule mod)
+ Just bi -> pure bi
-- required blocks have no dependencies, so don't have to use them as roots in
-- the traversal
=====================================
compiler/GHC/Types/SptEntry.hs
=====================================
@@ -0,0 +1,17 @@
+module GHC.Types.SptEntry
+ ( SptEntry(..)
+ )
+where
+
+import GHC.Types.Var ( Id )
+import GHC.Fingerprint.Type ( Fingerprint )
+import GHC.Utils.Outputable
+
+-- | An entry to be inserted into a module's static pointer table.
+-- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable".
+data SptEntry = SptEntry Id Fingerprint
+
+instance Outputable SptEntry where
+ ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr
+
+
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -68,6 +68,7 @@ import GHC.Driver.Env
import GHC.Driver.Config.Finder
import qualified Data.Set as Set
import qualified System.OsPath as OsPath
+import qualified Data.List.NonEmpty as NE
type FileExt = OsString -- Filename extension
type BaseName = OsPath -- Basename of file
@@ -747,7 +748,7 @@ findObjectLinkableMaybe mod locn
-- Make an object linkable when we know the object file exists, and we know
-- its modification time.
findObjectLinkable :: Module -> FilePath -> UTCTime -> IO Linkable
-findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn])
+findObjectLinkable mod obj_fn obj_time = return (Linkable obj_time mod (NE.singleton (DotO obj_fn)))
-- We used to look for _stub.o files here, but that was a bug (#706)
-- Now GHC merges the stub.o into the main .o (#3687)
=====================================
compiler/GHC/Unit/Home/ModInfo.hs
=====================================
@@ -35,7 +35,7 @@ import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModDetails
import GHC.Unit.Module
-import GHC.Linker.Types ( Linkable(..), isObjectLinkable )
+import GHC.Linker.Types ( Linkable(..), linkableIsNativeCodeOnly )
import GHC.Types.Unique
import GHC.Types.Unique.DFM
@@ -91,17 +91,17 @@ instance Outputable HomeModLinkable where
justBytecode :: Linkable -> HomeModLinkable
justBytecode lm =
- assertPpr (not (isObjectLinkable lm)) (ppr lm)
+ assertPpr (not (linkableIsNativeCodeOnly lm)) (ppr lm)
$ emptyHomeModInfoLinkable { homeMod_bytecode = Just lm }
justObjects :: Linkable -> HomeModLinkable
justObjects lm =
- assertPpr (isObjectLinkable lm) (ppr lm)
+ assertPpr (linkableIsNativeCodeOnly lm) (ppr lm)
$ emptyHomeModInfoLinkable { homeMod_object = Just lm }
bytecodeAndObjects :: Linkable -> Linkable -> HomeModLinkable
bytecodeAndObjects bc o =
- assertPpr (not (isObjectLinkable bc) && isObjectLinkable o) (ppr bc $$ ppr o)
+ assertPpr (not (linkableIsNativeCodeOnly bc) && linkableIsNativeCodeOnly o) (ppr bc $$ ppr o)
(HomeModLinkable (Just bc) (Just o))
=====================================
compiler/GHC/Unit/Module/WholeCoreBindings.hs
=====================================
@@ -24,14 +24,14 @@ The lifecycle of a WholeCoreBindings typically proceeds as follows:
the WholeCoreBindings into a proper Linkable (if we ever do that). The CoreBindings constructor also
allows us to convert the WholeCoreBindings into multiple different linkables if we so desired.
-2. `initWholeCoreBindings` turns a WholeCoreBindings into a proper BCO linkable. This step combines together
+2. `initWholeCoreBindings` turns a WholeCoreBindings into a proper BCOs linkable. This step combines together
all the necessary information from a ModIface, ModDetails and WholeCoreBindings in order to
- create the linkable. The linkable created is a "LoadedBCOs" linkable, which
- was introduced just for initWholeCoreBindings, so that the bytecode can be generated lazilly.
+ create the linkable. The linkable created is a "LazyBCOs" linkable, which
+ was introduced just for initWholeCoreBindings, so that the bytecode can be generated lazily.
Using the `BCOs` constructor directly here leads to the bytecode being forced
too eagerly.
-3. Then when bytecode is needed, the LoadedBCOs value is inspected and unpacked and
+3. Then when bytecode is needed, the LazyBCOs value is inspected and unpacked and
the linkable is used as before.
The flag `-fwrite-if-simplified-core` determines whether the extra information is written
=====================================
compiler/ghc.cabal.in
=====================================
@@ -889,6 +889,7 @@ Library
GHC.Types.SourceError
GHC.Types.SourceFile
GHC.Types.SourceText
+ GHC.Types.SptEntry
GHC.Types.SrcLoc
GHC.Types.Target
GHC.Types.Tickish
=====================================
testsuite/tests/count-deps/CountDepsAst.stdout
=====================================
@@ -172,6 +172,7 @@ GHC.Types.RepType
GHC.Types.SafeHaskell
GHC.Types.SourceFile
GHC.Types.SourceText
+GHC.Types.SptEntry
GHC.Types.SrcLoc
GHC.Types.Tickish
GHC.Types.TyThing
=====================================
testsuite/tests/count-deps/CountDepsParser.stdout
=====================================
@@ -192,6 +192,7 @@ GHC.Types.RepType
GHC.Types.SafeHaskell
GHC.Types.SourceFile
GHC.Types.SourceText
+GHC.Types.SptEntry
GHC.Types.SrcLoc
GHC.Types.Target
GHC.Types.Tickish
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4bee377c15f53c7cb7ff7d04ad7855c4bb9ac92c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4bee377c15f53c7cb7ff7d04ad7855c4bb9ac92c
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240816/486b415d/attachment-0001.html>
More information about the ghc-commits
mailing list