[Git][ghc/ghc][wip/js-th] Fix one-shot linking for Template Haskell in the JS interpreter
Luite Stegeman (@luite)
gitlab at gitlab.haskell.org
Mon Jan 30 13:05:33 UTC 2023
Luite Stegeman pushed to branch wip/js-th at Glasgow Haskell Compiler / GHC
Commits:
a1bb05bf by Luite Stegeman at 2023-01-30T22:04:15+09:00
Fix one-shot linking for Template Haskell in the JS interpreter
- - - - -
6 changed files:
- compiler/GHC.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Runtime/Interpreter/JS.hs
- compiler/GHC/Runtime/Interpreter/Types.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/StgToJS/Linker/Types.hs
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -702,13 +702,15 @@ setTopSessionDynFlags dflags = do
s <- liftIO $ newMVar InterpPending
loader <- liftIO Loader.uninitializedLoader
let cfg = JSInterpConfig
- { jsInterpNodeConfig = defaultNodeJsSettings
- , jsInterpScript = topDir dflags </> "ghc-interp.js"
- , jsInterpTmpFs = hsc_tmpfs hsc_env
- , jsInterpTmpDir = tmpDir dflags
- , jsInterpLogger = hsc_logger hsc_env
- , jsInterpCodegenCfg = initStgToJSConfig dflags
- , jsInterpUnitEnv = hsc_unit_env hsc_env
+ { jsInterpNodeConfig = defaultNodeJsSettings
+ , jsInterpScript = topDir dflags </> "ghc-interp.js"
+ , jsInterpTmpFs = hsc_tmpfs hsc_env
+ , jsInterpTmpDir = tmpDir dflags
+ , jsInterpLogger = hsc_logger hsc_env
+ , jsInterpCodegenCfg = initStgToJSConfig dflags
+ , jsInterpUnitEnv = hsc_unit_env hsc_env
+ , jsInterpFinderOpts = initFinderOpts dflags
+ , jsInterpFinderCache = hsc_FC hsc_env
}
return (Just (Interp (ExternalInterp (ExtJS (ExtInterpState cfg s))) loader))
=====================================
compiler/GHC/Driver/Pipeline.hs
=====================================
@@ -111,8 +111,6 @@ import GHC.Types.SourceError
import GHC.Unit
import GHC.Unit.Env
---import GHC.Unit.Finder
---import GHC.Unit.State
import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.Deps
=====================================
compiler/GHC/Runtime/Interpreter/JS.hs
=====================================
@@ -99,12 +99,16 @@ spawnJSInterp cfg = do
when (logVerbAtLeast logger 2) $
logInfo logger (text "Spawning JS interpreter")
- let tmpfs = jsInterpTmpFs cfg
- let tmp_dir = jsInterpTmpDir cfg
- let logger = jsInterpLogger cfg
- let codegen_cfg = jsInterpCodegenCfg cfg
- let unit_env = jsInterpUnitEnv cfg
+ let tmpfs = jsInterpTmpFs cfg
+ tmp_dir = jsInterpTmpDir cfg
+ logger = jsInterpLogger cfg
+ codegen_cfg = jsInterpCodegenCfg cfg
+ unit_env = jsInterpUnitEnv cfg
+ finder_opts = jsInterpFinderOpts cfg
+ finder_cache = jsInterpFinderCache cfg
+
(std_in, proc) <- startTHRunnerProcess (jsInterpScript cfg) (jsInterpNodeConfig cfg)
+
js_state <- newMVar (JSState
{ jsLinkState = emptyLinkPlan
, jsServerStarted = False
@@ -113,6 +117,8 @@ spawnJSInterp cfg = do
let extra = JSInterpExtra
{ instStdIn = std_in
, instJSState = js_state
+ , instFinderCache = finder_cache
+ , instFinderOpts = finder_opts
}
pending_frees <- newMVar []
@@ -144,7 +150,6 @@ spawnJSInterp cfg = do
-- | Link JS RTS
jsLinkRts :: Logger -> TmpFs -> TempDir -> StgToJSConfig -> UnitEnv -> ExtInterpInstance JSInterpExtra -> IO ()
jsLinkRts logger tmpfs tmp_dir cfg unit_env inst = do
-
let link_cfg = JSLinkConfig
{ lcNoStats = True -- we don't need the stats
, lcNoRts = False -- we need the RTS
@@ -162,7 +167,11 @@ jsLinkRts logger tmpfs tmp_dir cfg unit_env inst = do
, lks_extra_roots = mempty
, lks_extra_js = mempty
}
- link_plan <- computeLinkDependencies cfg unit_env link_spec
+
+ let finder_opts = instFinderOpts (instExtra inst)
+ finder_cache = instFinderCache (instExtra inst)
+
+ link_plan <- computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache
jsLinkPlan logger tmpfs tmp_dir link_cfg cfg inst link_plan
-- | Link JS interpreter
@@ -196,13 +205,17 @@ jsLinkInterp logger tmpfs tmp_dir cfg unit_env inst = do
, lks_extra_roots = root_deps
, lks_extra_js = mempty
}
- link_plan <- computeLinkDependencies cfg unit_env link_spec
+
+ let finder_cache = instFinderCache (instExtra inst)
+ finder_opts = instFinderOpts (instExtra inst)
+
+ link_plan <- computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache
+
jsLinkPlan logger tmpfs tmp_dir link_cfg cfg inst link_plan
-- | 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
, lcNoRts = True -- we don't need the RTS (already linked)
@@ -223,7 +236,11 @@ jsLinkObjects logger tmpfs tmp_dir cfg unit_env inst objs is_root = do
, lks_extra_roots = mempty
, lks_extra_js = mempty
}
- link_plan <- computeLinkDependencies cfg unit_env link_spec
+
+ let finder_opts = instFinderOpts (instExtra inst)
+ finder_cache = instFinderCache (instExtra inst)
+
+ link_plan <- computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache
-- link
jsLinkPlan logger tmpfs tmp_dir link_cfg cfg inst link_plan
=====================================
compiler/GHC/Runtime/Interpreter/Types.hs
=====================================
@@ -36,11 +36,12 @@ import GHC.Utils.TmpFs
import GHC.Utils.Logger
import GHC.Unit.Env
import GHC.StgToJS.Types
-import GHC.StgToJS.Linker.Linker
+import GHC.StgToJS.Linker.Types
import Control.Concurrent
import System.Process ( ProcessHandle, CreateProcess )
import System.IO
+import GHC.Unit.Finder.Types (FinderCache, FinderOpts)
-- | Interpreter
data Interp = Interp
@@ -118,8 +119,10 @@ data ExtInterpInstance c = ExtInterpInstance
------------------------
data JSInterpExtra = JSInterpExtra
- { instStdIn :: !Handle -- ^ Stdin for the process
- , instJSState :: !(MVar JSState) -- ^ Mutable state
+ { instStdIn :: !Handle -- ^ Stdin for the process
+ , instFinderCache :: !FinderCache
+ , instFinderOpts :: !FinderOpts
+ , instJSState :: !(MVar JSState) -- ^ Mutable state
}
data JSState = JSState
@@ -145,12 +148,14 @@ defaultNodeJsSettings = NodeJsSettings
data JSInterpConfig = JSInterpConfig
- { jsInterpNodeConfig :: !NodeJsSettings -- ^ NodeJS settings
- , jsInterpScript :: !FilePath -- ^ Path to "ghc-interp.js" script
- , jsInterpTmpFs :: !TmpFs
- , jsInterpTmpDir :: !TempDir
- , jsInterpLogger :: !Logger
- , jsInterpCodegenCfg :: !StgToJSConfig
- , jsInterpUnitEnv :: !UnitEnv
+ { jsInterpNodeConfig :: !NodeJsSettings -- ^ NodeJS settings
+ , jsInterpScript :: !FilePath -- ^ Path to "ghc-interp.js" script
+ , jsInterpTmpFs :: !TmpFs
+ , jsInterpTmpDir :: !TempDir
+ , jsInterpLogger :: !Logger
+ , jsInterpCodegenCfg :: !StgToJSConfig
+ , jsInterpUnitEnv :: !UnitEnv
+ , jsInterpFinderOpts :: !FinderOpts
+ , jsInterpFinderCache :: !FinderCache
}
=====================================
compiler/GHC/StgToJS/Linker/Linker.hs
=====================================
@@ -110,6 +110,10 @@ import System.Directory ( createDirectoryIfMissing
, getPermissions
)
+import GHC.Unit.Finder.Types
+import GHC.Unit.Finder (findObjectLinkableMaybe, initFinderCache, findHomeModule)
+import GHC.Driver.Config.Finder (initFinderOpts)
+
data LinkerStats = LinkerStats
{ bytesPerModule :: !(Map Module Word64) -- ^ number of bytes linked per module
, packedMetaDataSize :: !Word64 -- ^ number of bytes for metadata
@@ -153,7 +157,13 @@ jsLinkBinary lc_cfg cfg js_srcs logger dflags unit_env objs dep_units
, lks_extra_roots = mempty
, lks_extra_js = js_srcs'
}
- link_plan <- computeLinkDependencies cfg unit_env link_spec
+
+ -- XXX we should probably get this from the HscEnv instead?
+ finder_cache <- initFinderCache
+
+ let finder_opts = initFinderOpts dflags
+
+ link_plan <- computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache
void $ jsLink lc_cfg cfg logger exe link_plan
@@ -249,20 +259,6 @@ instance Outputable LinkSpec where
, hang (text "Extra JS:") 2 (vcat (fmap text (lks_extra_js s)))
]
-data LinkPlan = LinkPlan
- { lkp_block_info :: Map Module LocatedBlockInfo
- -- ^ Block information
-
- , lkp_dep_blocks :: Set BlockRef
- -- ^ Blocks to link
-
- , lkp_archives :: Set FilePath
- -- ^ Archives to load JS sources from
-
- , lkp_extra_js :: Set FilePath
- -- ^ Extra JS files to link
- }
-
emptyLinkPlan :: LinkPlan
emptyLinkPlan = LinkPlan
{ lkp_block_info = mempty
@@ -293,23 +289,14 @@ incrementLinkPlan base new = (diff,total)
}
-
-instance Outputable LinkPlan where
- ppr s = hang (text "LinkPlan") 2 $ vcat
- -- Hidden because it's too verbose and it's not really part of the
- -- plan, just meta info used to retrieve actual block contents
- -- [ hcat [ text "Block info: ", ppr (lkp_block_info s)]
- [ hcat [ text "Blocks: ", ppr (S.size (lkp_dep_blocks s))]
- , hang (text "JS files from archives:") 2 (vcat (fmap text (S.toList (lkp_archives s))))
- , hang (text "Extra JS:") 2 (vcat (fmap text (S.toList (lkp_extra_js s))))
- ]
-
computeLinkDependencies
:: StgToJSConfig
-> UnitEnv
-> LinkSpec
+ -> FinderOpts
+ -> FinderCache
-> IO LinkPlan
-computeLinkDependencies cfg unit_env link_spec = do
+computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache = do
let units = lks_unit_ids link_spec
let obj_files = lks_obj_files link_spec
@@ -346,11 +333,30 @@ computeLinkDependencies cfg unit_env link_spec = do
new_required_blocks_var <- newIORef []
let load_info mod = do
-- Adapted from the tangled code in GHC.Linker.Loader.getLinkDeps.
- case lookupHugByModule mod (ue_home_unit_graph unit_env) of
- Nothing -> pprPanic "getDeps: Couldn't find home-module: " (pprModule mod)
+ linkable <- case lookupHugByModule mod (ue_home_unit_graph unit_env) of
+ Nothing ->
+ -- It's not in the HPT because we are in one shot mode,
+ -- so use the Finder to get a ModLocation...
+ case ue_homeUnit unit_env of
+ Nothing -> pprPanic "getDeps: No home-unit: " (pprModule mod)
+ Just home_unit -> do
+ mb_stuff <- findHomeModule finder_cache finder_opts home_unit (moduleName mod)
+ case mb_stuff of
+ Found loc mod -> found loc mod
+ _ -> pprPanic "getDeps: Couldn't find home-module: " (pprModule mod)
+ where
+ found loc mod = do {
+ mb_lnk <- findObjectLinkableMaybe mod loc ;
+ case mb_lnk of {
+ Nothing -> pprPanic "getDeps: Couldn't find linkable for module: " (pprModule mod) ;
+ Just lnk -> pure lnk
+ }}
+
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
+ Just lnk -> pure lnk
+
+ case linkableUnlinked linkable of
[DotO p] -> do
(bis, req_b) <- loadObjBlockInfo [ObjFile p]
-- Store new required blocks in IORef
@@ -362,8 +368,6 @@ computeLinkDependencies cfg unit_env link_spec = do
(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
=====================================
compiler/GHC/StgToJS/Linker/Types.hs
=====================================
@@ -20,12 +20,22 @@ module GHC.StgToJS.Linker.Types
( JSLinkConfig (..)
, defaultJSLinkConfig
, LinkedObj (..)
+ , LinkPlan (..)
)
where
import GHC.StgToJS.Object
-import GHC.Utils.Outputable (hsep,Outputable(..),text,ppr)
+import GHC.Unit.Types
+import GHC.Utils.Outputable (hsep,Outputable(..),text,ppr, hang, IsDoc (vcat), IsLine (hcat))
+
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import Data.Set (Set)
+import qualified Data.Set as S
+
+
+import Control.Concurrent.MVar
import System.IO
@@ -55,6 +65,30 @@ defaultJSLinkConfig = JSLinkConfig
, lcForeignRefs = True
}
+data LinkPlan = LinkPlan
+ { lkp_block_info :: Map Module LocatedBlockInfo
+ -- ^ Block information
+
+ , lkp_dep_blocks :: Set BlockRef
+ -- ^ Blocks to link
+
+ , lkp_archives :: Set FilePath
+ -- ^ Archives to load JS sources from
+
+ , lkp_extra_js :: Set FilePath
+ -- ^ Extra JS files to link
+ }
+
+instance Outputable LinkPlan where
+ ppr s = hang (text "LinkPlan") 2 $ vcat
+ -- Hidden because it's too verbose and it's not really part of the
+ -- plan, just meta info used to retrieve actual block contents
+ -- [ hcat [ text "Block info: ", ppr (lkp_block_info s)]
+ [ hcat [ text "Blocks: ", ppr (S.size (lkp_dep_blocks s))]
+ , hang (text "JS files from archives:") 2 (vcat (fmap text (S.toList (lkp_archives s))))
+ , hang (text "Extra JS:") 2 (vcat (fmap text (S.toList (lkp_extra_js s))))
+ ]
+
--------------------------------------------------------------------------------
-- Linker Environment
--------------------------------------------------------------------------------
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a1bb05bfef1938a19bcb6c80eb815757c48b56af
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a1bb05bfef1938a19bcb6c80eb815757c48b56af
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/20230130/dbdf4cf1/attachment-0001.html>
More information about the ghc-commits
mailing list