[Git][ghc/ghc][wip/js-th] 4 commits: More refactoring
Sylvain Henry (@hsyl20)
gitlab at gitlab.haskell.org
Fri Jan 20 15:05:07 UTC 2023
Sylvain Henry pushed to branch wip/js-th at Glasgow Haskell Compiler / GHC
Commits:
1942705b by Sylvain Henry at 2023-01-20T14:21:37+01:00
More refactoring
- - - - -
8a6cd713 by Sylvain Henry at 2023-01-20T14:21:49+01:00
Add jsLinkObjects to prepare for loading home-unit objects
- - - - -
9a47acf1 by Sylvain Henry at 2023-01-20T15:25:13+01:00
Allow getDeps to update module info during its traversal
- - - - -
b7049732 by Sylvain Henry at 2023-01-20T16:09:00+01:00
Load home unit dependencies too
- - - - -
3 changed files:
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Runtime/Interpreter/JS.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
Changes:
=====================================
compiler/GHC/Driver/Env.hs
=====================================
@@ -84,7 +84,6 @@ import GHC.Utils.Logger
import Data.IORef
import qualified Data.Set as Set
-import Data.Set (Set)
import GHC.Unit.Module.Graph
runHsc :: HscEnv -> Hsc a -> IO a
@@ -265,14 +264,6 @@ hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a]
hptAllThings extract hsc_env = concatMap (concatMap extract . eltsHpt . homeUnitEnv_hpt . snd)
(hugElts (hsc_HUG hsc_env))
--- | This function returns all the modules belonging to the home-unit that can
--- be reached by following the given dependencies. Additionally, if both the
--- boot module and the non-boot module can be reached, it only returns the
--- non-boot one.
-hptModulesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> Set ModNodeKeyWithUid
-hptModulesBelow hsc_env uid mn = moduleGraphModulesBelow (hsc_mod_graph hsc_env) uid mn
-
-
-- | Get things from modules "below" this one (in the dependency sense)
-- C.f Inst.hptInstances
hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> [a]
@@ -281,11 +272,12 @@ hptSomeThingsBelowUs extract include_hi_boot hsc_env uid mn
| otherwise
= let hug = hsc_HUG hsc_env
+ mg = hsc_mod_graph hsc_env
in
[ thing
|
-- Find each non-hi-boot module below me
- (ModNodeKeyWithUid (GWIB { gwib_mod = mod, gwib_isBoot = is_boot }) mod_uid) <- Set.toList (hptModulesBelow hsc_env uid mn)
+ (ModNodeKeyWithUid (GWIB { gwib_mod = mod, gwib_isBoot = is_boot }) mod_uid) <- Set.toList (moduleGraphModulesBelow mg uid mn)
, include_hi_boot || (is_boot == NotBoot)
-- unsavoury: when compiling the base package with --make, we
@@ -301,7 +293,7 @@ hptSomeThingsBelowUs extract include_hi_boot hsc_env uid mn
Nothing -> pprTrace "WARNING in hptSomeThingsBelowUs" msg mempty
msg = vcat [text "missing module" <+> ppr mod,
text "When starting from" <+> ppr mn,
- text "below:" <+> ppr (hptModulesBelow hsc_env uid mn),
+ text "below:" <+> ppr (moduleGraphModulesBelow mg uid mn),
text "Probable cause: out-of-date interface files"]
-- This really shouldn't happen, but see #962
, thing <- things
=====================================
compiler/GHC/Runtime/Interpreter/JS.hs
=====================================
@@ -9,6 +9,7 @@ module GHC.Runtime.Interpreter.JS
, jsLinkRts
, jsLinkInterp
, jsLinkObject
+ , jsLinkObjects
, jsLoadFile
, jsRunServer
-- * Reexported for convenience
@@ -200,10 +201,9 @@ jsLinkInterp logger tmpfs tmp_dir cfg unit_env inst = do
link_plan <- computeLinkDependencies cfg unit_env link_spec
jsLinkPlan logger tmpfs tmp_dir link_cfg cfg inst link_plan
-
--- | Link an object file using the given functions as roots
-jsLinkObject :: Logger -> TmpFs -> TempDir -> StgToJSConfig -> UnitEnv -> ExtInterpInstance JSInterpExtra -> FilePath -> [ExportedFun] -> IO ()
-jsLinkObject logger tmpfs tmp_dir cfg unit_env inst obj roots = do
+-- | Link object files
+jsLinkObjects :: Logger -> TmpFs -> TempDir -> StgToJSConfig -> UnitEnv -> ExtInterpInstance JSInterpExtra -> [FilePath] -> (ExportedFun -> Bool) -> IO ()
+jsLinkObjects logger tmpfs tmp_dir cfg unit_env inst objs is_root = do
let link_cfg = JSLinkConfig
{ lcNoStats = True -- we don't need the stats
@@ -214,16 +214,13 @@ jsLinkObject logger tmpfs tmp_dir cfg unit_env inst obj roots = do
, lcNoHsMain = True -- nor HsMain
}
- let is_root f = Set.member f (Set.fromList roots)
-
let units = preloadUnits (ue_units unit_env)
++ [thUnitId] -- don't forget TH which is an implicit dep
-
-- compute dependencies
let link_spec = LinkSpec
{ lks_unit_ids = units
- , lks_obj_files = [ObjFile obj]
+ , lks_obj_files = fmap ObjFile objs
, lks_obj_root_filter = is_root
, lks_extra_roots = mempty
, lks_extra_js = mempty
@@ -234,6 +231,15 @@ jsLinkObject logger tmpfs tmp_dir cfg unit_env inst obj roots = do
jsLinkPlan logger tmpfs tmp_dir link_cfg cfg inst link_plan
+
+-- | Link an object file using the given functions as roots
+jsLinkObject :: Logger -> TmpFs -> TempDir -> StgToJSConfig -> UnitEnv -> ExtInterpInstance JSInterpExtra -> FilePath -> [ExportedFun] -> IO ()
+jsLinkObject logger tmpfs tmp_dir cfg unit_env inst obj roots = do
+ let is_root f = Set.member f (Set.fromList roots)
+ let objs = [obj]
+ jsLinkObjects logger tmpfs tmp_dir cfg unit_env inst objs is_root
+
+
-- | Link the given link plan
--
-- Perform incremental linking by removing what is already linked from the plan
=====================================
compiler/GHC/StgToJS/Linker/Linker.hs
=====================================
@@ -48,6 +48,7 @@ import GHC.SysTools.Cpp
import GHC.SysTools
import GHC.Linker.Static.Utils (exeFileName)
+import GHC.Linker.Types (Unlinked(..), linkableUnlinked)
import GHC.StgToJS.Linker.Types
import GHC.StgToJS.Linker.Utils
@@ -63,6 +64,7 @@ import GHC.Unit.State
import GHC.Unit.Env
import GHC.Unit.Types
import GHC.Unit.Module (moduleStableString)
+import GHC.Unit.Home.ModInfo
import GHC.Utils.Outputable hiding ((<>))
import GHC.Utils.Panic
@@ -341,12 +343,45 @@ computeLinkDependencies cfg unit_env link_spec = do
-- compute dependencies
let block_info = objs_block_info `M.union` archives_block_info
dep_fun_roots = obj_roots `S.union` rts_wired_functions `S.union` extra_roots
- required_blocks = S.fromList (archives_required_blocks ++ objs_required_blocks)
- all_deps <- getDeps (fmap lbi_info block_info) dep_fun_roots required_blocks
+ -- read transitive dependencies
+ new_required_blocks_var <- newIORef []
+ let load_info mod = do
+ -- Adapted from the ugly code in GHC.Linker.Loader.getLinkDeps.
+ -- TODO: factorize the ugly code and reuse it.
+ case lookupHugByModule mod (ue_home_unit_graph unit_env) of
+ Nothing -> pprPanic "getDeps: Couldn't find home-module: " (pprModule mod)
+ Just mod_info -> case homeModInfoObject mod_info of
+ Nothing -> pprPanic "getDeps: Couldn't find object file for home-module: " (pprModule mod)
+ Just lnk -> case linkableUnlinked lnk of -- "Unlinked"? WTF?
+ [DotO p] -> do
+ (bis, req_b) <- loadObjBlockInfo [ObjFile 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])
+
+
+
+ -- required blocks have no dependencies, so don't have to use them as roots in
+ -- the traversal
+ (updated_block_info, transitive_deps) <- getDeps block_info load_info dep_fun_roots mempty
+
+ new_required_blocks <- readIORef new_required_blocks_var
+ let required_blocks = S.fromList $ mconcat
+ [ archives_required_blocks
+ , objs_required_blocks
+ , new_required_blocks
+ ]
+
+ let all_deps = S.union transitive_deps required_blocks
let plan = LinkPlan
- { lkp_block_info = block_info
+ { lkp_block_info = updated_block_info
, lkp_dep_blocks = all_deps
, lkp_archives = S.fromList dep_archives
, lkp_extra_js = S.fromList (lks_extra_js link_spec)
@@ -549,11 +584,14 @@ writeExterns out = writeFile (out </> "all.js.externs")
$ unpackFS rtsExterns
-- | Get all block dependencies for a given set of roots
-getDeps :: Map Module BlockInfo -- ^ Block info per module
- -> Set ExportedFun -- ^ start here
- -> Set BlockRef -- ^ and also link these
- -> IO (Set BlockRef)
-getDeps loaded_deps root_funs root_blocks = traverse_funs S.empty root_blocks (S.toList root_funs)
+--
+-- Returns the update block info map and the blocks.
+getDeps :: Map Module LocatedBlockInfo -- ^ Block info per module
+ -> (Module -> IO LocatedBlockInfo) -- ^ Used to load block info if missing
+ -> Set ExportedFun -- ^ start here
+ -> Set BlockRef -- ^ and also link these
+ -> IO (Map Module LocatedBlockInfo, Set BlockRef)
+getDeps init_infos load_info root_funs root_blocks = traverse_funs init_infos S.empty root_blocks (S.toList root_funs)
where
-- A block may depend on:
-- 1. other blocks from the same module
@@ -561,7 +599,7 @@ getDeps loaded_deps root_funs root_blocks = traverse_funs S.empty root_blocks (S
--
-- Process:
-- 1. We use the BlockInfos to find the block corresponding to every
- -- exported functions.
+ -- exported root functions.
--
-- 2. We had these blocks to the set of root_blocks if they aren't already
-- added to the result.
@@ -572,52 +610,67 @@ getDeps loaded_deps root_funs root_blocks = traverse_funs S.empty root_blocks (S
--
-- 4. back to 1
- traverse_blocks :: Set BlockRef -> Set BlockRef -> IO (Set BlockRef)
- traverse_blocks result open = case S.minView open of
- Nothing -> return result
+ lookup_info infos mod = case M.lookup mod infos of
+ Just info -> pure (infos, lbi_info info)
+ Nothing -> do
+ -- load info and update cache with it
+ info <- load_info mod
+ pure (M.insert mod info infos, lbi_info info)
+
+ traverse_blocks
+ :: Map Module LocatedBlockInfo
+ -> Set BlockRef
+ -> Set BlockRef
+ -> IO (Map Module LocatedBlockInfo, Set BlockRef)
+ traverse_blocks infos result open = case S.minView open of
+ Nothing -> return (infos, result)
Just (ref, open') -> do
let mod = block_ref_mod ref
- case M.lookup mod loaded_deps of
- Nothing -> pprPanic "getDeps.traverse_blocks: object file not loaded for: " (pprModule mod)
- Just info -> do
- let block = bi_block_deps info ! block_ref_idx ref
- result' = S.insert ref result
- to_block_ref i = BlockRef
- { block_ref_mod = mod
- , block_ref_idx = i
- }
- traverse_funs result'
- (addOpen result' open' $
- map to_block_ref (blockBlockDeps block)) (blockFunDeps block)
-
- traverse_funs :: Set BlockRef
- -> Set BlockRef
- -> [ExportedFun]
- -> IO (Set BlockRef)
- traverse_funs result open [] = traverse_blocks result open
- traverse_funs result open (f:fs) = do
+ !(infos',info) <- lookup_info infos mod
+ let block = bi_block_deps info ! block_ref_idx ref
+ result' = S.insert ref result
+ to_block_ref i = BlockRef
+ { block_ref_mod = mod
+ , block_ref_idx = i
+ }
+ traverse_funs infos' result'
+ (addOpen result' open' $
+ map to_block_ref (blockBlockDeps block)) (blockFunDeps block)
+
+ traverse_funs
+ :: Map Module LocatedBlockInfo
+ -> Set BlockRef
+ -> Set BlockRef
+ -> [ExportedFun]
+ -> IO (Map Module LocatedBlockInfo, Set BlockRef)
+ traverse_funs infos result open = \case
+ [] -> traverse_blocks infos result open
+ (f:fs) -> do
let mod = funModule f
-- lookup module block info for the module that exports the function
- case M.lookup mod loaded_deps of
- Nothing -> pprPanic "getDeps.traverse_funs: object file not loaded for: " $ pprModule mod
- Just info -> do
- -- lookup block index associated to the function in the block info
- case M.lookup f (bi_exports info) of
- Nothing -> pprPanic "exported function not found: " $ ppr f
- Just idx -> do
- let fun_block_ref = BlockRef
- { block_ref_mod = mod
- , block_ref_idx = idx
- }
- -- always add the module "global block" when we link a module
- let global_block_ref = BlockRef
- { block_ref_mod = mod
- , block_ref_idx = 0
- }
- traverse_funs result (addOpen result open [fun_block_ref,global_block_ref]) fs
-
- addOpen :: Set BlockRef -> Set BlockRef -> [BlockRef]
- -> Set BlockRef
+ !(infos',info) <- lookup_info infos mod
+ -- lookup block index associated to the function in the block info
+ case M.lookup f (bi_exports info) of
+ Nothing -> pprPanic "exported function not found: " $ ppr f
+ Just idx -> do
+ let fun_block_ref = BlockRef
+ { block_ref_mod = mod
+ , block_ref_idx = idx
+ }
+ -- always add the module "global block" when we link a module
+ let global_block_ref = BlockRef
+ { block_ref_mod = mod
+ , block_ref_idx = 0
+ }
+ traverse_funs infos' result (addOpen result open [fun_block_ref,global_block_ref]) fs
+
+ -- extend the open block set with new blocks that are not already in the
+ -- result block set nor in the open block set.
+ addOpen
+ :: Set BlockRef
+ -> Set BlockRef
+ -> [BlockRef]
+ -> Set BlockRef
addOpen result open new_blocks =
let alreadyLinked s = S.member s result || S.member s open
in open `S.union` S.fromList (filter (not . alreadyLinked) new_blocks)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9840d044dec76cd3a6fb34af0bb6121d7ce933b8...b70497329025ff3487c0f2ef199867e5c279f976
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9840d044dec76cd3a6fb34af0bb6121d7ce933b8...b70497329025ff3487c0f2ef199867e5c279f976
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/20230120/ecddf481/attachment-0001.html>
More information about the ghc-commits
mailing list