From d492ae389be39b631bf06701276633d50a418645 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.
(cherry picked from commit 677e3aa56e905524071fc9717a88ad2cd1bc2951)
(cherry picked from commit 0db7ace8a69487365bc82b758fec7c6cb712d529)
---
compiler/GHC/Driver/Main.hs | 54 ++++++++++++------------------
compiler/GHC/Linker/Loader.hs | 2 ++
testsuite/tests/ghci/scripts/all.T | 2 +-
3 files changed, 25 insertions(+), 33 deletions(-)
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index d7d861a7e0d..18398b70804 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -229,6 +229,7 @@ import GHC.Unit.Module.Deps
import GHC.Unit.Module.Status
import GHC.Unit.Home.ModInfo
+import GHC.Types.Basic
import GHC.Types.Id
import GHC.Types.SourceError
import GHC.Types.SafeHaskell
@@ -2315,7 +2316,7 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
{- Desugar it -}
-- We use a basically null location for iNTERACTIVE
- let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing,
+ let iNTERACTIVELoc = ModLocation{ ml_hs_file = Just "Interactive",
ml_hi_file = panic "hsDeclsWithLocation:ml_hi_file",
ml_obj_file = panic "hsDeclsWithLocation:ml_obj_file",
ml_dyn_obj_file = panic "hsDeclsWithLocation:ml_dyn_obj_file",
@@ -2332,47 +2333,36 @@ 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 } = tidy_cg
+ 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
+ {- Generate byte code & load foreign stubs -}
+ (cbc, spt_entries) <- liftIO $ do
+ (BCOs cbc spt_entries):fos <- generateByteCode hsc_env (mkCgInteractiveGuts tidy_cg) iNTERACTIVELoc
+ case NE.nonEmpty fos of
+ Just nefos -> modifyLoaderState_ interp $ \pls -> do
+ mtime <- getModificationUTCTime $ nameOfObject $ NE.head nefos
+ (pls1, ok_flag) <- loadObjects interp hsc_env pls
+ [ LM
+ { linkableTime = mtime,
+ linkableModule = this_mod,
+ linkableUnlinked = NE.toList nefos
+ } ]
+ if succeeded ok_flag
+ then pure pls1
+ else panic "could not load foreign stubs for interactive module"
+ Nothing -> pure ()
+ pure (cbc, spt_entries)
let src_span = srcLocSpan interactiveSrcLoc
_ <- liftIO $ loadDecls interp hsc_env src_span cbc
{- Load static pointer table entries -}
- liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg)
+ liftIO $ hscAddSptEntries hsc_env spt_entries
let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg)
patsyns = mg_patsyns simpl_mg
diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs
index 99e6ec02608..4cf9882e4dc 100644
--- a/compiler/GHC/Linker/Loader.hs
+++ b/compiler/GHC/Linker/Loader.hs
@@ -24,6 +24,7 @@ module GHC.Linker.Loader
, loadModule
, loadCmdLineLibs
, loadName
+ , loadObjects
, unload
-- * LoadedEnv
, withExtendedLoadedEnv
@@ -31,6 +32,7 @@ module GHC.Linker.Loader
, deleteFromLoadedEnv
-- * Internals
, rmDupLinkables
+ , modifyLoaderState_
, modifyLoaderState
, initLinkDepsOpts
, partitionLinkable
diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T
index 57da4578faa..eb20009984a 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