diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 7233ffff6122f46aaf426257458166bd94775a66..a514b76198d021c79085e1a4e68014bcddf4edd2 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -148,6 +148,7 @@ import GHC.ByteCode.Types
import GHC.Linker.Loader
import GHC.Linker.Types
+import GHC.Linker.Deps
import GHC.Hs
import GHC.Hs.Dump
@@ -2578,7 +2579,7 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr = do
tidy_expr
{- Lint if necessary -}
- lintInteractiveExpr (text "hscCompileExpr") hsc_env prepd_expr
+ lintInteractiveExpr (text "hscCompileCoreExpr") hsc_env prepd_expr
let this_loc = ModLocation{ ml_hs_file = Nothing,
ml_hi_file = panic "hscCompileCoreExpr':ml_hi_file",
ml_obj_file = panic "hscCompileCoreExpr':ml_obj_file",
@@ -2592,7 +2593,7 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr = do
-- files for the same module and the JS linker doesn't support this.
--
-- Note that we can't use icInteractiveModule because the ic_mod_index value
- -- isn't bumped between invocations of hscCompileExpr, so uniqueness isn't
+ -- isn't bumped between invocations of hscCompileCoreExpr, so uniqueness isn't
-- guaranteed.
--
-- We reuse the unique we obtained for the binding, but any unique would do.
@@ -2611,14 +2612,11 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr = do
let (stg_binds, _stg_deps) = unzip stg_binds_with_deps
let interp = hscInterp hsc_env
- let tmpfs = hsc_tmpfs hsc_env
- let tmp_dir = tmpDir dflags
case interp of
-- always generate JS code for the JS interpreter (no bytecode!)
Interp (ExternalInterp (ExtJS i)) _ ->
- jsCodeGen logger tmpfs tmp_dir unit_env (initStgToJSConfig dflags) interp i
- this_mod stg_binds binding_id
+ jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id
_ -> do
{- Convert to BCOs -}
@@ -2637,18 +2635,70 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr = do
-- | Generate JS code for the given bindings and return the HValue for the given id
jsCodeGen
- :: Logger
- -> TmpFs
- -> TempDir
- -> UnitEnv
- -> StgToJSConfig
- -> Interp
+ :: HscEnv
+ -> SrcSpan
-> JSInterp
-> Module
- -> [CgStgTopBinding]
+ -> [(CgStgTopBinding,IdSet)]
-> Id
-> IO (ForeignHValue, [Linkable], PkgsLoaded)
-jsCodeGen logger tmpfs tmp_dir unit_env js_config interp i this_mod stg_binds binding_id = do
+jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id = do
+ let logger = hsc_logger hsc_env
+ tmpfs = hsc_tmpfs hsc_env
+ dflags = hsc_dflags hsc_env
+ interp = hscInterp hsc_env
+ tmp_dir = tmpDir dflags
+ unit_env = hsc_unit_env hsc_env
+ js_config = initStgToJSConfig dflags
+
+ -- We need to load all the dependencies first.
+ --
+ -- We get all the imported names from the Stg bindings and load their modules.
+ --
+ -- (logic adapted from GHC.Linker.Loader.loadDecls for the JS linker)
+ let
+ (stg_binds, stg_deps) = unzip stg_binds_with_deps
+ imported_ids = nonDetEltsUniqSet (unionVarSets stg_deps)
+ imported_names = map idName imported_ids
+
+ needed_mods :: [Module]
+ needed_mods = [ nameModule n | n <- imported_names,
+ isExternalName n, -- Names from other modules
+ not (isWiredInName n) -- Exclude wired-in names
+ ] -- (see note below)
+ -- Exclude wired-in names because we may not have read
+ -- their interface files, so getLinkDeps will fail
+ -- All wired-in names are in the base package, which we link
+ -- by default, so we can safely ignore them here.
+
+ -- Initialise the linker (if it's not been done already)
+ initLoaderState interp hsc_env
+
+ -- Take lock for the actual work.
+ (dep_linkables, dep_units) <- modifyLoaderState interp $ \pls -> do
+ let link_opts = initLinkDepsOpts hsc_env
+
+ -- Find what packages and linkables are required
+ 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
+ (concatMap partitionLinkable (ldNeededLinkables deps))
+
+ let (objs_loaded', _new_objs) = rmDupLinkables (objs_loaded pls) objs
+
+ -- FIXME: we should make the JS linker load new_objs here, instead of
+ -- on-demand.
+
+ -- FIXME: we don't report needed units because we would have to find a way
+ -- to build a meaningful LoadedPkgInfo (see the mess in
+ -- GHC.Linker.Loader.{loadPackage,loadPackages'}). Detecting what to load
+ -- and actually loading (using the native interpreter) are intermingled, so
+ -- we can't directly reuse this code.
+ let pls' = pls { objs_loaded = objs_loaded' }
+ pure (pls', (ldAllLinkables deps, emptyUDFM {- ldNeededUnits deps -}) )
+
+
let foreign_stubs = NoStubs
spt_entries = mempty
cost_centre_info = mempty
@@ -2671,12 +2721,7 @@ jsCodeGen logger tmpfs tmp_dir unit_env js_config interp i this_mod stg_binds bi
binding_fref <- withJSInterp i $ \inst ->
mkForeignRef href (freeReallyRemoteRef inst href)
- -- FIXME (#23013): the JS linker doesn't use the LoaderState.
- -- The state is only maintained in the interpreter instance (jsLinkState field) for now.
- let linkables = mempty
- let loaded_pkgs = emptyUDFM
-
- return (castForeignRef binding_fref, linkables, loaded_pkgs)
+ return (castForeignRef binding_fref, dep_linkables, dep_units)
{- **********************************************************************
diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs
index aaea2936fbf385d1e3597b5b8cadf43e89f5dea4..fe19df150b9771d88b9566390ab2c861531fb02c 100644
--- a/compiler/GHC/Linker/Loader.hs
+++ b/compiler/GHC/Linker/Loader.hs
@@ -29,6 +29,11 @@ module GHC.Linker.Loader
, withExtendedLoadedEnv
, extendLoadedEnv
, deleteFromLoadedEnv
+ -- * Internals
+ , rmDupLinkables
+ , modifyLoaderState
+ , initLinkDepsOpts
+ , partitionLinkable
)
where
@@ -282,15 +287,22 @@ reallyInitLoaderState interp hsc_env = do
-- Initialise the linker state
let pls0 = emptyLoaderState
- -- (a) initialise the C dynamic linker
- initObjLinker interp
+ case platformArch (targetPlatform (hsc_dflags hsc_env)) of
+ -- FIXME: we don't initialize anything with the JS interpreter.
+ -- Perhaps we should load preload packages. We'll load them on demand
+ -- anyway.
+ ArchJavaScript -> return pls0
+ _ -> do
+ -- (a) initialise the C dynamic linker
+ initObjLinker interp
- -- (b) Load packages from the command-line (Note [preload packages])
- pls <- unitEnv_foldWithKey (\k u env -> k >>= \pls' -> loadPackages' interp (hscSetActiveUnitId u hsc_env) (preloadUnits (homeUnitEnv_units env)) pls') (return pls0) (hsc_HUG hsc_env)
- -- steps (c), (d) and (e)
- loadCmdLineLibs' interp hsc_env pls
+ -- (b) Load packages from the command-line (Note [preload packages])
+ pls <- unitEnv_foldWithKey (\k u env -> k >>= \pls' -> loadPackages' interp (hscSetActiveUnitId u hsc_env) (preloadUnits (homeUnitEnv_units env)) pls') (return pls0) (hsc_HUG hsc_env)
+
+ -- steps (c), (d) and (e)
+ loadCmdLineLibs' interp hsc_env pls
loadCmdLineLibs :: Interp -> HscEnv -> IO ()
diff --git a/testsuite/tests/driver/recomp009/all.T b/testsuite/tests/driver/recomp009/all.T
index 83a811ca68d551f738453f095e312f37001bf8eb..33c36f7ea3d8ba7dd13871bdb5013383015a8a5d 100644
--- a/testsuite/tests/driver/recomp009/all.T
+++ b/testsuite/tests/driver/recomp009/all.T
@@ -1,3 +1,3 @@
# Test for #481, a recompilation bug with Template Haskell
-test('recomp009', [req_th, js_broken(23013), extra_files(['Main.hs', 'Sub1.hs', 'Sub2.hs'])], makefile_test, [])
+test('recomp009', [req_th, extra_files(['Main.hs', 'Sub1.hs', 'Sub2.hs'])], makefile_test, [])
diff --git a/testsuite/tests/driver/recompTH/all.T b/testsuite/tests/driver/recompTH/all.T
index 238f7aa2749248ab8187ad2f5868b7fa72d64a5d..8d75ed0308ffaeb513e34a0ec052ca98d717420c 100644
--- a/testsuite/tests/driver/recompTH/all.T
+++ b/testsuite/tests/driver/recompTH/all.T
@@ -1,4 +1,4 @@
-test('recompTH', [req_th, js_broken(23013), extra_files(['A.hs', 'B1.hs', 'B2.hs' ]),
+test('recompTH', [req_th, extra_files(['A.hs', 'B1.hs', 'B2.hs' ]),
when(fast(), skip)
, normalise_slashes],
makefile_test, [])
diff --git a/testsuite/tests/driver/th-new-test/all.T b/testsuite/tests/driver/th-new-test/all.T
index a5072178b4be450677c99af63ebe4794e532be18..54dd7852beb639b3587a7882be1ca1509ae4890f 100644
--- a/testsuite/tests/driver/th-new-test/all.T
+++ b/testsuite/tests/driver/th-new-test/all.T
@@ -1,4 +1,4 @@
-test('th-new-test', [req_th, js_broken(23013), extra_files(['A.hs', 'B.hs', 'C.hs', 'D.hs', 'B1.hs', 'D1.hs', 'Main.hs']),
+test('th-new-test', [req_th, extra_files(['A.hs', 'B.hs', 'C.hs', 'D.hs', 'B1.hs', 'D1.hs', 'Main.hs']),
when(fast(), skip)
, normalise_slashes],
makefile_test, [])