[Git][ghc/ghc][wip/torsten.schmits/rts-linker-direct-symbol-lookup] 3 commits: move test to subdir
Torsten Schmits (@torsten.schmits)
gitlab at gitlab.haskell.org
Fri Mar 15 12:44:06 UTC 2024
Torsten Schmits pushed to branch wip/torsten.schmits/rts-linker-direct-symbol-lookup at Glasgow Haskell Compiler / GHC
Commits:
a68cbaf2 by Torsten Schmits at 2024-03-13T15:15:18+01:00
move test to subdir
- - - - -
fb25ac08 by Torsten Schmits at 2024-03-15T13:42:56+01:00
add flag and logging
- - - - -
17319148 by Torsten Schmits at 2024-03-15T13:43:51+01:00
add test case with long chain of package deps
- - - - -
17 changed files:
- compiler/GHC/ByteCode/Linker.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Linker/Types.hs
- ghc/Main.hs
- testsuite/tests/rts/linker/Makefile
- + testsuite/tests/rts/linker/T23415/Makefile
- testsuite/tests/rts/linker/Reuse.hs → testsuite/tests/rts/linker/T23415/Reuse.hs
- testsuite/tests/rts/linker/Reuse.script → testsuite/tests/rts/linker/T23415/Reuse.script
- testsuite/tests/rts/linker/ReusePlugin.hs → testsuite/tests/rts/linker/T23415/ReusePlugin.hs
- testsuite/tests/rts/linker/T23415.stderr → testsuite/tests/rts/linker/T23415/T23415a.stderr
- + testsuite/tests/rts/linker/T23415/T23415b.script
- + testsuite/tests/rts/linker/T23415/all.T
- + testsuite/tests/rts/linker/T23415/prepare-load.sh
- testsuite/tests/rts/linker/reuse.conf → testsuite/tests/rts/linker/T23415/reuse.conf
- testsuite/tests/rts/linker/all.T
Changes:
=====================================
compiler/GHC/ByteCode/Linker.hs
=====================================
@@ -46,6 +46,7 @@ import Language.Haskell.Syntax.Module.Name
import Data.Array.Unboxed
import Foreign.Ptr
import GHC.Exts
+import GHC.Utils.Error (debugTraceMsg)
{-
Linking interpretables into something we can run
@@ -53,7 +54,7 @@ import GHC.Exts
linkBCO
:: Interp
- -> PkgsLoaded
+ -> PkgsLoadedEnv
-> LinkerEnv
-> NameEnv Int
-> UnlinkedBCO
@@ -68,7 +69,7 @@ linkBCO interp pkgs_loaded le bco_ix
(listArray (0, fromIntegral (sizeSS lits0)-1) lits)
(addListToSS emptySS ptrs))
-lookupLiteral :: Interp -> PkgsLoaded -> LinkerEnv -> BCONPtr -> IO Word
+lookupLiteral :: Interp -> PkgsLoadedEnv -> LinkerEnv -> BCONPtr -> IO Word
lookupLiteral interp pkgs_loaded le ptr = case ptr of
BCONPtrWord lit -> return lit
BCONPtrLbl sym -> do
@@ -92,7 +93,7 @@ lookupStaticPtr interp addr_of_label_string = do
Nothing -> linkFail "GHC.ByteCode.Linker: can't find label"
(unpackFS addr_of_label_string)
-lookupIE :: Interp -> PkgsLoaded -> ItblEnv -> Name -> IO (Ptr ())
+lookupIE :: Interp -> PkgsLoadedEnv -> ItblEnv -> Name -> IO (Ptr ())
lookupIE interp pkgs_loaded ie con_nm =
case lookupNameEnv ie con_nm of
Just (_, ItblPtr a) -> return (fromRemotePtr (castRemotePtr a))
@@ -112,7 +113,7 @@ lookupIE interp pkgs_loaded ie con_nm =
unpackFS sym_to_find2)
-- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode
-lookupAddr :: Interp -> PkgsLoaded -> AddrEnv -> Name -> IO (Ptr ())
+lookupAddr :: Interp -> PkgsLoadedEnv -> AddrEnv -> Name -> IO (Ptr ())
lookupAddr interp pkgs_loaded ae addr_nm = do
case lookupNameEnv ae addr_nm of
Just (_, AddrPtr ptr) -> return (fromRemotePtr ptr)
@@ -135,7 +136,7 @@ lookupPrimOp interp primop = do
resolvePtr
:: Interp
- -> PkgsLoaded
+ -> PkgsLoadedEnv
-> LinkerEnv
-> NameEnv Int
-> BCOPtr
@@ -166,8 +167,8 @@ resolvePtr interp pkgs_loaded le bco_ix ptr = case ptr of
BCOPtrBreakArray breakarray
-> withForeignRef breakarray $ \ba -> return (ResolvedBCOPtrBreakArray ba)
-lookupHsSymbol :: Interp -> PkgsLoaded -> Name -> String -> IO (Maybe (Ptr ()))
-lookupHsSymbol interp pkgs_loaded nm sym_suffix = do
+lookupHsSymbol :: Interp -> PkgsLoadedEnv -> Name -> String -> IO (Maybe (Ptr ()))
+lookupHsSymbol interp PkgsLoadedEnv {ple_pkgs_loaded = pkgs_loaded, ple_logger = logger} nm sym_suffix = do
massertPpr (isExternalName nm) (ppr nm)
let sym_to_find = nameToCLabel nm sym_suffix
pkg_id = moduleUnitId $ nameModule nm
@@ -176,12 +177,20 @@ lookupHsSymbol interp pkgs_loaded nm sym_suffix = do
go (dll:dlls) = do
mb_ptr <- lookupSymbolInDLL interp dll sym_to_find
case mb_ptr of
- Just ptr -> pure (Just ptr)
+ Just ptr -> do
+ log_resolution sym_to_find "hit"
+ pure (Just ptr)
Nothing -> go dlls
- go [] =
+ go [] = do
+ log_resolution sym_to_find "miss"
lookupSymbol interp sym_to_find
go loaded_dlls
+ where
+ log_resolution sym_to_find res =
+ debugTraceMsg logger 3 $
+ text "lookupHsSymbol: Cache" <+> text res <+> text "for" <+> ppr nm <+>
+ parens (ftext sym_to_find)
linkFail :: String -> String -> IO a
linkFail who what
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -468,6 +468,7 @@ data GeneralFlag
-- temporary flags
| Opt_AutoLinkPackages
| Opt_ImplicitImportQualified
+ | Opt_CacheLoadedLibraryUnits
-- keeping stuff
| Opt_KeepHscppFiles
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -2345,8 +2345,8 @@ fFlagsDeps = [
flagGhciSpec "break-on-error" Opt_BreakOnError,
flagGhciSpec "break-on-exception" Opt_BreakOnException,
flagSpec "building-cabal-package" Opt_BuildingCabalPackage,
+ flagGhciSpec "cache-loaded-library-units" Opt_CacheLoadedLibraryUnits,
flagSpec "call-arity" Opt_CallArity,
- flagSpec "exitification" Opt_Exitification,
flagSpec "case-merge" Opt_CaseMerge,
flagSpec "case-folding" Opt_CaseFolding,
flagSpec "cmm-elim-common-blocks" Opt_CmmElimCommonBlocks,
@@ -2379,6 +2379,7 @@ fFlagsDeps = [
flagSpec "enable-th-splice-warnings" Opt_EnableThSpliceWarnings,
flagSpec "error-spans" Opt_ErrorSpans,
flagSpec "excess-precision" Opt_ExcessPrecision,
+ flagSpec "exitification" Opt_Exitification,
flagSpec "expose-all-unfoldings" Opt_ExposeAllUnfoldings,
flagSpec "keep-auto-rules" Opt_KeepAutoRules,
flagSpec "expose-internal-symbols" Opt_ExposeInternalSymbols,
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -588,7 +588,7 @@ loadExpr interp hsc_env span root_ul_bco = do
-- Load the necessary packages and linkables
let le = linker_env pls
bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)]
- resolved <- linkBCO interp (pkgs_loaded pls) le bco_ix root_ul_bco
+ resolved <- linkBCO interp (PkgsLoadedEnv (pkgs_loaded pls) (hsc_logger hsc_env)) le bco_ix root_ul_bco
[root_hvref] <- createBCOs interp [resolved]
fhv <- mkFinalizedHValue interp root_hvref
return (pls, fhv)
@@ -651,7 +651,7 @@ loadDecls interp hsc_env span cbc at CompiledByteCode{..} = do
, addr_env = plusNameEnv (addr_env le) bc_strs }
-- Link the necessary packages and linkables
- new_bindings <- linkSomeBCOs interp (pkgs_loaded pls) le2 [cbc]
+ new_bindings <- linkSomeBCOs interp (PkgsLoadedEnv (pkgs_loaded pls) (hsc_logger hsc_env)) le2 [cbc]
nms_fhvs <- makeForeignNamedHValueRefs interp new_bindings
let ce2 = extendClosureEnv (closure_env le2) nms_fhvs
!pls2 = pls { linker_env = le2 { closure_env = ce2 } }
@@ -706,7 +706,7 @@ loadModuleLinkables interp hsc_env pls linkables
if failed ok_flag then
return (pls1, Failed)
else do
- pls2 <- dynLinkBCOs interp pls1 bcos
+ pls2 <- dynLinkBCOs interp hsc_env pls1 bcos
return (pls2, Succeeded)
@@ -856,8 +856,8 @@ rmDupLinkables already ls
********************************************************************* -}
-dynLinkBCOs :: Interp -> LoaderState -> [Linkable] -> IO LoaderState
-dynLinkBCOs interp pls bcos = do
+dynLinkBCOs :: Interp -> HscEnv -> LoaderState -> [Linkable] -> IO LoaderState
+dynLinkBCOs interp hsc_env pls bcos = do
let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
pls1 = pls { bcos_loaded = bcos_loaded' }
@@ -873,7 +873,7 @@ dynLinkBCOs interp pls bcos = do
ae2 = foldr plusNameEnv (addr_env le1) (map bc_strs cbcs)
le2 = le1 { itbl_env = ie2, addr_env = ae2 }
- names_and_refs <- linkSomeBCOs interp (pkgs_loaded pls) le2 cbcs
+ names_and_refs <- linkSomeBCOs interp (PkgsLoadedEnv (pkgs_loaded pls) (hsc_logger hsc_env)) le2 cbcs
-- We only want to add the external ones to the ClosureEnv
let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs
@@ -888,7 +888,7 @@ dynLinkBCOs interp pls bcos = do
-- Link a bunch of BCOs and return references to their values
linkSomeBCOs :: Interp
- -> PkgsLoaded
+ -> PkgsLoadedEnv
-> LinkerEnv
-> [CompiledByteCode]
-> IO [(Name,HValueRef)]
@@ -896,7 +896,7 @@ linkSomeBCOs :: Interp
-- the incoming unlinked BCOs. Each gives the
-- value of the corresponding unlinked BCO
-linkSomeBCOs interp pkgs_loaded le mods = foldr fun do_link mods []
+linkSomeBCOs interp pkgs_loaded_env le mods = foldr fun do_link mods []
where
fun CompiledByteCode{..} inner accum = inner (bc_bcos : accum)
@@ -905,7 +905,7 @@ linkSomeBCOs interp pkgs_loaded le mods = foldr fun do_link mods []
let flat = [ bco | bcos <- mods, bco <- bcos ]
names = map unlinkedBCOName flat
bco_ix = mkNameEnv (zip names [0..])
- resolved <- sequence [ linkBCO interp pkgs_loaded le bco_ix bco | bco <- flat ]
+ resolved <- sequence [ linkBCO interp pkgs_loaded_env le bco_ix bco | bco <- flat ]
hvrefs <- createBCOs interp resolved
return (zip names hvrefs)
@@ -1072,11 +1072,18 @@ loadPackages' interp hsc_env new_pks pls = do
| dep_pkg <- deps
, Just loaded_pkg_info <- pure (lookupUDFM pkgs' dep_pkg)
]
- ; return (addToUDFM pkgs' new_pkg (LoadedPkgInfo new_pkg hs_cls extra_cls loaded_dlls trans_deps)) }
+ cached | cacheDlls = loaded_dlls
+ | otherwise = []
+ ; when (cacheDlls && not (null cached)) $
+ debugTraceMsg (hsc_logger hsc_env) 3 $
+ text "loadPackages': Updating cache for" <+> ppr (unitId pkg_cfg)
+ ; return (addToUDFM pkgs' new_pkg (LoadedPkgInfo new_pkg hs_cls extra_cls cached trans_deps)) }
| otherwise
= throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg)))
+ cacheDlls = gopt Opt_CacheLoadedLibraryUnits (hsc_dflags hsc_env)
+
loadPackage :: Interp -> HscEnv -> UnitInfo -> IO ([LibrarySpec], [LibrarySpec], [RemotePtr LoadedDLL])
loadPackage interp hsc_env pkg
=====================================
compiler/GHC/Linker/Types.hs
=====================================
@@ -33,6 +33,7 @@ module GHC.Linker.Types
, LibrarySpec(..)
, LoadedPkgInfo(..)
, PkgsLoaded
+ , PkgsLoadedEnv(..)
)
where
@@ -57,6 +58,7 @@ import GHC.Unit.Module.Env
import GHC.Types.Unique.DSet
import GHC.Types.Unique.DFM
import GHC.Unit.Module.WholeCoreBindings
+import GHC.Utils.Logger (Logger)
{- **********************************************************************
@@ -140,6 +142,12 @@ extendClosureEnv :: ClosureEnv -> [(Name,ForeignHValue)] -> ClosureEnv
extendClosureEnv cl_env pairs
= extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs]
+data PkgsLoadedEnv =
+ PkgsLoadedEnv {
+ ple_pkgs_loaded :: !PkgsLoaded,
+ ple_logger :: !Logger
+ }
+
type PkgsLoaded = UniqDFM UnitId LoadedPkgInfo
data LoadedPkgInfo
=====================================
ghc/Main.hs
=====================================
@@ -218,6 +218,8 @@ main' postLoadMode units dflags0 args flagWarnings = do
`gopt_set` Opt_UseBytecodeRatherThanObjects
-- By default enable the debugger by inserting breakpoints
`gopt_set` Opt_InsertBreakpoints
+ -- Speed up symbol lookup
+ `gopt_set` Opt_CacheLoadedLibraryUnits
logger1 <- getLogger
let logger2 = setLogFlags logger1 (initLogFlags dflags2)
=====================================
testsuite/tests/rts/linker/Makefile
=====================================
@@ -140,35 +140,3 @@ T20918:
T21618:
"$(TEST_HC)" -c T21618_c.c -o T21618_c.o
echo main | '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) T21618_c.o T21618.hs
-
-REUSE_DB=db
-REUSE_CONF=reuse.conf
-REUSE_PKG=pkg-reuse
-
-.PHONY: T23415
-T23415:
- mkdir -p "$(REUSE_PKG)"/{lib,hi}
- mkdir -p src
- mkdir -p "$(REUSE_DB)"
- mv Reuse.hs ReusePlugin.hs src/
- "$(TEST_HC)" $(filter-out -rtsopts, $(TEST_HC_OPTS)) \
- -dynamic-too \
- -hidir "$(REUSE_PKG)/hi/" \
- -O0 \
- -this-unit-id reuse-1.0 \
- -package ghc \
- -c src/*
- "$(TEST_HC)" $(filter-out -rtsopts, $(TEST_HC_OPTS)) \
- -dynamic -shared -fPIC \
- -hidir "$(REUSE_PKG)/hi/" \
- -this-unit-id reuse-1.0 \
- -package ghc \
- -O0 \
- -o "$(REUSE_PKG)/lib/libHSreuse-1.0-ghc$(shell "$(TEST_HC)" --numeric-version)$(dllext)" src/*.dyn_o
- "$(GHC_PKG)" --no-user-package-db --package-db="$(REUSE_DB)" recache
- "$(GHC_PKG)" --no-user-package-db --package-db="$(REUSE_DB)" register "$(REUSE_CONF)"
- "$(TEST_HC)" $(TEST_HC_OPTS_INTERACTIVE) \
- -package-db $(REUSE_DB) \
- -v0 +RTS -Dl -RTS \
- -fplugin=ReusePlugin \
- -ghci-script Reuse.script
=====================================
testsuite/tests/rts/linker/T23415/Makefile
=====================================
@@ -0,0 +1,43 @@
+TOP=../../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+REUSE_DB=db
+REUSE_CONF=reuse.conf
+REUSE_PKG=pkg-reuse
+
+.PHONY: T23415a
+T23415a:
+ mkdir -p "$(REUSE_PKG)"/{lib,hi}
+ mkdir -p src
+ mkdir -p "$(REUSE_DB)"
+ mv Reuse.hs ReusePlugin.hs src/
+ "$(TEST_HC)" $(filter-out -rtsopts, $(TEST_HC_OPTS)) \
+ -dynamic-too \
+ -hidir "$(REUSE_PKG)/hi/" \
+ -O0 \
+ -this-unit-id reuse-1.0 \
+ -package ghc \
+ -c src/*
+ "$(TEST_HC)" $(filter-out -rtsopts, $(TEST_HC_OPTS)) \
+ -dynamic -shared -fPIC \
+ -hidir "$(REUSE_PKG)/hi/" \
+ -this-unit-id reuse-1.0 \
+ -package ghc \
+ -O0 \
+ -o "$(REUSE_PKG)/lib/libHSreuse-1.0-ghc$(shell "$(TEST_HC)" --numeric-version)$(dllext)" src/*.dyn_o
+ "$(GHC_PKG)" --no-user-package-db --package-db="$(REUSE_DB)" recache
+ "$(GHC_PKG)" --no-user-package-db --package-db="$(REUSE_DB)" register "$(REUSE_CONF)"
+ "$(TEST_HC)" $(TEST_HC_OPTS_INTERACTIVE) \
+ -package-db $(REUSE_DB) \
+ -v0 +RTS -Dl -RTS \
+ -fplugin=ReusePlugin \
+ -ghci-script Reuse.script
+
+.PHONY: T23415b
+T23415b:
+ ./prepare-load.sh "$(TEST_HC)" " $(filter-out -rtsopts, $(TEST_HC_OPTS))" "$(GHC_PKG)" "$(dllext)" 30 100 1000
+
+.PHONY: T23415d
+T23415d: T23415b
+ "$(TEST_HC)" -package-db=db -fcache-loaded-library-units -v0 --interactive -ghci-script T23415.script
=====================================
testsuite/tests/rts/linker/Reuse.hs → testsuite/tests/rts/linker/T23415/Reuse.hs
=====================================
=====================================
testsuite/tests/rts/linker/Reuse.script → testsuite/tests/rts/linker/T23415/Reuse.script
=====================================
=====================================
testsuite/tests/rts/linker/ReusePlugin.hs → testsuite/tests/rts/linker/T23415/ReusePlugin.hs
=====================================
=====================================
testsuite/tests/rts/linker/T23415.stderr → testsuite/tests/rts/linker/T23415/T23415a.stderr
=====================================
=====================================
testsuite/tests/rts/linker/T23415/T23415b.script
=====================================
@@ -0,0 +1,13 @@
+import Data.Time.Clock.System
+import System.IO
+import Data.Int
+start <- systemSeconds <$> getSystemTime
+writeFile "start-time" (show start)
+hPutStrLn stderr "--------------------- START"
+:load Main
+hPutStrLn stderr "--------------------- LOADED"
+main
+hPutStrLn stderr "--------------------- EXECUTED"
+end <- systemSeconds <$> getSystemTime
+start :: Int64 <- readIO =<< readFile "start-time"
+hPutStrLn stderr (show (end - start) ++ " seconds")
=====================================
testsuite/tests/rts/linker/T23415/all.T
=====================================
@@ -0,0 +1,36 @@
+setTestOpts([
+ # unless(doing_ghci, skip),
+ unless(have_dynamic(),skip),
+])
+
+######################################
+# https://gitlab.haskell.org/ghc/ghc/-/issues/23415
+
+######################################
+# When loading a Haskell symbol from a shared object (here `libHS_Reuse-1.0-ghcXXX.so` created from `Reuse.hs`),
+# the native object loader in `loadNativeObj_ELF` stores the object code in a list.
+# When the function is called again for the same object, the previously stored object code is returned.
+test('T23415a',
+ [extra_files(['Reuse.hs', 'Reuse.script', 'reuse.conf', 'ReusePlugin.hs']),
+ grep_stderr('Found existing OC for.*libHSreuse-1.*'),
+ req_rts_linker],
+ makefile_test, ['T23415a'])
+
+test('T23415b',
+ [extra_files(['prepare-load.sh']),
+ pre_cmd('$MAKE T23415b'),
+ req_rts_linker,
+ # extra_hc_opts('-package-db=db -fno-cache-loaded-library-units -v3')],
+ extra_hc_opts('-package-db=db -fno-cache-loaded-library-units -v3')],
+ ghci_script, ['T23415b.script'])
+
+test('T23415c',
+ [extra_files(['prepare-load.sh']),
+ pre_cmd('$MAKE T23415b'),
+ req_rts_linker],
+ multimod_compile_and_run, ['Main', '-dynamic -package-db=db -O0'])
+
+test('T23415d',
+ [extra_files(['prepare-load.sh']),
+ req_rts_linker],
+ makefile_test, ['T23415d'])
=====================================
testsuite/tests/rts/linker/T23415/prepare-load.sh
=====================================
@@ -0,0 +1,203 @@
+#!/usr/bin/env bash
+
+set -e
+
+if [[ $# < 6 ]]
+then
+ echo "Usage: ./prepare-transitive-load.sh GHC GHC_OPTS GHC_PKG DLL_EXT NUM_PKGS NUM_FUNCS NUM_REFS"
+ exit 1
+fi
+
+ghc_cmd="$1"
+ghc_opts="$2"
+ghc_pkg_cmd="$3"
+dll_ext="$4"
+num_pkgs="$5"
+num_funcs="$6"
+num_refs="$7"
+
+base="$PWD"
+src="$base/src"
+build="$base/build"
+db="$base/db"
+
+ghc_pkg()
+{
+ eval "${ghc_pkg_cmd at Q} --no-user-package-db --package-db=${db at Q} $@"
+}
+
+ghc()
+{
+ eval "${ghc_cmd at Q} $ghc_opts $@"
+}
+
+version_suffix=$(ghc --numeric-version)
+
+range()
+{
+ eval echo "{1..$1}"
+}
+
+append()
+{
+ echo -e "$*" >> $file_name
+}
+
+create_sources()
+{
+ local num="$1"
+ local prev="$(($num - 1))"
+ local name="load${num}"
+ local module_name="Load${num}"
+ local fun expr
+ file_name="${module_name}.hs"
+ cd "$base"
+ mkdir -p "$src/$name" "$build/$name/lib" "$build/$name/hi"
+ cd "$src"
+ cd "$name"
+ append "module $module_name where"
+ if [[ $prev != 0 ]]
+ then
+ append "\nimport Load${prev}"
+ fi
+ for j in $(range $num_funcs)
+ do
+ fun="num${num}_${j}"
+ append "\n$fun :: Int"
+ if [[ $prev == 0 ]]
+ then
+ expr="$j"
+ else
+ expr="num${prev}_${j}"
+ fi
+ append "$fun = $expr"
+ done
+ cd "$build"
+ file_name="${name}/${name}.conf"
+ append "name: $name
+version: 1.0
+id: ${name}-1.0
+key: ${name}-1.0
+exposed: True
+exposed-modules: ${module_name}
+import-dirs: \${pkgroot}/build/${name}/hi
+dynamic-library-dirs: \${pkgroot}/build/${name}/lib
+hs-libraries: HS${name}-1.0"
+ if [[ $prev != 0 ]]
+ then
+ append "depends: load${prev}-1.0"
+ fi
+}
+
+create_package()
+{
+ local num="$1"
+ local prev="$(($num - 1))"
+ local name="load${num}"
+ local module_name="Load${num}"
+ local pkg_build="$build/$name"
+ if [[ $prev != 0 ]]
+ then
+ extra="-package load${prev}"
+ fi
+ local opts="-package-db ${db at Q} -hidir ${pkg_build at Q}/hi -O0 -this-unit-id ${name}-1.0 $extra"
+ # dynamic-too produces .dyn_o and .dyn_hi
+ # eval "${ghc at Q} $opts -dynamic-too -c ${src at Q}/${name}/${module_name}.hs"
+ ghc "$opts -dynamic-too -c ${src at Q}/${name}/${module_name}.hs"
+ # -dynamic instructs GHC to link against shared objects of dependencies
+ ghc "$opts -dynamic -shared -fPIC -o ${pkg_build at Q}/lib/libHS${name}-1.0-ghc${version_suffix}${dll_ext} ${src at Q}/${name}/${module_name}.dyn_o"
+ ghc_pkg register "${build at Q}/${name}/${name}.conf"
+}
+
+mkdir "$src" "$build" "$db"
+
+for i in $(range $num_pkgs)
+do
+ create_sources $i
+done
+
+cd "$base"
+ghc_pkg recache
+
+for i in $(range $num_pkgs)
+do
+ create_package $i
+done
+
+cd "$base"
+
+file_name="Main.hs"
+
+append "module Main where"
+
+# for i in $(range $num_pkgs)
+# do
+# append "import Load${i}"
+# done
+
+append "import Load${num_pkgs}"
+
+for i in $(range $num_refs)
+do
+ append "
+ref${i} :: Int
+ref${i} = sum ["
+ for j in $(range $num_funcs)
+ do
+ append " num${num_pkgs}_${j},"
+ done
+ append " 0]"
+done
+
+append '
+main :: IO ()
+main = do'
+
+append ' putStrLn $ show $ sum ['
+
+for i in $(range $num_refs)
+do
+ append " ref${i},"
+done
+
+append " 0]"
+
+file_name=T23415.script
+
+append 'import Data.Time.Clock.System
+import System.IO
+import Data.Int
+start <- systemSeconds <$> getSystemTime
+writeFile "start-time" (show start)
+hPutStrLn stderr "--------------------- START"
+'
+
+for i in $(eval echo "{1..${num_pkgs}}")
+# for i in $(eval echo "{${num_pkgs}..1}")
+do
+ append "import Load${i}
+putStrLn (show num${i}_1)"
+done
+
+append '
+endLoad1 <- systemSeconds <$> getSystemTime
+start :: Int64 <- readIO =<< readFile "start-time"
+writeFile "start-time" (show endLoad1)
+hPutStrLn stderr ("--------------------- LOADED 1: " ++ show (endLoad1 - start) ++ " seconds")
+:load Main
+endLoad2 <- systemSeconds <$> getSystemTime
+endLoad1 :: Int64 <- readIO =<< readFile "start-time"
+hPutStrLn stderr ("--------------------- LOADED 2: " ++ show (endLoad2 - endLoad1) ++ " seconds")
+main
+endExec1 <- systemSeconds <$> getSystemTime
+hPutStrLn stderr ("--------------------- EXECUTED 1: " ++ show (endExec1 - endLoad2) ++ " seconds")
+main
+endExec2 <- systemSeconds <$> getSystemTime
+writeFile "start-time" (show endExec2)
+hPutStrLn stderr ("--------------------- EXECUTED 2: " ++ show (endExec2 - endExec1) ++ " seconds")
+:reload
+main
+endExec3 <- systemSeconds <$> getSystemTime
+endExec2 :: Int64 <- readIO =<< readFile "start-time"
+hPutStrLn stderr ("--------------------- EXECUTED 3: " ++ show (endExec3 - endExec2) ++ " seconds")
+'
=====================================
testsuite/tests/rts/linker/reuse.conf → testsuite/tests/rts/linker/T23415/reuse.conf
=====================================
=====================================
testsuite/tests/rts/linker/all.T
=====================================
@@ -159,18 +159,3 @@ test('T20918',
test('T21618',
[unless(opsys('mingw32'), skip), req_rts_linker],
makefile_test, ['T21618'])
-
-######################################
-# https://gitlab.haskell.org/ghc/ghc/-/issues/23415
-# When loading a Haskell symbol from a shared object (here `libHS_Reuse-1.0-ghcXXX.so` created from `Reuse.hs`),
-# the native object loader in `loadNativeObj_ELF` stores the object code in a list.
-# When the function is called again for the same object, the previously stored object code is returned.
-test('T23415',
- [extra_files(['Reuse.hs', 'Reuse.script', 'reuse.conf', 'ReusePlugin.hs']),
- unless(arch('x86_64'), skip),
- unless(opsys('linux'), skip),
- unless(doing_ghci, skip),
- unless(have_dynamic(),skip),
- # grep_stderr('Found existing OC for.*libHSreuse-1.*'),
- req_rts_linker],
- makefile_test, ['T23415'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e7f4491aaae861bb2c64bb8e9ffa8aaf22ef8bff...17319148af7f860ab0c7a813b601767a8611229a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e7f4491aaae861bb2c64bb8e9ffa8aaf22ef8bff...17319148af7f860ab0c7a813b601767a8611229a
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/20240315/3270749a/attachment-0001.html>
More information about the ghc-commits
mailing list