[Git][ghc/ghc][master] 2 commits: testsuite: add T25414 test case marked as broken
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Oct 30 03:18:48 UTC 2024
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
b1eed26f by Cheng Shao at 2024-10-29T23:18:13-04:00
testsuite: add T25414 test case marked as broken
This commit adds T25414 test case to demonstrate #25414. It is marked
as broken and will be fixed by the next commit.
- - - - -
e70009bc by Cheng Shao at 2024-10-29T23:18:13-04:00
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.
- - - - -
4 changed files:
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Linker/Loader.hs
- + testsuite/tests/ghci/scripts/T25414.script
- testsuite/tests/ghci/scripts/all.T
Changes:
=====================================
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)
=====================================
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 at 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,
=====================================
testsuite/tests/ghci/scripts/T25414.script
=====================================
@@ -0,0 +1,6 @@
+:set -XCApiFFI
+import Foreign
+import Foreign.C
+foreign import capi unsafe "stdlib.h malloc" c_malloc :: CSize -> IO (Ptr ())
+foreign import capi unsafe "stdlib.h free" c_free :: Ptr () -> IO ()
+c_free =<< c_malloc 16
=====================================
testsuite/tests/ghci/scripts/all.T
=====================================
@@ -360,6 +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', 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'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e3496ef6c6f4cdb8bbef8b0e9dfa61219c32a575...e70009bc5b388ed02db12ee7a99bca0e4c283c87
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e3496ef6c6f4cdb8bbef8b0e9dfa61219c32a575...e70009bc5b388ed02db12ee7a99bca0e4c283c87
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/20241029/a16a5150/attachment-0001.html>
More information about the ghc-commits
mailing list