From e70009bc5b388ed02db12ee7a99bca0e4c283c87 Mon Sep 17 00:00:00 2001
From: Cheng Shao <terrorjack@type.dance>
Date: Thu, 24 Oct 2024 20:30:13 +0200
Subject: [PATCH] driver: fix foreign stub handling logic in hscParsedDecls
This patch fixes foreign stub handling logic in `hscParsedDecls`.
Previously foreign stubs were simply ignored here, so any feature that
involve foreign stubs would not work in ghci (e.g. CApiFFI). The patch
reuses `generateByteCode` logic and eliminates a large chunk of
duplicate logic that implements Core to bytecode generation pipeline
here. Fixes #25414.
---
compiler/GHC/Driver/Main.hs | 43 +++++++-----------------------
compiler/GHC/Linker/Loader.hs | 22 ++++++++++-----
testsuite/tests/ghci/scripts/all.T | 2 +-
3 files changed, 26 insertions(+), 41 deletions(-)
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index e3a59b86112..3b9cb98771d 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -2507,46 +2507,21 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
(tidy_cg, mod_details) <- liftIO $ hscTidy hsc_env simpl_mg
let !CgGuts{ cg_module = this_mod,
- cg_binds = core_binds,
- cg_tycons = tycons,
- cg_modBreaks = mod_breaks,
- cg_spt_entries = spt_entries
+ cg_binds = core_binds
} = tidy_cg
!ModDetails { md_insts = cls_insts
, md_fam_insts = fam_insts } = mod_details
-- Get the *tidied* cls_insts and fam_insts
- data_tycons = filter isDataTyCon tycons
-
- {- Prepare For Code Generation -}
- -- Do saturation and convert to A-normal form
- prepd_binds <- {-# SCC "CorePrep" #-} liftIO $ do
- cp_cfg <- initCorePrepConfig hsc_env
- corePrepPgm
- (hsc_logger hsc_env)
- cp_cfg
- (initCorePrepPgmConfig (hsc_dflags hsc_env) (interactiveInScope $ hsc_IC hsc_env))
- this_mod iNTERACTIVELoc core_binds data_tycons
-
- (stg_binds_with_deps, _infotable_prov, _caf_ccs__caf_cc_stacks, _stg_cg_info)
- <- {-# SCC "CoreToStg" #-}
- liftIO $ myCoreToStg (hsc_logger hsc_env)
- (hsc_dflags hsc_env)
- (interactiveInScope (hsc_IC hsc_env))
- True
- this_mod
- iNTERACTIVELoc
- prepd_binds
-
- let (stg_binds,_stg_deps) = unzip stg_binds_with_deps
-
- {- Generate byte code -}
- cbc <- liftIO $ byteCodeGen hsc_env this_mod
- stg_binds data_tycons mod_breaks spt_entries
+ {- Generate byte code & foreign stubs -}
+ linkable <- liftIO $ generateFreshByteCode hsc_env
+ (moduleName this_mod)
+ (mkCgInteractiveGuts tidy_cg)
+ iNTERACTIVELoc
let src_span = srcLocSpan interactiveSrcLoc
- _ <- liftIO $ loadDecls interp hsc_env src_span cbc
+ _ <- liftIO $ loadDecls interp hsc_env src_span linkable
{- Load static pointer table entries -}
liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg)
@@ -2825,7 +2800,9 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr = do
[] -- spt entries
{- load it -}
- (fv_hvs, mods_needed, units_needed) <- loadDecls interp hsc_env srcspan bcos
+ bco_time <- getCurrentTime
+ (fv_hvs, mods_needed, units_needed) <- loadDecls interp hsc_env srcspan $
+ Linkable bco_time this_mod $ NE.singleton $ BCOs bcos
{- Get the HValue for the root -}
return (expectJust "hscCompileCoreExpr'"
$ lookup (idName binding_id) fv_hvs, mods_needed, units_needed)
diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs
index c3ffd24c040..a14b2a6d60d 100644
--- a/compiler/GHC/Linker/Loader.hs
+++ b/compiler/GHC/Linker/Loader.hs
@@ -669,32 +669,40 @@ initLinkDepsOpts hsc_env = opts
********************************************************************* -}
-loadDecls :: Interp -> HscEnv -> SrcSpan -> CompiledByteCode -> IO ([(Name, ForeignHValue)], [Linkable], PkgsLoaded)
-loadDecls interp hsc_env span cbc@CompiledByteCode{..} = do
+loadDecls :: Interp -> HscEnv -> SrcSpan -> Linkable -> IO ([(Name, ForeignHValue)], [Linkable], PkgsLoaded)
+loadDecls interp hsc_env span linkable = do
-- Initialise the linker (if it's not been done already)
initLoaderState interp hsc_env
-- Take lock for the actual work.
modifyLoaderState interp $ \pls0 -> do
+ -- Link the foreign objects first; BCOs in linkable are ignored here.
+ (pls1, objs_ok) <- loadObjects interp hsc_env pls0 [linkable]
+ when (failed objs_ok) $ throwGhcExceptionIO $ ProgramError "loadDecls: failed to load foreign objects"
+
-- Link the packages and modules required
- (pls, ok, links_needed, units_needed) <- loadDependencies interp hsc_env pls0 span needed_mods
+ (pls, ok, links_needed, units_needed) <- loadDependencies interp hsc_env pls1 span needed_mods
if failed ok
then throwGhcExceptionIO (ProgramError "")
else do
-- Link the expression itself
let le = linker_env pls
- le2 = le { itbl_env = plusNameEnv (itbl_env le) bc_itbls
- , addr_env = plusNameEnv (addr_env le) bc_strs }
+ le2 = le { itbl_env = foldl' (\acc cbc -> plusNameEnv acc (bc_itbls cbc)) (itbl_env le) cbcs
+ , addr_env = foldl' (\acc cbc -> plusNameEnv acc (bc_strs cbc)) (addr_env le) cbcs }
-- Link the necessary packages and linkables
- new_bindings <- linkSomeBCOs interp (pkgs_loaded pls) le2 [cbc]
+ new_bindings <- linkSomeBCOs interp (pkgs_loaded pls) le2 cbcs
nms_fhvs <- makeForeignNamedHValueRefs interp new_bindings
let ce2 = extendClosureEnv (closure_env le2) nms_fhvs
!pls2 = pls { linker_env = le2 { closure_env = ce2 } }
return (pls2, (nms_fhvs, links_needed, units_needed))
where
+ cbcs = linkableBCOs linkable
+
free_names = uniqDSetToList $
- foldr (unionUniqDSets . bcoFreeNames) emptyUniqDSet bc_bcos
+ foldl'
+ (\acc cbc -> foldl' (\acc' bco -> bcoFreeNames bco `unionUniqDSets` acc') acc (bc_bcos cbc))
+ emptyUniqDSet cbcs
needed_mods :: [Module]
needed_mods = [ nameModule n | n <- free_names,
diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T
index 1da5d6ff733..717e10f1f8a 100755
--- a/testsuite/tests/ghci/scripts/all.T
+++ b/testsuite/tests/ghci/scripts/all.T
@@ -360,7 +360,7 @@ test('T20455', normal, ghci_script, ['T20455.script'])
test('shadow-bindings', normal, ghci_script, ['shadow-bindings.script'])
test('T925', normal, ghci_script, ['T925.script'])
test('T7388', normal, ghci_script, ['T7388.script'])
-test('T25414', [expect_broken(25414)], ghci_script, ['T25414.script'])
+test('T25414', normal, ghci_script, ['T25414.script'])
test('T20627', normal, ghci_script, ['T20627.script'])
test('T20473a', normal, ghci_script, ['T20473a.script'])
test('T20473b', normal, ghci_script, ['T20473b.script'])
--
GitLab