[Git][ghc/ghc][wip/romes/rts-linker-direct-symbol-lookup] 9 commits: loader: Note down suggestion for needed_mods
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Thu Mar 28 13:41:55 UTC 2024
Rodrigo Mesquita pushed to branch wip/romes/rts-linker-direct-symbol-lookup at Glasgow Haskell Compiler / GHC
Commits:
341c836a by Rodrigo Mesquita at 2024-03-28T13:41:14+00:00
loader: Note down suggestion for needed_mods
The associated ticket is #24600
- - - - -
eaac1931 by Rodrigo Mesquita at 2024-03-28T13:41:18+00:00
rts: free error message before returning
Fixes a memory leak in rts/linker/PEi386.c
- - - - -
b12635aa by Rodrigo Mesquita at 2024-03-28T13:41:18+00:00
Start writing test
- - - - -
fc0bdd47 by Alexis King at 2024-03-28T13:41:18+00:00
linker: Avoid linear search when looking up Haskell symbols via dlsym
Write Note [Looking up symbols in the relevant objects]
Write Note [Symbols may not be found in pkgs_loaded]
Use lookupHsSymbol for PrimOps too
- - - - -
8619bc42 by Rodrigo Mesquita at 2024-03-28T13:41:18+00:00
wip: make addDLL wrapper around loadNativeObj
- - - - -
63d99f94 by Alexis King at 2024-03-28T13:41:18+00:00
wip: use loadNativeObj to implement addDLL
- - - - -
e3f6ced0 by Rodrigo Mesquita at 2024-03-28T13:41:18+00:00
Refactor loadNativeObj_ELF to _POSIX and delete dl_mutex
CPP Support loadNativeObj in MachO
- - - - -
95c7569e by Rodrigo Mesquita at 2024-03-28T13:41:18+00:00
Use symbol cache in internal interpreter too
This commit makes the symbol cache that was used by the external
interpreter available for the internal interpreter too.
This follows from the analysis in #23415 that suggests the internal
interpreter could benefit from this cache too, and that there is no good
reason not to have the cache for it too. It also makes it a bit more
uniform to have the symbol cache range over both the internal and
external interpreter.
This commit also refactors the cache into a function which is used by
both `lookupSymbol` and also by `lookupSymbolInDLL`, extending the
caching logic to `lookupSymbolInDLL` too.
- - - - -
573b9729 by Rodrigo Mesquita at 2024-03-28T13:41:18+00:00
Implement lookupSymbolInDLL for ExternalInterp
- - - - -
29 changed files:
- + T23415/Makefile
- + T23415/main.hs
- + T23415/make_shared_libs.sh
- + T23415/new-main.hs
- + T23415/run_test.sh
- compiler/GHC.hs
- compiler/GHC/ByteCode/Linker.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Plugins.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Linker/MacOS.hs
- compiler/GHC/Linker/Types.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/Runtime/Interpreter/JS.hs
- compiler/GHC/Runtime/Interpreter/Types.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/ObjLink.hs
- libraries/ghci/GHCi/Run.hs
- rts/Linker.c
- rts/LinkerInternals.h
- rts/RtsSymbols.c
- rts/include/rts/Linker.h
- rts/linker/Elf.c
- rts/linker/Elf.h
- + rts/linker/LoadNativeObjPosix.c
- + rts/linker/LoadNativeObjPosix.h
- rts/linker/PEi386.c
- rts/rts.cabal
- testsuite/tests/ghci/linking/dyn/T3372.hs
Changes:
=====================================
T23415/Makefile
=====================================
@@ -0,0 +1,10 @@
+.PHONY: run build clean
+
+run:
+ sh run_test.sh
+
+build:
+ sh make_shared_libs.sh
+
+clean:
+ rm -f lib*.out main main.o main.hi test.o tags
=====================================
T23415/main.hs
=====================================
@@ -0,0 +1,20 @@
+import Control.Monad
+import System.FilePath
+import System.Directory
+import GHCi.ObjLink
+
+hsLoadObjs = do
+ cwd <- getCurrentDirectory
+ forM_ [0..499] $ \i ->
+ loadDLL (cwd </> "lib" ++ show i ++ ".out")
+
+hsLoadSymbols = do
+ forM_ [0..99] $ \j ->
+ forM_ [0..499] $ \i ->
+ lookupSymbol ("lib" ++ show i ++ "_" ++ show j)
+
+main = do
+ initObjLinker RetainCAFs
+ hsLoadObjs
+ hsLoadSymbols
+
=====================================
T23415/make_shared_libs.sh
=====================================
@@ -0,0 +1,20 @@
+#!/bin/sh
+
+example_dylib=$(basename -- $(find $(ghc --print-libdir) -name libHS* -not -name *.a | head -n1))
+dylib_ext="${example_dylib##*.}"
+# we try .out instead of using the correct extension.
+
+i=0
+while [ $i -lt 500 ]; do
+ j=0
+ while [ $j -lt 100 ]; do
+ echo "int lib${i}_$j(void) { return $i; }" >> "lib$i.c"
+ j=$(( j + 1 ))
+ done
+ cc -o "lib$i.o" -c "lib$i.c" -fPIC
+ cc -shared "lib$i.o" -o "lib$i.out" # "lib$i.$dylib_ext"
+ rm "lib$i.c" "lib$i.o"
+ i=$(( i + 1 ))
+done
+
+
=====================================
T23415/new-main.hs
=====================================
@@ -0,0 +1,29 @@
+import Data.Either
+import Data.Foldable
+import Data.Map as M
+import Control.Monad
+import System.FilePath
+import System.Directory
+import GHCi.ObjLink
+
+libname i = "lib" ++ show i
+
+hsLoadObjs = do
+ cwd <- getCurrentDirectory
+ foldrM (\i acc -> do
+ Right handle <- loadDLL (cwd </> libname i ++ ".out")
+ return $ M.insert (libname i) handle acc
+ )
+ M.empty [0..499]
+
+hsLoadSymbols handles = do
+ forM_ [0..499] $ \i ->
+ forM_ [0..99] $ \j -> do
+ let symbolname = libname i ++ "_" ++ show j
+ lookupSymbolInDLL (handles M.! libname i) symbolname
+
+main = do
+ initObjLinker RetainCAFs
+ handles <- hsLoadObjs
+ hsLoadSymbols handles
+ print "hi"
=====================================
T23415/run_test.sh
=====================================
@@ -0,0 +1,8 @@
+#!/bin/sh
+
+GHC1=/Users/romes/ghc-dev/ghc/_build/stage1/bin/ghc
+GHC2=/Users/romes/ghc-dev/23415/_build/stage1/bin/ghc
+
+# $GHC1 --interactive main.hs -package directory -package ghci -package filepath
+$GHC2 --interactive new-main.hs -package directory -package ghci -package filepath -package containers
+
=====================================
compiler/GHC.hs
=====================================
@@ -394,6 +394,7 @@ import GHC.Types.Name.Ppr
import GHC.Types.TypeEnv
import GHC.Types.BreakInfo
import GHC.Types.PkgQual
+import GHC.Types.Unique.FM
import GHC.Unit
import GHC.Unit.Env
@@ -673,6 +674,7 @@ setTopSessionDynFlags :: GhcMonad m => DynFlags -> m ()
setTopSessionDynFlags dflags = do
hsc_env <- getSession
logger <- getLogger
+ lookup_cache <- liftIO $ newMVar emptyUFM
-- Interpreter
interp <- if
@@ -702,7 +704,7 @@ setTopSessionDynFlags dflags = do
}
s <- liftIO $ newMVar InterpPending
loader <- liftIO Loader.uninitializedLoader
- return (Just (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader))
+ return (Just (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache))
-- JavaScript interpreter
| ArchJavaScript <- platformArch (targetPlatform dflags)
@@ -720,7 +722,7 @@ setTopSessionDynFlags dflags = do
, jsInterpFinderOpts = initFinderOpts dflags
, jsInterpFinderCache = hsc_FC hsc_env
}
- return (Just (Interp (ExternalInterp (ExtJS (ExtInterpState cfg s))) loader))
+ return (Just (Interp (ExternalInterp (ExtJS (ExtInterpState cfg s))) loader lookup_cache))
-- Internal interpreter
| otherwise
@@ -728,7 +730,7 @@ setTopSessionDynFlags dflags = do
#if defined(HAVE_INTERNAL_INTERPRETER)
do
loader <- liftIO Loader.uninitializedLoader
- return (Just (Interp InternalInterp loader))
+ return (Just (Interp InternalInterp loader lookup_cache))
#else
return Nothing
#endif
=====================================
compiler/GHC/ByteCode/Linker.hs
=====================================
@@ -24,6 +24,7 @@ import GHCi.RemoteTypes
import GHCi.ResolvedBCO
import GHC.Builtin.PrimOps
+import GHC.Builtin.PrimOps.Ids
import GHC.Builtin.Names
import GHC.Unit.Types
@@ -38,6 +39,8 @@ import GHC.Utils.Outputable
import GHC.Types.Name
import GHC.Types.Name.Env
+import qualified GHC.Types.Id as Id
+import GHC.Types.Unique.DFM
import Language.Haskell.Syntax.Module.Name
@@ -52,31 +55,32 @@ import GHC.Exts
linkBCO
:: Interp
+ -> PkgsLoaded
-> LinkerEnv
-> NameEnv Int
-> UnlinkedBCO
-> IO ResolvedBCO
-linkBCO interp le bco_ix
+linkBCO interp pkgs_loaded le bco_ix
(UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do
-- fromIntegral Word -> Word64 should be a no op if Word is Word64
-- otherwise it will result in a cast to longlong on 32bit systems.
- lits <- mapM (fmap fromIntegral . lookupLiteral interp le) (ssElts lits0)
- ptrs <- mapM (resolvePtr interp le bco_ix) (ssElts ptrs0)
+ lits <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded le) (ssElts lits0)
+ ptrs <- mapM (resolvePtr interp pkgs_loaded le bco_ix) (ssElts ptrs0)
return (ResolvedBCO isLittleEndian arity insns bitmap
(listArray (0, fromIntegral (sizeSS lits0)-1) lits)
(addListToSS emptySS ptrs))
-lookupLiteral :: Interp -> LinkerEnv -> BCONPtr -> IO Word
-lookupLiteral interp le ptr = case ptr of
+lookupLiteral :: Interp -> PkgsLoaded -> LinkerEnv -> BCONPtr -> IO Word
+lookupLiteral interp pkgs_loaded le ptr = case ptr of
BCONPtrWord lit -> return lit
BCONPtrLbl sym -> do
Ptr a# <- lookupStaticPtr interp sym
return (W# (int2Word# (addr2Int# a#)))
BCONPtrItbl nm -> do
- Ptr a# <- lookupIE interp (itbl_env le) nm
+ Ptr a# <- lookupIE interp pkgs_loaded (itbl_env le) nm
return (W# (int2Word# (addr2Int# a#)))
BCONPtrAddr nm -> do
- Ptr a# <- lookupAddr interp (addr_env le) nm
+ Ptr a# <- lookupAddr interp pkgs_loaded (addr_env le) nm
return (W# (int2Word# (addr2Int# a#)))
BCONPtrStr _ ->
-- should be eliminated during assembleBCOs
@@ -90,19 +94,19 @@ lookupStaticPtr interp addr_of_label_string = do
Nothing -> linkFail "GHC.ByteCode.Linker: can't find label"
(unpackFS addr_of_label_string)
-lookupIE :: Interp -> ItblEnv -> Name -> IO (Ptr ())
-lookupIE interp ie con_nm =
+lookupIE :: Interp -> PkgsLoaded -> ItblEnv -> Name -> IO (Ptr ())
+lookupIE interp pkgs_loaded ie con_nm =
case lookupNameEnv ie con_nm of
Just (_, ItblPtr a) -> return (fromRemotePtr (castRemotePtr a))
Nothing -> do -- try looking up in the object files.
let sym_to_find1 = nameToCLabel con_nm "con_info"
- m <- lookupSymbol interp sym_to_find1
+ m <- lookupHsSymbol interp pkgs_loaded con_nm "con_info"
case m of
Just addr -> return addr
Nothing
-> do -- perhaps a nullary constructor?
let sym_to_find2 = nameToCLabel con_nm "static_info"
- n <- lookupSymbol interp sym_to_find2
+ n <- lookupHsSymbol interp pkgs_loaded con_nm "static_info"
case n of
Just addr -> return addr
Nothing -> linkFail "GHC.ByteCode.Linker.lookupIE"
@@ -110,34 +114,35 @@ lookupIE interp ie con_nm =
unpackFS sym_to_find2)
-- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode
-lookupAddr :: Interp -> AddrEnv -> Name -> IO (Ptr ())
-lookupAddr interp ae addr_nm = do
+lookupAddr :: Interp -> PkgsLoaded -> AddrEnv -> Name -> IO (Ptr ())
+lookupAddr interp pkgs_loaded ae addr_nm = do
case lookupNameEnv ae addr_nm of
Just (_, AddrPtr ptr) -> return (fromRemotePtr ptr)
Nothing -> do -- try looking up in the object files.
let sym_to_find = nameToCLabel addr_nm "bytes"
-- see Note [Bytes label] in GHC.Cmm.CLabel
- m <- lookupSymbol interp sym_to_find
+ m <- lookupHsSymbol interp pkgs_loaded addr_nm "bytes"
case m of
Just ptr -> return ptr
Nothing -> linkFail "GHC.ByteCode.Linker.lookupAddr"
(unpackFS sym_to_find)
-lookupPrimOp :: Interp -> PrimOp -> IO (RemotePtr ())
-lookupPrimOp interp primop = do
+lookupPrimOp :: Interp -> PkgsLoaded -> PrimOp -> IO (RemotePtr ())
+lookupPrimOp interp pkgs_loaded primop = do
let sym_to_find = primopToCLabel primop "closure"
- m <- lookupSymbol interp (mkFastString sym_to_find)
+ m <- lookupHsSymbol interp pkgs_loaded (Id.idName $ primOpId primop) "closure"
case m of
Just p -> return (toRemotePtr p)
Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE(primop)" sym_to_find
resolvePtr
:: Interp
+ -> PkgsLoaded
-> LinkerEnv
-> NameEnv Int
-> BCOPtr
-> IO ResolvedBCOPtr
-resolvePtr interp le bco_ix ptr = case ptr of
+resolvePtr interp pkgs_loaded le bco_ix ptr = case ptr of
BCOPtrName nm
| Just ix <- lookupNameEnv bco_ix nm
-> return (ResolvedBCORef ix) -- ref to another BCO in this group
@@ -149,20 +154,38 @@ resolvePtr interp le bco_ix ptr = case ptr of
-> assertPpr (isExternalName nm) (ppr nm) $
do
let sym_to_find = nameToCLabel nm "closure"
- m <- lookupSymbol interp sym_to_find
+ m <- lookupHsSymbol interp pkgs_loaded nm "closure"
case m of
Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p))
Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (unpackFS sym_to_find)
BCOPtrPrimOp op
- -> ResolvedBCOStaticPtr <$> lookupPrimOp interp op
+ -> ResolvedBCOStaticPtr <$> lookupPrimOp interp pkgs_loaded op
BCOPtrBCO bco
- -> ResolvedBCOPtrBCO <$> linkBCO interp le bco_ix bco
+ -> ResolvedBCOPtrBCO <$> linkBCO interp pkgs_loaded le bco_ix bco
BCOPtrBreakArray breakarray
-> withForeignRef breakarray $ \ba -> return (ResolvedBCOPtrBreakArray ba)
+lookupHsSymbol :: Interp -> PkgsLoaded -> Name -> String -> IO (Maybe (Ptr ()))
+lookupHsSymbol interp pkgs_loaded nm sym_suffix = do
+ massertPpr (isExternalName nm) (ppr nm)
+ let sym_to_find = nameToCLabel nm sym_suffix
+ pkg_id = moduleUnitId $ nameModule nm
+ loaded_dlls = maybe [] loaded_pkg_hs_dlls $ lookupUDFM pkgs_loaded pkg_id
+
+ go (dll:dlls) = do
+ mb_ptr <- lookupSymbolInDLL interp dll sym_to_find
+ case mb_ptr of
+ Just ptr -> pure (Just ptr)
+ Nothing -> go dlls
+ go [] =
+ -- See Note [Symbols may not be found in pkgs_loaded] in GHC.Linker.Types
+ lookupSymbol interp sym_to_find
+
+ go loaded_dlls
+
linkFail :: String -> String -> IO a
linkFail who what
= throwGhcExceptionIO (ProgramError $
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -2665,7 +2665,7 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr = do
case interp of
-- always generate JS code for the JS interpreter (no bytecode!)
- Interp (ExternalInterp (ExtJS i)) _ ->
+ Interp (ExternalInterp (ExtJS i)) _ _ ->
jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id
_ -> do
=====================================
compiler/GHC/Driver/Plugins.hs
=====================================
@@ -420,12 +420,12 @@ loadExternalPluginLib :: FilePath -> IO ()
loadExternalPluginLib path = do
-- load library
loadDLL path >>= \case
- Just errmsg -> pprPanic "loadExternalPluginLib"
- (vcat [ text "Can't load plugin library"
- , text " Library path: " <> text path
- , text " Error : " <> text errmsg
- ])
- Nothing -> do
+ Left errmsg -> pprPanic "loadExternalPluginLib"
+ (vcat [ text "Can't load plugin library"
+ , text " Library path: " <> text path
+ , text " Error : " <> text errmsg
+ ])
+ Right _ -> do -- TODO: use returned LoadedDLL?
-- resolve objects
resolveObjs >>= \case
True -> return ()
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -55,6 +55,7 @@ import GHC.Tc.Utils.Monad
import GHC.Runtime.Interpreter
import GHCi.RemoteTypes
import GHC.Iface.Load
+import GHCi.Message (LoadedDLL)
import GHC.ByteCode.Linker
import GHC.ByteCode.Asm
@@ -172,7 +173,7 @@ emptyLoaderState = LoaderState
--
-- The linker's symbol table is populated with RTS symbols using an
-- explicit list. See rts/Linker.c for details.
- where init_pkgs = unitUDFM rtsUnitId (LoadedPkgInfo rtsUnitId [] [] emptyUniqDSet)
+ where init_pkgs = unitUDFM rtsUnitId (LoadedPkgInfo rtsUnitId [] [] [] emptyUniqDSet)
extendLoadedEnv :: Interp -> [(Name,ForeignHValue)] -> IO ()
extendLoadedEnv interp new_bindings =
@@ -221,8 +222,8 @@ loadDependencies
-> SrcSpan
-> [Module]
-> IO (LoaderState, SuccessFlag, [Linkable], PkgsLoaded) -- ^ returns the set of linkables required
+-- When called, the loader state must have been initialized (see `initLoaderState`)
loadDependencies interp hsc_env pls span needed_mods = do
--- initLoaderState (hsc_dflags hsc_env) dl
let opts = initLinkDepsOpts hsc_env
-- Find what packages and linkables are required
@@ -512,25 +513,25 @@ preloadLib interp hsc_env lib_paths framework_paths pls lib_spec = do
DLL dll_unadorned -> do
maybe_errstr <- loadDLL interp (platformSOName platform dll_unadorned)
case maybe_errstr of
- Nothing -> maybePutStrLn logger "done"
- Just mm | platformOS platform /= OSDarwin ->
+ Right _ -> maybePutStrLn logger "done"
+ Left mm | platformOS platform /= OSDarwin ->
preloadFailed mm lib_paths lib_spec
- Just mm | otherwise -> do
+ Left mm | otherwise -> do
-- As a backup, on Darwin, try to also load a .so file
-- since (apparently) some things install that way - see
-- ticket #8770.
let libfile = ("lib" ++ dll_unadorned) <.> "so"
err2 <- loadDLL interp libfile
case err2 of
- Nothing -> maybePutStrLn logger "done"
- Just _ -> preloadFailed mm lib_paths lib_spec
+ Right _ -> maybePutStrLn logger "done"
+ Left _ -> preloadFailed mm lib_paths lib_spec
return pls
DLLPath dll_path -> do
do maybe_errstr <- loadDLL interp dll_path
case maybe_errstr of
- Nothing -> maybePutStrLn logger "done"
- Just mm -> preloadFailed mm lib_paths lib_spec
+ Right _ -> maybePutStrLn logger "done"
+ Left mm -> preloadFailed mm lib_paths lib_spec
return pls
Framework framework ->
@@ -614,13 +615,14 @@ 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 le bco_ix root_ul_bco
+ resolved <- linkBCO interp (pkgs_loaded pls) le bco_ix root_ul_bco
[root_hvref] <- createBCOs interp [resolved]
fhv <- mkFinalizedHValue interp root_hvref
return (pls, fhv)
where
free_names = uniqDSetToList (bcoFreeNames root_ul_bco)
+ -- TODO(24600): We should be using a Set-like datatype, as this may contain lots of duplicates.
needed_mods :: [Module]
needed_mods = [ nameModule n | n <- free_names,
isExternalName n, -- Names from other modules
@@ -677,7 +679,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 le2 [cbc]
+ new_bindings <- linkSomeBCOs interp (pkgs_loaded pls) le2 [cbc]
nms_fhvs <- makeForeignNamedHValueRefs interp new_bindings
let ce2 = extendClosureEnv (closure_env le2) nms_fhvs
!pls2 = pls { linker_env = le2 { closure_env = ce2 } }
@@ -686,6 +688,7 @@ loadDecls interp hsc_env span cbc at CompiledByteCode{..} = do
free_names = uniqDSetToList $
foldr (unionUniqDSets . bcoFreeNames) emptyUniqDSet bc_bcos
+ -- TODO(24600): We should be using a Set-like datatype, as this may contain lots of duplicates.
needed_mods :: [Module]
needed_mods = [ nameModule n | n <- free_names,
isExternalName n, -- Names from other modules
@@ -858,8 +861,8 @@ dynLoadObjs interp hsc_env pls at LoaderState{..} objs = do
changeTempFilesLifetime tmpfs TFL_GhcSession [soFile]
m <- loadDLL interp soFile
case m of
- Nothing -> return $! pls { temp_sos = (libPath, libName) : temp_sos }
- Just err -> linkFail msg err
+ Right _ -> return $! pls { temp_sos = (libPath, libName) : temp_sos }
+ Left err -> linkFail msg err
where
msg = "GHC.Linker.Loader.dynLoadObjs: Loading temp shared object failed"
@@ -899,7 +902,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 le2 cbcs
+ names_and_refs <- linkSomeBCOs interp (pkgs_loaded pls) le2 cbcs
-- We only want to add the external ones to the ClosureEnv
let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs
@@ -914,6 +917,7 @@ dynLinkBCOs interp pls bcos = do
-- Link a bunch of BCOs and return references to their values
linkSomeBCOs :: Interp
+ -> PkgsLoaded
-> LinkerEnv
-> [CompiledByteCode]
-> IO [(Name,HValueRef)]
@@ -921,7 +925,7 @@ linkSomeBCOs :: Interp
-- the incoming unlinked BCOs. Each gives the
-- value of the corresponding unlinked BCO
-linkSomeBCOs interp le mods = foldr fun do_link mods []
+linkSomeBCOs interp pkgs_loaded le mods = foldr fun do_link mods []
where
fun CompiledByteCode{..} inner accum = inner (bc_bcos : accum)
@@ -930,7 +934,7 @@ linkSomeBCOs interp 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 le bco_ix bco | bco <- flat ]
+ resolved <- sequence [ linkBCO interp pkgs_loaded le bco_ix bco | bco <- flat ]
hvrefs <- createBCOs interp resolved
return (zip names hvrefs)
@@ -1092,18 +1096,18 @@ loadPackages' interp hsc_env new_pks pls = do
-- Link dependents first
; pkgs' <- link pkgs deps
-- Now link the package itself
- ; (hs_cls, extra_cls) <- loadPackage interp hsc_env pkg_cfg
+ ; (hs_cls, extra_cls, loaded_dlls) <- loadPackage interp hsc_env pkg_cfg
; let trans_deps = unionManyUniqDSets [ addOneToUniqDSet (loaded_pkg_trans_deps loaded_pkg_info) dep_pkg
| dep_pkg <- deps
, Just loaded_pkg_info <- pure (lookupUDFM pkgs' dep_pkg)
]
- ; return (addToUDFM pkgs' new_pkg (LoadedPkgInfo new_pkg hs_cls extra_cls trans_deps)) }
+ ; return (addToUDFM pkgs' new_pkg (LoadedPkgInfo new_pkg hs_cls extra_cls loaded_dlls trans_deps)) }
| otherwise
= throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg)))
-loadPackage :: Interp -> HscEnv -> UnitInfo -> IO ([LibrarySpec], [LibrarySpec])
+loadPackage :: Interp -> HscEnv -> UnitInfo -> IO ([LibrarySpec], [LibrarySpec], [RemotePtr LoadedDLL])
loadPackage interp hsc_env pkg
= do
let dflags = hsc_dflags hsc_env
@@ -1145,7 +1149,9 @@ loadPackage interp hsc_env pkg
let classifieds = hs_classifieds ++ extra_classifieds
-- Complication: all the .so's must be loaded before any of the .o's.
- let known_dlls = [ dll | DLLPath dll <- classifieds ]
+ let known_hs_dlls = [ dll | DLLPath dll <- hs_classifieds ]
+ known_extra_dlls = [ dll | DLLPath dll <- extra_classifieds ]
+ known_dlls = known_hs_dlls ++ known_extra_dlls
#if defined(CAN_LOAD_DLL)
dlls = [ dll | DLL dll <- classifieds ]
#endif
@@ -1166,10 +1172,13 @@ loadPackage interp hsc_env pkg
loadFrameworks interp platform pkg
-- See Note [Crash early load_dyn and locateLib]
-- Crash early if can't load any of `known_dlls`
- mapM_ (load_dyn interp hsc_env True) known_dlls
+ mapM_ (load_dyn interp hsc_env True) known_extra_dlls
+ loaded_dlls <- mapMaybeM (load_dyn interp hsc_env True) known_hs_dlls
-- For remaining `dlls` crash early only when there is surely
-- no package's DLL around ... (not is_dyn)
mapM_ (load_dyn interp hsc_env (not is_dyn) . platformSOName platform) dlls
+#else
+ let loaded_dlls = []
#endif
-- After loading all the DLLs, we can load the static objects.
-- Ordering isn't important here, because we do one final link
@@ -1189,7 +1198,7 @@ loadPackage interp hsc_env pkg
if succeeded ok
then do
maybePutStrLn logger "done."
- return (hs_classifieds, extra_classifieds)
+ return (hs_classifieds, extra_classifieds, loaded_dlls)
else let errmsg = text "unable to load unit `"
<> pprUnitInfoForUser pkg <> text "'"
in throwGhcExceptionIO (InstallationError (showSDoc dflags errmsg))
@@ -1242,19 +1251,20 @@ restriction very easily.
-- can be passed directly to loadDLL. They are either fully-qualified
-- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so"). In the latter case,
-- loadDLL is going to search the system paths to find the library.
-load_dyn :: Interp -> HscEnv -> Bool -> FilePath -> IO ()
+load_dyn :: Interp -> HscEnv -> Bool -> FilePath -> IO (Maybe (RemotePtr LoadedDLL))
load_dyn interp hsc_env crash_early dll = do
r <- loadDLL interp dll
case r of
- Nothing -> return ()
- Just err ->
+ Right loaded_dll -> pure (Just loaded_dll)
+ Left err ->
if crash_early
then cmdLineErrorIO err
- else
+ else do
when (diag_wopt Opt_WarnMissedExtraSharedLib diag_opts)
$ logMsg logger
(mkMCDiagnostic diag_opts (WarningWithFlag Opt_WarnMissedExtraSharedLib) Nothing)
noSrcSpan $ withPprStyle defaultUserStyle (note err)
+ pure Nothing
where
diag_opts = initDiagOpts (hsc_dflags hsc_env)
logger = hsc_logger hsc_env
=====================================
compiler/GHC/Linker/MacOS.hs
=====================================
@@ -172,6 +172,6 @@ loadFramework interp extraPaths rootname
findLoadDLL (p:ps) errs =
do { dll <- loadDLL interp (p </> fwk_file)
; case dll of
- Nothing -> return Nothing
- Just err -> findLoadDLL ps ((p ++ ": " ++ err):errs)
+ Right _ -> return Nothing
+ Left err -> findLoadDLL ps ((p ++ ": " ++ err):errs)
}
=====================================
compiler/GHC/Linker/Types.hs
=====================================
@@ -40,7 +40,8 @@ import GHC.Prelude
import GHC.Unit ( UnitId, Module )
import GHC.ByteCode.Types ( ItblEnv, AddrEnv, CompiledByteCode )
import GHC.Fingerprint.Type ( Fingerprint )
-import GHCi.RemoteTypes ( ForeignHValue )
+import GHCi.RemoteTypes ( ForeignHValue, RemotePtr )
+import GHCi.Message ( LoadedDLL )
import GHC.Types.Var ( Id )
import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnvList, filterNameEnv )
@@ -75,6 +76,57 @@ initialised.
The LinkerEnv maps Names to actual closures (for interpreted code only), for
use during linking.
+
+Note [Looking up symbols in the relevant objects]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In #23415, we determined that a lot of time (>10s, or even up to >35s!) was
+being spent on dynamically loading symbols before actually interpreting code
+when `:main` was run in GHCi. The root cause was that for each symbol we wanted
+to lookup, we would traverse the list of loaded objects and try find the symbol
+in each of them with dlsym (i.e. looking up a symbol was, worst case, linear in
+the amount of loaded objects).
+
+To drastically improve load time (XXX(TODO:get better measure against 10s
+baseline rather than 35second one) to <3s), we now:
+
+1. For every of the native objects loaded for a given unit, store the handles returned by `dlopen`.
+ - In `pkgs_loaded` of the `LoaderState`, which maps `UnitId`s to
+ `LoadedPkgInfo`s, where the handles live in its field `loaded_pkg_hs_dlls`.
+
+2. When looking up a Name (e.g. `lookupHsSymbol`), find that name's `UnitId` in
+ the `pkgs_loaded` mapping,
+
+3. And only look for the symbol (with `dlsym`) on the /handles relevant to that
+ unit/, rather than in every loaded object.
+
+Note [Symbols may not be found in pkgs_loaded]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Despite storing and looking for symbols in the relevant loaded libraries
+handles for a given unit-id, as described in the note above, we may still have
+to fallback to the "slow" `lookupSymbol` function (see its "fallback" call in
+`lookupHsSymbol`).
+
+TODO: Ben: my understanding here is flawed; could you make this clearer?.
+
+This fallback is still needed because a given unit may be associated with
+static objects (`loaded_pkg_hs_objs`) only and no dynamic libraries, but we
+only `lookupSymbolInDLL` for loaded dynamic libraries. In that case,
+`lookupSymbol` will do the right thing because, besides looking up the symbol
+in every loaded dylib, it will end up searching the static name table and find those symbols.
+
+Arguably, we should rather generalise `lookupSymbolInDLL` to
+`lookupSymbolInObject`, where an object may be a DLL/native object (as in
+`loadNativeObj`), or e.g. a static archive, instead of having a special case
+for dynamic libraries.
+
+This fallback is further needed because we don't look in the haskell objects
+loaded for the home units (see the call to `loadModuleLinkables` in
+`loadDependencies`, as opposed to the call to `loadPackages'` in the same
+function which updates `pkgs_loaded`). We should ultimately keep track of the
+objects loaded (probably in `objs_loaded`, for which `LinkableSet` is a bit
+unsatisfactory, see a suggestion in 51c5c4eb1f2a33e4dc88e6a37b7b7c135234ce9b)
+and be able to lookup symbols specifically in them too (similarly to
+`lookupSymbolInDLL`).
-}
newtype Loader = Loader { loader_state :: MVar (Maybe LoaderState) }
@@ -146,11 +198,13 @@ data LoadedPkgInfo
{ loaded_pkg_uid :: !UnitId
, loaded_pkg_hs_objs :: ![LibrarySpec]
, loaded_pkg_non_hs_objs :: ![LibrarySpec]
+ , loaded_pkg_hs_dlls :: ![RemotePtr LoadedDLL]
+ -- ^ See Note [Looking up symbols in the relevant objects]
, loaded_pkg_trans_deps :: UniqDSet UnitId
}
instance Outputable LoadedPkgInfo where
- ppr (LoadedPkgInfo uid hs_objs non_hs_objs trans_deps) =
+ ppr (LoadedPkgInfo uid hs_objs non_hs_objs _ trans_deps) =
vcat [ppr uid
, ppr hs_objs
, ppr non_hs_objs
@@ -159,10 +213,10 @@ instance Outputable LoadedPkgInfo where
-- | Information we can use to dynamically link modules into the compiler
data Linkable = LM {
- linkableTime :: !UTCTime, -- ^ Time at which this linkable was built
+ linkableTime :: !UTCTime, -- ^ Time at which this linkable was built
-- (i.e. when the bytecodes were produced,
-- or the mod date on the files)
- linkableModule :: !Module, -- ^ The linkable module itself
+ linkableModule :: !Module, -- ^ The linkable module itself
linkableUnlinked :: [Unlinked]
-- ^ Those files and chunks of code we have yet to link.
--
=====================================
compiler/GHC/Runtime/Interpreter.hs
=====================================
@@ -35,6 +35,7 @@ module GHC.Runtime.Interpreter
-- * The object-code linker
, initObjLinker
, lookupSymbol
+ , lookupSymbolInDLL
, lookupClosure
, loadDLL
, loadArchive
@@ -151,22 +152,22 @@ The main pieces are:
- implementation of Template Haskell (GHCi.TH)
- a few other things needed to run interpreted code
-- top-level iserv directory, containing the codefor the external
- server. This is a fairly simple wrapper, most of the functionality
+- top-level iserv directory, containing the code for the external
+ server. This is a fairly simple wrapper, most of the functionality
is provided by modules in libraries/ghci.
- This module which provides the interface to the server used
by the rest of GHC.
-GHC works with and without -fexternal-interpreter. With the flag, all
-interpreted code is run by the iserv binary. Without the flag,
+GHC works with and without -fexternal-interpreter. With the flag, all
+interpreted code is run by the iserv binary. Without the flag,
interpreted code is run in the same process as GHC.
Things that do not work with -fexternal-interpreter
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
dynCompileExpr cannot work, because we have no way to run code of an
-unknown type in the remote process. This API fails with an error
+unknown type in the remote process. This API fails with an error
message if it is used with -fexternal-interpreter.
Other Notes on Remote GHCi
@@ -440,57 +441,78 @@ initObjLinker :: Interp -> IO ()
initObjLinker interp = interpCmd interp InitLinker
lookupSymbol :: Interp -> FastString -> IO (Maybe (Ptr ()))
-lookupSymbol interp str = case interpInstance interp of
+lookupSymbol interp str = withSymbolCache interp str $
+ case interpInstance interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
- InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str))
+ InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str))
#endif
-
- ExternalInterp ext -> case ext of
- ExtIServ i -> withIServ i $ \inst -> do
- -- Profiling of GHCi showed a lot of time and allocation spent
- -- making cross-process LookupSymbol calls, so I added a GHC-side
- -- cache which sped things up quite a lot. We have to be careful
- -- to purge this cache when unloading code though.
- cache <- readMVar (instLookupSymbolCache inst)
- case lookupUFM cache str of
- Just p -> return (Just p)
- Nothing -> do
- m <- uninterruptibleMask_ $
- sendMessage inst (LookupSymbol (unpackFS str))
- case m of
- Nothing -> return Nothing
- Just r -> do
- let p = fromRemotePtr r
- cache' = addToUFM cache str p
- modifyMVar_ (instLookupSymbolCache inst) (const (pure cache'))
- return (Just p)
-
- ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)
+ ExternalInterp ext -> case ext of
+ ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do
+ uninterruptibleMask_ $
+ sendMessage inst (LookupSymbol (unpackFS str))
+ ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)
+
+lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> FastString -> IO (Maybe (Ptr ()))
+lookupSymbolInDLL interp dll str = withSymbolCache interp str $
+ case interpInstance interp of
+#if defined(HAVE_INTERNAL_INTERPRETER)
+ InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (unpackFS str))
+#endif
+ ExternalInterp ext -> case ext of
+ ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do
+ uninterruptibleMask_ $
+ sendMessage inst (LookupSymbolInDLL dll (unpackFS str))
+ ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)
lookupClosure :: Interp -> String -> IO (Maybe HValueRef)
lookupClosure interp str =
interpCmd interp (LookupClosure str)
+-- | 'withSymbolCache' tries to find a symbol in the 'interpLookupSymbolCache'
+-- which maps symbols to the address where they are loaded.
+-- When there's a cache hit we simply return the cached address, when there is
+-- a miss we run the action which determines the symbol's address and populate
+-- the cache with the answer.
+withSymbolCache :: Interp
+ -> FastString
+ -- ^ The symbol we are looking up in the cache
+ -> IO (Maybe (Ptr ()))
+ -- ^ An action which determines the address of the symbol we
+ -- are looking up in the cache, which is run if there is a
+ -- cache miss. The result will be cached.
+ -> IO (Maybe (Ptr ()))
+withSymbolCache interp str determine_addr = do
+
+ -- Profiling of GHCi showed a lot of time and allocation spent
+ -- making cross-process LookupSymbol calls, so I added a GHC-side
+ -- cache which sped things up quite a lot. We have to be careful
+ -- to purge this cache when unloading code though.
+ --
+ -- The analysis in #23415 further showed this cache should also benefit the
+ -- internal interpreter's loading times, and needn't be used by the external
+ -- interpreter only.
+ cache <- readMVar (interpLookupSymbolCache interp)
+ case lookupUFM cache str of
+ Just p -> return (Just p)
+ Nothing -> do
+
+ maddr <- determine_addr
+ case maddr of
+ Nothing -> return Nothing
+ Just p -> do
+ let upd_cache cache' = addToUFM cache' str p
+ modifyMVar_ (interpLookupSymbolCache interp) (pure . upd_cache)
+ return (Just p)
+
purgeLookupSymbolCache :: Interp -> IO ()
-purgeLookupSymbolCache interp = case interpInstance interp of
-#if defined(HAVE_INTERNAL_INTERPRETER)
- InternalInterp -> pure ()
-#endif
- ExternalInterp ext -> withExtInterpMaybe ext $ \case
- Nothing -> pure () -- interpreter stopped, nothing to do
- Just inst -> modifyMVar_ (instLookupSymbolCache inst) (const (pure emptyUFM))
+purgeLookupSymbolCache interp = putMVar (interpLookupSymbolCache interp) emptyUFM
-- | loadDLL loads a dynamic library using the OS's native linker
-- (i.e. dlopen() on Unix, LoadLibrary() on Windows). It takes either
-- an absolute pathname to the file, or a relative filename
-- (e.g. "libfoo.so" or "foo.dll"). In the latter case, loadDLL
-- searches the standard locations for the appropriate library.
---
--- Returns:
---
--- Nothing => success
--- Just err_msg => failure
-loadDLL :: Interp -> String -> IO (Maybe String)
+loadDLL :: Interp -> String -> IO (Either String (RemotePtr LoadedDLL))
loadDLL interp str = interpCmd interp (LoadDLL str)
loadArchive :: Interp -> String -> IO ()
@@ -549,11 +571,9 @@ spawnIServ conf = do
}
pending_frees <- newMVar []
- lookup_cache <- newMVar emptyUFM
let inst = ExtInterpInstance
{ instProcess = process
, instPendingFrees = pending_frees
- , instLookupSymbolCache = lookup_cache
, instExtra = ()
}
pure inst
=====================================
compiler/GHC/Runtime/Interpreter/JS.hs
=====================================
@@ -41,7 +41,6 @@ import GHC.Utils.Panic
import GHC.Utils.Error (logInfo)
import GHC.Utils.Outputable (text)
import GHC.Data.FastString
-import GHC.Types.Unique.FM
import Control.Concurrent
import Control.Monad
@@ -178,11 +177,9 @@ spawnJSInterp cfg = do
}
pending_frees <- newMVar []
- lookup_cache <- newMVar emptyUFM
let inst = ExtInterpInstance
{ instProcess = proc
, instPendingFrees = pending_frees
- , instLookupSymbolCache = lookup_cache
, instExtra = extra
}
=====================================
compiler/GHC/Runtime/Interpreter/Types.hs
=====================================
@@ -51,6 +51,9 @@ data Interp = Interp
, interpLoader :: !Loader
-- ^ Interpreter loader
+
+ , interpLookupSymbolCache :: !(MVar (UniqFM FastString (Ptr ())))
+ -- ^ LookupSymbol cache
}
data InterpInstance
@@ -108,9 +111,6 @@ data ExtInterpInstance c = ExtInterpInstance
-- Finalizers for ForeignRefs can append values to this list
-- asynchronously.
- , instLookupSymbolCache :: !(MVar (UniqFM FastString (Ptr ())))
- -- ^ LookupSymbol cache
-
, instExtra :: !c
-- ^ Instance specific extra fields
}
=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -23,6 +23,7 @@ module GHCi.Message
, getMessage, putMessage, getTHMessage, putTHMessage
, Pipe(..), remoteCall, remoteTHCall, readPipe, writePipe
, BreakModule
+ , LoadedDLL
) where
import Prelude -- See note [Why do we import Prelude here?]
@@ -73,8 +74,9 @@ data Message a where
-- These all invoke the corresponding functions in the RTS Linker API.
InitLinker :: Message ()
LookupSymbol :: String -> Message (Maybe (RemotePtr ()))
+ LookupSymbolInDLL :: RemotePtr LoadedDLL -> String -> Message (Maybe (RemotePtr ()))
LookupClosure :: String -> Message (Maybe HValueRef)
- LoadDLL :: String -> Message (Maybe String)
+ LoadDLL :: String -> Message (Either String (RemotePtr LoadedDLL))
LoadArchive :: String -> Message () -- error?
LoadObj :: String -> Message () -- error?
UnloadObj :: String -> Message () -- error?
@@ -415,6 +417,9 @@ instance Binary a => Binary (EvalResult a)
-- that type isn't available here.
data BreakModule
+-- | A dummy type that tags pointers returned by 'LoadDLL'.
+data LoadedDLL
+
-- SomeException can't be serialized because it contains dynamic
-- types. However, we do very limited things with the exceptions that
-- are thrown by interpreted computations:
@@ -544,6 +549,7 @@ getMessage = do
37 -> Msg <$> return RtsRevertCAFs
38 -> Msg <$> (ResumeSeq <$> get)
39 -> Msg <$> (NewBreakModule <$> get)
+ 40 -> Msg <$> (LookupSymbolInDLL <$> get <*> get)
_ -> error $ "Unknown Message code " ++ (show b)
putMessage :: Message a -> Put
@@ -588,7 +594,8 @@ putMessage m = case m of
Seq a -> putWord8 36 >> put a
RtsRevertCAFs -> putWord8 37
ResumeSeq a -> putWord8 38 >> put a
- NewBreakModule name -> putWord8 39 >> put name
+ NewBreakModule name -> putWord8 39 >> put name
+ LookupSymbolInDLL dll str -> putWord8 40 >> put dll >> put str
{-
Note [Parallelize CreateBCOs serialization]
=====================================
libraries/ghci/GHCi/ObjLink.hs
=====================================
@@ -18,6 +18,7 @@ module GHCi.ObjLink
, unloadObj
, purgeObj
, lookupSymbol
+ , lookupSymbolInDLL
, lookupClosure
, resolveObjs
, addLibrarySearchPath
@@ -27,18 +28,17 @@ module GHCi.ObjLink
import Prelude -- See note [Why do we import Prelude here?]
import GHCi.RemoteTypes
+import GHCi.Message (LoadedDLL)
import Control.Exception (throwIO, ErrorCall(..))
import Control.Monad ( when )
import Foreign.C
-import Foreign.Marshal.Alloc ( free )
-import Foreign ( nullPtr )
+import Foreign.Marshal.Alloc ( alloca, free )
+import Foreign ( nullPtr, peek )
import GHC.Exts
import System.Posix.Internals ( CFilePath, withFilePath, peekFilePath )
import System.FilePath ( dropExtension, normalise )
-
-
-- ---------------------------------------------------------------------------
-- RTS Linker Interface
-- ---------------------------------------------------------------------------
@@ -70,6 +70,15 @@ lookupSymbol str_in = do
then return Nothing
else return (Just addr)
+lookupSymbolInDLL :: Ptr LoadedDLL -> String -> IO (Maybe (Ptr a))
+lookupSymbolInDLL dll str_in = do
+ let str = prefixUnderscore str_in
+ withCAString str $ \c_str -> do
+ addr <- c_lookupSymbolInNativeObj dll c_str
+ if addr == nullPtr
+ then return Nothing
+ else return (Just addr)
+
lookupClosure :: String -> IO (Maybe HValueRef)
lookupClosure str = do
m <- lookupSymbol str
@@ -89,7 +98,7 @@ prefixUnderscore
-- (e.g. "libfoo.so" or "foo.dll"). In the latter case, loadDLL
-- searches the standard locations for the appropriate library.
--
-loadDLL :: String -> IO (Maybe String)
+loadDLL :: String -> IO (Either String (Ptr LoadedDLL))
-- Nothing => success
-- Just err_msg => failure
loadDLL str0 = do
@@ -101,12 +110,16 @@ loadDLL str0 = do
str | isWindowsHost = dropExtension str0
| otherwise = str0
--
- maybe_errmsg <- withFilePath (normalise str) $ \dll -> c_addDLL dll
- if maybe_errmsg == nullPtr
- then return Nothing
- else do str <- peekCString maybe_errmsg
- free maybe_errmsg
- return (Just str)
+ (maybe_handle, maybe_errmsg) <- withFilePath (normalise str) $ \dll ->
+ alloca $ \errmsg_ptr -> (,)
+ <$> c_loadNativeObj dll errmsg_ptr
+ <*> peek errmsg_ptr
+
+ if maybe_handle == nullPtr
+ then do str <- peekCString maybe_errmsg
+ free maybe_errmsg
+ return (Left str)
+ else return (Right maybe_handle)
loadArchive :: String -> IO ()
loadArchive str = do
@@ -163,7 +176,8 @@ resolveObjs = do
-- Foreign declarations to RTS entry points which does the real work;
-- ---------------------------------------------------------------------------
-foreign import ccall unsafe "addDLL" c_addDLL :: CFilePath -> IO CString
+foreign import ccall unsafe "loadNativeObj" c_loadNativeObj :: CFilePath -> Ptr CString -> IO (Ptr LoadedDLL)
+foreign import ccall unsafe "lookupSymbolInNativeObj" c_lookupSymbolInNativeObj :: Ptr LoadedDLL -> CString -> IO (Ptr a)
foreign import ccall unsafe "initLinker_" c_initLinker_ :: CInt -> IO ()
foreign import ccall unsafe "lookupSymbol" c_lookupSymbol :: CString -> IO (Ptr a)
foreign import ccall unsafe "loadArchive" c_loadArchive :: CFilePath -> IO Int
=====================================
libraries/ghci/GHCi/Run.hs
=====================================
@@ -66,7 +66,7 @@ run m = case m of
LookupClosure str -> lookupJSClosure str
#else
InitLinker -> initObjLinker RetainCAFs
- LoadDLL str -> loadDLL str
+ LoadDLL str -> fmap toRemotePtr <$> loadDLL str
LoadArchive str -> loadArchive str
LoadObj str -> loadObj str
UnloadObj str -> unloadObj str
@@ -81,6 +81,8 @@ run m = case m of
#endif
RtsRevertCAFs -> rts_revertCAFs
LookupSymbol str -> fmap toRemotePtr <$> lookupSymbol str
+ LookupSymbolInDLL dll str ->
+ fmap toRemotePtr <$> lookupSymbolInDLL (fromRemotePtr dll) str
FreeHValueRefs rs -> mapM_ freeRemoteRef rs
AddSptEntry fpr r -> localRef r >>= sptAddEntry fpr
EvalStmt opts r -> evalStmt opts r
=====================================
rts/Linker.c
=====================================
@@ -77,6 +77,10 @@
# include <mach-o/fat.h>
#endif
+#if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
+# include "linker/LoadNativeObjPosix.h"
+#endif
+
#if defined(dragonfly_HOST_OS)
#include <sys/tls.h>
#endif
@@ -130,7 +134,7 @@ extern void iconv();
- Indexing (e.g. ocVerifyImage and ocGetNames)
- Initialization (e.g. ocResolve)
- RunInit (e.g. ocRunInit)
- - Lookup (e.g. lookupSymbol)
+ - Lookup (e.g. lookupSymbol/lookupSymbolInDLL)
This is to enable lazy loading of symbols. Eager loading is problematic
as it means that all symbols must be available, even those which we will
@@ -419,9 +423,6 @@ static int linker_init_done = 0 ;
static void *dl_prog_handle;
static regex_t re_invalid;
static regex_t re_realso;
-#if defined(THREADED_RTS)
-Mutex dl_mutex; // mutex to protect dlopen/dlerror critical section
-#endif
#endif
void initLinker (void)
@@ -455,9 +456,6 @@ initLinker_ (int retain_cafs)
#if defined(THREADED_RTS)
initMutex(&linker_mutex);
-#if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
- initMutex(&dl_mutex);
-#endif
#endif
symhash = allocStrHashTable();
@@ -520,9 +518,6 @@ exitLinker( void ) {
if (linker_init_done == 1) {
regfree(&re_invalid);
regfree(&re_realso);
-#if defined(THREADED_RTS)
- closeMutex(&dl_mutex);
-#endif
}
#endif
if (linker_init_done == 1) {
@@ -556,90 +551,6 @@ exitLinker( void ) {
# if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
-/* Suppose in ghci we load a temporary SO for a module containing
- f = 1
- and then modify the module, recompile, and load another temporary
- SO with
- f = 2
- Then as we don't unload the first SO, dlsym will find the
- f = 1
- symbol whereas we want the
- f = 2
- symbol. We therefore need to keep our own SO handle list, and
- try SOs in the right order. */
-
-typedef
- struct _OpenedSO {
- struct _OpenedSO* next;
- void *handle;
- }
- OpenedSO;
-
-/* A list thereof. */
-static OpenedSO* openedSOs = NULL;
-
-static const char *
-internal_dlopen(const char *dll_name)
-{
- OpenedSO* o_so;
- void *hdl;
- const char *errmsg;
- char *errmsg_copy;
-
- // omitted: RTLD_NOW
- // see http://www.haskell.org/pipermail/cvs-ghc/2007-September/038570.html
- IF_DEBUG(linker,
- debugBelch("internal_dlopen: dll_name = '%s'\n", dll_name));
-
- //-------------- Begin critical section ------------------
- // This critical section is necessary because dlerror() is not
- // required to be reentrant (see POSIX -- IEEE Std 1003.1-2008)
- // Also, the error message returned must be copied to preserve it
- // (see POSIX also)
-
- ACQUIRE_LOCK(&dl_mutex);
-
- // When dlopen() loads a profiled dynamic library, it calls the
- // ctors which will call registerCcsList() to append the defined
- // CostCentreStacks to CCS_LIST. This execution path starting from
- // addDLL() was only protected by dl_mutex previously. However,
- // another thread may be doing other things with the RTS linker
- // that transitively calls refreshProfilingCCSs() which also
- // accesses CCS_LIST, and those execution paths are protected by
- // linker_mutex. So there's a risk of data race that may lead to
- // segfaults (#24423), and we need to ensure the ctors are also
- // protected by ccs_mutex.
-#if defined(PROFILING)
- ACQUIRE_LOCK(&ccs_mutex);
-#endif
-
- hdl = dlopen(dll_name, RTLD_LAZY|RTLD_LOCAL); /* see Note [RTLD_LOCAL] */
-
-#if defined(PROFILING)
- RELEASE_LOCK(&ccs_mutex);
-#endif
-
- errmsg = NULL;
- if (hdl == NULL) {
- /* dlopen failed; return a ptr to the error msg. */
- errmsg = dlerror();
- if (errmsg == NULL) errmsg = "addDLL: unknown error";
- errmsg_copy = stgMallocBytes(strlen(errmsg)+1, "addDLL");
- strcpy(errmsg_copy, errmsg);
- errmsg = errmsg_copy;
- } else {
- o_so = stgMallocBytes(sizeof(OpenedSO), "addDLL");
- o_so->handle = hdl;
- o_so->next = openedSOs;
- openedSOs = o_so;
- }
-
- RELEASE_LOCK(&dl_mutex);
- //--------------- End critical section -------------------
-
- return errmsg;
-}
-
/*
Note [RTLD_LOCAL]
~~~~~~~~~~~~~~~~~
@@ -660,11 +571,10 @@ internal_dlopen(const char *dll_name)
static void *
internal_dlsym(const char *symbol) {
- OpenedSO* o_so;
void *v;
- // We acquire dl_mutex as concurrent dl* calls may alter dlerror
- ACQUIRE_LOCK(&dl_mutex);
+ // concurrent dl* calls may alter dlerror
+ ASSERT_LOCK_HELD(&linker_mutex);
// clears dlerror
dlerror();
@@ -672,20 +582,19 @@ internal_dlsym(const char *symbol) {
// look in program first
v = dlsym(dl_prog_handle, symbol);
if (dlerror() == NULL) {
- RELEASE_LOCK(&dl_mutex);
IF_DEBUG(linker, debugBelch("internal_dlsym: found symbol '%s' in program\n", symbol));
return v;
}
- for (o_so = openedSOs; o_so != NULL; o_so = o_so->next) {
- v = dlsym(o_so->handle, symbol);
- if (dlerror() == NULL) {
+ for (ObjectCode *nc = loaded_objects; nc; nc = nc->next_loaded_object) {
+ if (nc->type == DYNAMIC_OBJECT) {
+ v = dlsym(nc->dlopen_handle, symbol);
+ if (dlerror() == NULL) {
IF_DEBUG(linker, debugBelch("internal_dlsym: found symbol '%s' in shared object\n", symbol));
- RELEASE_LOCK(&dl_mutex);
return v;
+ }
}
}
- RELEASE_LOCK(&dl_mutex);
IF_DEBUG(linker, debugBelch("internal_dlsym: looking for symbol '%s' in special cases\n", symbol));
# define SPECIAL_SYMBOL(sym) \
@@ -725,79 +634,33 @@ internal_dlsym(const char *symbol) {
// we failed to find the symbol
return NULL;
}
-# endif
-const char *
-addDLL( pathchar *dll_name )
+void *lookupSymbolInNativeObj(void *handle, const char *symbol_name)
{
-# if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
- /* ------------------- ELF DLL loader ------------------- */
-
-#define NMATCH 5
- regmatch_t match[NMATCH];
- const char *errmsg;
- FILE* fp;
- size_t match_length;
-#define MAXLINE 1000
- char line[MAXLINE];
- int result;
-
- IF_DEBUG(linker, debugBelch("addDLL: dll_name = '%s'\n", dll_name));
- errmsg = internal_dlopen(dll_name);
+ ASSERT_LOCK_HELD(&linker_mutex);
- if (errmsg == NULL) {
- return NULL;
- }
+#if defined(OBJFORMAT_MACHO)
+ CHECK(symbol_name[0] == '_');
+ symbol_name = symbol_name+1;
+#endif
+ void *result = dlsym(handle, symbol_name);
+ return result;
+}
+# endif
- // GHC #2615
- // On some systems (e.g., Gentoo Linux) dynamic files (e.g. libc.so)
- // contain linker scripts rather than ELF-format object code. This
- // code handles the situation by recognizing the real object code
- // file name given in the linker script.
- //
- // If an "invalid ELF header" error occurs, it is assumed that the
- // .so file contains a linker script instead of ELF object code.
- // In this case, the code looks for the GROUP ( ... ) linker
- // directive. If one is found, the first file name inside the
- // parentheses is treated as the name of a dynamic library and the
- // code attempts to dlopen that file. If this is also unsuccessful,
- // an error message is returned.
-
- // see if the error message is due to an invalid ELF header
- IF_DEBUG(linker, debugBelch("errmsg = '%s'\n", errmsg));
- result = regexec(&re_invalid, errmsg, (size_t) NMATCH, match, 0);
- IF_DEBUG(linker, debugBelch("result = %i\n", result));
- if (result == 0) {
- // success -- try to read the named file as a linker script
- match_length = (size_t) stg_min((match[1].rm_eo - match[1].rm_so),
- MAXLINE-1);
- strncpy(line, (errmsg+(match[1].rm_so)),match_length);
- line[match_length] = '\0'; // make sure string is null-terminated
- IF_DEBUG(linker, debugBelch("file name = '%s'\n", line));
- if ((fp = __rts_fopen(line, "r")) == NULL) {
- return errmsg; // return original error if open fails
- }
- // try to find a GROUP or INPUT ( ... ) command
- while (fgets(line, MAXLINE, fp) != NULL) {
- IF_DEBUG(linker, debugBelch("input line = %s", line));
- if (regexec(&re_realso, line, (size_t) NMATCH, match, 0) == 0) {
- // success -- try to dlopen the first named file
- IF_DEBUG(linker, debugBelch("match%s\n",""));
- line[match[2].rm_eo] = '\0';
- stgFree((void*)errmsg); // Free old message before creating new one
- errmsg = internal_dlopen(line+match[2].rm_so);
- break;
- }
- // if control reaches here, no GROUP or INPUT ( ... ) directive
- // was found and the original error message is returned to the
- // caller
- }
- fclose(fp);
+const char *addDLL(pathchar* dll_name)
+{
+# if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
+ char *errmsg;
+ if (loadNativeObj(dll_name, &errmsg)) {
+ return NULL;
+ } else {
+ ASSERT(errmsg != NULL);
+ return errmsg;
}
- return errmsg;
# elif defined(OBJFORMAT_PEi386)
- return addDLL_PEi386(dll_name, NULL);
+ return addDLL_PEi386(dll_name);
# else
barf("addDLL: not implemented on this platform");
@@ -1229,9 +1092,10 @@ void freeObjectCode (ObjectCode *oc)
if (oc->type == DYNAMIC_OBJECT) {
#if defined(OBJFORMAT_ELF)
- ACQUIRE_LOCK(&dl_mutex);
- freeNativeCode_ELF(oc);
- RELEASE_LOCK(&dl_mutex);
+ // ROMES:TODO: This previously acquired dl_mutex. Check that acquiring linker_mutex here is fine.
+ ACQUIRE_LOCK(&linker_mutex);
+ freeNativeCode_POSIX(oc);
+ RELEASE_LOCK(&linker_mutex);
#else
barf("freeObjectCode: This shouldn't happen");
#endif
@@ -1896,12 +1760,20 @@ HsInt purgeObj (pathchar *path)
return r;
}
+ObjectCode *lookupObjectByPath(pathchar *path) {
+ for (ObjectCode *o = objects; o; o = o->next) {
+ if (0 == pathcmp(o->fileName, path)) {
+ return o;
+ }
+ }
+ return NULL;
+}
+
OStatus getObjectLoadStatus_ (pathchar *path)
{
- for (ObjectCode *o = objects; o; o = o->next) {
- if (0 == pathcmp(o->fileName, path)) {
- return o->status;
- }
+ ObjectCode *oc = lookupObjectByPath(path);
+ if (oc) {
+ return oc->status;
}
return OBJECT_NOT_LOADED;
}
@@ -1988,11 +1860,21 @@ addSection (Section *s, SectionKind kind, SectionAlloc alloc,
#define UNUSED(x) (void)(x)
-#if defined(OBJFORMAT_ELF)
+#if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
void * loadNativeObj (pathchar *path, char **errmsg)
{
+ IF_DEBUG(linker, debugBelch("loadNativeObj: path = '%s'\n", path));
ACQUIRE_LOCK(&linker_mutex);
- void *r = loadNativeObj_ELF(path, errmsg);
+ void *r = loadNativeObj_POSIX(path, errmsg);
+
+#if defined(OBJFORMAT_ELF)
+ if (!r) {
+ // Check if native object may be a linker script and try loading a native
+ // object from it
+ r = loadNativeObjFromLinkerScript_ELF(errmsg);
+ }
+#endif
+
RELEASE_LOCK(&linker_mutex);
return r;
}
@@ -2006,7 +1888,7 @@ loadNativeObj (pathchar *path, char **errmsg)
}
#endif
-HsInt unloadNativeObj (void *handle)
+static HsInt unloadNativeObj_(void *handle)
{
bool unloadedAnyObj = false;
@@ -2044,6 +1926,13 @@ HsInt unloadNativeObj (void *handle)
}
}
+HsInt unloadNativeObj(void *handle) {
+ ACQUIRE_LOCK(&linker_mutex);
+ HsInt r = unloadNativeObj_(handle);
+ RELEASE_LOCK(&linker_mutex);
+ return r;
+}
+
/* -----------------------------------------------------------------------------
* Segment management
*/
=====================================
rts/LinkerInternals.h
=====================================
@@ -412,10 +412,6 @@ extern Elf_Word shndx_table_uninit_label;
#if defined(THREADED_RTS)
extern Mutex linker_mutex;
-
-#if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
-extern Mutex dl_mutex;
-#endif
#endif /* THREADED_RTS */
/* Type of an initializer */
@@ -515,9 +511,9 @@ HsInt loadArchive_ (pathchar *path);
#define USE_CONTIGUOUS_MMAP 0
#endif
-
HsInt isAlreadyLoaded( pathchar *path );
OStatus getObjectLoadStatus_ (pathchar *path);
+ObjectCode *lookupObjectByPath(pathchar *path);
HsInt loadOc( ObjectCode* oc );
ObjectCode* mkOc( ObjectType type, pathchar *path, char *image, int imageSize,
bool mapped, pathchar *archiveMemberName,
=====================================
rts/RtsSymbols.c
=====================================
@@ -619,6 +619,7 @@ extern char **environ;
SymI_HasProto(purgeObj) \
SymI_HasProto(insertSymbol) \
SymI_HasProto(lookupSymbol) \
+ SymI_HasProto(lookupSymbolInNativeObj) \
SymI_HasDataProto(stg_makeStablePtrzh) \
SymI_HasDataProto(stg_mkApUpd0zh) \
SymI_HasDataProto(stg_labelThreadzh) \
=====================================
rts/include/rts/Linker.h
=====================================
@@ -90,8 +90,12 @@ void *loadNativeObj( pathchar *path, char **errmsg );
Takes the handle returned from loadNativeObj() as an argument. */
HsInt unloadNativeObj( void *handle );
+void *lookupSymbolInNativeObj(void *handle, const char *symbol_name);
+
/* load a dynamic library */
-const char *addDLL( pathchar* dll_name );
+const char *addDLL(pathchar* dll_name);
+
+void *lookupSymbolInDLL(void *handle, const char *symbol_name);
/* add a path to the library search path */
HsPtr addLibrarySearchPath(pathchar* dll_path);
=====================================
rts/linker/Elf.c
=====================================
@@ -2069,159 +2069,6 @@ int ocRunFini_ELF( ObjectCode *oc )
return true;
}
-/*
- * Shared object loading
- */
-
-#if defined(HAVE_DLINFO)
-struct piterate_cb_info {
- ObjectCode *nc;
- void *l_addr; /* base virtual address of the loaded code */
-};
-
-static int loadNativeObjCb_(struct dl_phdr_info *info,
- size_t _size STG_UNUSED, void *data) {
- struct piterate_cb_info *s = (struct piterate_cb_info *) data;
-
- // This logic mimicks _dl_addr_inside_object from glibc
- // For reference:
- // int
- // internal_function
- // _dl_addr_inside_object (struct link_map *l, const ElfW(Addr) addr)
- // {
- // int n = l->l_phnum;
- // const ElfW(Addr) reladdr = addr - l->l_addr;
- //
- // while (--n >= 0)
- // if (l->l_phdr[n].p_type == PT_LOAD
- // && reladdr - l->l_phdr[n].p_vaddr >= 0
- // && reladdr - l->l_phdr[n].p_vaddr < l->l_phdr[n].p_memsz)
- // return 1;
- // return 0;
- // }
-
- if ((void*) info->dlpi_addr == s->l_addr) {
- int n = info->dlpi_phnum;
- while (--n >= 0) {
- if (info->dlpi_phdr[n].p_type == PT_LOAD) {
- NativeCodeRange* ncr =
- stgMallocBytes(sizeof(NativeCodeRange), "loadNativeObjCb_");
- ncr->start = (void*) ((char*) s->l_addr + info->dlpi_phdr[n].p_vaddr);
- ncr->end = (void*) ((char*) ncr->start + info->dlpi_phdr[n].p_memsz);
-
- ncr->next = s->nc->nc_ranges;
- s->nc->nc_ranges = ncr;
- }
- }
- }
- return 0;
-}
-#endif /* defined(HAVE_DLINFO) */
-
-static void copyErrmsg(char** errmsg_dest, char* errmsg) {
- if (errmsg == NULL) errmsg = "loadNativeObj_ELF: unknown error";
- *errmsg_dest = stgMallocBytes(strlen(errmsg)+1, "loadNativeObj_ELF");
- strcpy(*errmsg_dest, errmsg);
-}
-
-// need dl_mutex
-void freeNativeCode_ELF (ObjectCode *nc) {
- dlclose(nc->dlopen_handle);
-
- NativeCodeRange *ncr = nc->nc_ranges;
- while (ncr) {
- NativeCodeRange* last_ncr = ncr;
- ncr = ncr->next;
- stgFree(last_ncr);
- }
-}
-
-void * loadNativeObj_ELF (pathchar *path, char **errmsg)
-{
- ObjectCode* nc;
- void *hdl, *retval;
-
- IF_DEBUG(linker, debugBelch("loadNativeObj_ELF %" PATH_FMT "\n", path));
-
- retval = NULL;
- ACQUIRE_LOCK(&dl_mutex);
-
- /* Loading the same object multiple times will lead to chaos
- * as we will have two ObjectCodes but one underlying dlopen
- * handle. Fail if this happens.
- */
- if (getObjectLoadStatus_(path) != OBJECT_NOT_LOADED) {
- copyErrmsg(errmsg, "loadNativeObj_ELF: Already loaded");
- goto dlopen_fail;
- }
-
- nc = mkOc(DYNAMIC_OBJECT, path, NULL, 0, false, NULL, 0);
-
- foreignExportsLoadingObject(nc);
- hdl = dlopen(path, RTLD_NOW|RTLD_LOCAL);
- nc->dlopen_handle = hdl;
- foreignExportsFinishedLoadingObject();
- if (hdl == NULL) {
- /* dlopen failed; save the message in errmsg */
- copyErrmsg(errmsg, dlerror());
- goto dlopen_fail;
- }
-
-#if defined(HAVE_DLINFO)
- struct link_map *map;
- if (dlinfo(hdl, RTLD_DI_LINKMAP, &map) == -1) {
- /* dlinfo failed; save the message in errmsg */
- copyErrmsg(errmsg, dlerror());
- goto dlinfo_fail;
- }
-
- hdl = NULL; // pass handle ownership to nc
-
- struct piterate_cb_info piterate_info = {
- .nc = nc,
- .l_addr = (void *) map->l_addr
- };
- dl_iterate_phdr(loadNativeObjCb_, &piterate_info);
- if (!nc->nc_ranges) {
- copyErrmsg(errmsg, "dl_iterate_phdr failed to find obj");
- goto dl_iterate_phdr_fail;
- }
- nc->unloadable = true;
-#else
- nc->nc_ranges = NULL;
- nc->unloadable = false;
-#endif /* defined (HAVE_DLINFO) */
-
- insertOCSectionIndices(nc);
-
- nc->next_loaded_object = loaded_objects;
- loaded_objects = nc;
-
- retval = nc->dlopen_handle;
-
-#if defined(PROFILING)
- // collect any new cost centres that were defined in the loaded object.
- refreshProfilingCCSs();
-#endif
-
- goto success;
-
-dl_iterate_phdr_fail:
- // already have dl_mutex
- freeNativeCode_ELF(nc);
-dlinfo_fail:
- if (hdl) dlclose(hdl);
-dlopen_fail:
-success:
-
- RELEASE_LOCK(&dl_mutex);
-
- IF_DEBUG(linker, debugBelch("loadNativeObj_ELF result=%p\n", retval));
-
- return retval;
-}
-
-
/*
* PowerPC & X86_64 ELF specifics
*/
@@ -2271,4 +2118,70 @@ int ocAllocateExtras_ELF( ObjectCode *oc )
#endif /* NEED_SYMBOL_EXTRAS */
+void * loadNativeObjFromLinkerScript_ELF(char **errmsg)
+{
+ // GHC #2615
+ // On some systems (e.g., Gentoo Linux) dynamic files (e.g. libc.so)
+ // contain linker scripts rather than ELF-format object code. This
+ // code handles the situation by recognizing the real object code
+ // file name given in the linker script.
+ //
+ // If an "invalid ELF header" error occurs, it is assumed that the
+ // .so file contains a linker script instead of ELF object code.
+ // In this case, the code looks for the GROUP ( ... ) linker
+ // directive. If one is found, the first file name inside the
+ // parentheses is treated as the name of a dynamic library and the
+ // code attempts to dlopen that file. If this is also unsuccessful,
+ // an error message is returned.
+
+#define NMATCH 5
+ regmatch_t match[NMATCH];
+ FILE* fp;
+ size_t match_length;
+#define MAXLINE 1000
+ char line[MAXLINE];
+ int result;
+ void* r = NULL;
+
+ ASSERT_LOCK_HELD(&linker_mutex)
+
+ // see if the error message is due to an invalid ELF header
+ IF_DEBUG(linker, debugBelch("errmsg = '%s'\n", *errmsg));
+ result = regexec(&re_invalid, *errmsg, (size_t) NMATCH, match, 0);
+ IF_DEBUG(linker, debugBelch("result = %i\n", result));
+ if (result == 0) {
+ // success -- try to read the named file as a linker script
+ match_length = (size_t) stg_min((match[1].rm_eo - match[1].rm_so),
+ MAXLINE-1);
+ strncpy(line, (*errmsg+(match[1].rm_so)),match_length);
+ line[match_length] = '\0'; // make sure string is null-terminated
+ IF_DEBUG(linker, debugBelch("file name = '%s'\n", line));
+ if ((fp = __rts_fopen(line, "r")) == NULL) {
+ // return original error if open fails
+ return NULL;
+ }
+ // try to find a GROUP or INPUT ( ... ) command
+ while (fgets(line, MAXLINE, fp) != NULL) {
+ IF_DEBUG(linker, debugBelch("input line = %s", line));
+ if (regexec(&re_realso, line, (size_t) NMATCH, match, 0) == 0) {
+ // success -- try to dlopen the first named file
+ IF_DEBUG(linker, debugBelch("match%s\n",""));
+ line[match[2].rm_eo] = '\0';
+ stgFree((void*)*errmsg); // Free old message before creating new one
+ // ROMES:TODO: NO GOOD, this is almost recursive? no, as long we
+ // move the loadNativeObj_ELF to a shared impl
+ r = loadNativeObj_POSIX(line+match[2].rm_so, errmsg);
+ break;
+ }
+ // if control reaches here, no GROUP or INPUT ( ... ) directive
+ // was found and the original error message is returned to the
+ // caller
+ }
+ fclose(fp);
+ }
+
+ return r;
+}
+
+
#endif /* elf */
=====================================
rts/linker/Elf.h
=====================================
@@ -14,7 +14,6 @@ int ocResolve_ELF ( ObjectCode* oc );
int ocRunInit_ELF ( ObjectCode* oc );
int ocRunFini_ELF ( ObjectCode* oc );
int ocAllocateExtras_ELF ( ObjectCode *oc );
-void freeNativeCode_ELF ( ObjectCode *nc );
-void *loadNativeObj_ELF ( pathchar *path, char **errmsg );
+void *loadNativeObjFromLinkerScript_ELF( char **errmsg );
#include "EndPrivate.h"
=====================================
rts/linker/LoadNativeObjPosix.c
=====================================
@@ -0,0 +1,211 @@
+#include "CheckUnload.h"
+#include "ForeignExports.h"
+#include "LinkerInternals.h"
+#include "Rts.h"
+#include "RtsUtils.h"
+#include "Profiling.h"
+
+#include "linker/LoadNativeObjPosix.h"
+
+#if defined(HAVE_DLFCN_H)
+#include <dlfcn.h>
+#endif
+
+#include <string.h>
+
+#if defined(THREADED_RTS)
+extern Mutex linker_mutex;
+#endif
+
+/*
+ * Shared object loading
+ */
+
+#if defined(HAVE_DLINFO)
+struct piterate_cb_info {
+ ObjectCode *nc;
+ void *l_addr; /* base virtual address of the loaded code */
+};
+
+static int loadNativeObjCb_(struct dl_phdr_info *info,
+ size_t _size STG_UNUSED, void *data) {
+ struct piterate_cb_info *s = (struct piterate_cb_info *) data;
+
+ // This logic mimicks _dl_addr_inside_object from glibc
+ // For reference:
+ // int
+ // internal_function
+ // _dl_addr_inside_object (struct link_map *l, const ElfW(Addr) addr)
+ // {
+ // int n = l->l_phnum;
+ // const ElfW(Addr) reladdr = addr - l->l_addr;
+ //
+ // while (--n >= 0)
+ // if (l->l_phdr[n].p_type == PT_LOAD
+ // && reladdr - l->l_phdr[n].p_vaddr >= 0
+ // && reladdr - l->l_phdr[n].p_vaddr < l->l_phdr[n].p_memsz)
+ // return 1;
+ // return 0;
+ // }
+
+ if ((void*) info->dlpi_addr == s->l_addr) {
+ int n = info->dlpi_phnum;
+ while (--n >= 0) {
+ if (info->dlpi_phdr[n].p_type == PT_LOAD) {
+ NativeCodeRange* ncr =
+ stgMallocBytes(sizeof(NativeCodeRange), "loadNativeObjCb_");
+ ncr->start = (void*) ((char*) s->l_addr + info->dlpi_phdr[n].p_vaddr);
+ ncr->end = (void*) ((char*) ncr->start + info->dlpi_phdr[n].p_memsz);
+
+ ncr->next = s->nc->nc_ranges;
+ s->nc->nc_ranges = ncr;
+ }
+ }
+ }
+ return 0;
+}
+#endif /* defined(HAVE_DLINFO) */
+
+static void copyErrmsg(char** errmsg_dest, char* errmsg) {
+ if (errmsg == NULL) errmsg = "loadNativeObj_POSIX: unknown error";
+ *errmsg_dest = stgMallocBytes(strlen(errmsg)+1, "loadNativeObj_POSIX");
+ strcpy(*errmsg_dest, errmsg);
+}
+
+void freeNativeCode_POSIX (ObjectCode *nc) {
+ ASSERT_LOCK_HELD(&linker_mutex);
+
+ dlclose(nc->dlopen_handle);
+
+ NativeCodeRange *ncr = nc->nc_ranges;
+ while (ncr) {
+ NativeCodeRange* last_ncr = ncr;
+ ncr = ncr->next;
+ stgFree(last_ncr);
+ }
+}
+
+void * loadNativeObj_POSIX (pathchar *path, char **errmsg)
+{
+ ObjectCode* nc;
+ void *hdl, *retval;
+
+ ASSERT_LOCK_HELD(&linker_mutex);
+
+ IF_DEBUG(linker, debugBelch("loadNativeObj_POSIX %" PATH_FMT "\n", path));
+
+ retval = NULL;
+
+
+ /* If we load the same object multiple times, just return the
+ * already-loaded handle. Note that this is broken if unloadNativeObj
+ * is used, as we don’t do any reference counting; see #24345.
+ */
+ ObjectCode *existing_oc = lookupObjectByPath(path);
+ if (existing_oc && existing_oc->status != OBJECT_UNLOADED) {
+ if (existing_oc->type == DYNAMIC_OBJECT) {
+ retval = existing_oc->dlopen_handle;
+ goto success;
+ }
+ copyErrmsg(errmsg, "loadNativeObj_POSIX: already loaded as non-dynamic object");
+ goto dlopen_fail;
+ }
+
+ nc = mkOc(DYNAMIC_OBJECT, path, NULL, 0, false, NULL, 0);
+
+ foreignExportsLoadingObject(nc);
+
+ // When dlopen() loads a profiled dynamic library, it calls the ctors which
+ // will call registerCcsList() to append the defined CostCentreStacks to
+ // CCS_LIST. However, another thread may be doing other things with the RTS
+ // linker that transitively calls refreshProfilingCCSs() which also accesses
+ // CCS_LIST. So there's a risk of data race that may lead to segfaults
+ // (#24423), and we need to ensure the ctors are also protected by
+ // ccs_mutex.
+#if defined(PROFILING)
+ ACQUIRE_LOCK(&ccs_mutex);
+#endif
+
+ // If we HAVE_DLINFO, we use RTLD_NOW rather than RTLD_LAZY because we want
+ // to learn eagerly about all external functions. Otherwise, there is no
+ // additional advantage to being eager, so it is better to be lazy and only bind
+ // functions when needed for better performance.
+ int dlopen_mode;
+#if defined(HAVE_DLINFO)
+ dlopen_mode = RTLD_NOW;
+#else
+ dlopen_mode = RTLD_LAZY;
+#endif
+
+ hdl = dlopen(path, dlopen_mode|RTLD_LOCAL); /* see Note [RTLD_LOCAL] */
+ nc->dlopen_handle = hdl;
+ nc->status = OBJECT_READY;
+
+#if defined(PROFILING)
+ RELEASE_LOCK(&ccs_mutex);
+#endif
+
+ foreignExportsFinishedLoadingObject();
+
+ if (hdl == NULL) {
+ /* dlopen failed; save the message in errmsg */
+ copyErrmsg(errmsg, dlerror());
+ goto dlopen_fail;
+ }
+
+#if defined(HAVE_DLINFO)
+ struct link_map *map;
+ if (dlinfo(hdl, RTLD_DI_LINKMAP, &map) == -1) {
+ /* dlinfo failed; save the message in errmsg */
+ copyErrmsg(errmsg, dlerror());
+ goto dlinfo_fail;
+ }
+
+ hdl = NULL; // pass handle ownership to nc
+
+ struct piterate_cb_info piterate_info = {
+ .nc = nc,
+ .l_addr = (void *) map->l_addr
+ };
+ dl_iterate_phdr(loadNativeObjCb_, &piterate_info);
+ if (!nc->nc_ranges) {
+ copyErrmsg(errmsg, "dl_iterate_phdr failed to find obj");
+ goto dl_iterate_phdr_fail;
+ }
+ nc->unloadable = true;
+#else
+ nc->nc_ranges = NULL;
+ nc->unloadable = false;
+#endif /* defined (HAVE_DLINFO) */
+
+ insertOCSectionIndices(nc);
+
+ nc->next_loaded_object = loaded_objects;
+ loaded_objects = nc;
+
+ retval = nc->dlopen_handle;
+
+#if defined(PROFILING)
+ // collect any new cost centres that were defined in the loaded object.
+ refreshProfilingCCSs();
+#endif
+
+ goto success;
+
+#if defined(HAVE_DLINFO)
+dl_iterate_phdr_fail:
+#endif
+ freeNativeCode_POSIX(nc);
+#if defined(HAVE_DLINFO)
+dlinfo_fail:
+#endif
+ if (hdl) dlclose(hdl);
+dlopen_fail:
+success:
+
+ IF_DEBUG(linker, debugBelch("loadNativeObj_POSIX result=%p\n", retval));
+
+ return retval;
+}
+
+
=====================================
rts/linker/LoadNativeObjPosix.h
=====================================
@@ -0,0 +1,11 @@
+#pragma once
+
+#include "Rts.h"
+#include "LinkerInternals.h"
+
+#include "BeginPrivate.h"
+
+void freeNativeCode_POSIX ( ObjectCode *nc );
+void *loadNativeObj_POSIX ( pathchar *path, char **errmsg );
+
+#include "EndPrivate.h"
=====================================
rts/linker/PEi386.c
=====================================
@@ -1865,6 +1865,7 @@ ocGetNames_PEi386 ( ObjectCode* oc )
if (result != NULL || dllInstance == 0) {
errorBelch("Could not load `%s'. Reason: %s\n",
(char*)dllName, result);
+ stgFree((void*)result);
return false;
}
=====================================
rts/rts.cabal
=====================================
@@ -458,6 +458,7 @@ library
linker/Elf.c
linker/InitFini.c
linker/LoadArchive.c
+ linker/LoadNativeObjPosix.c
linker/M32Alloc.c
linker/MMap.c
linker/MachO.c
=====================================
testsuite/tests/ghci/linking/dyn/T3372.hs
=====================================
@@ -1,3 +1,6 @@
+-- Note: This test exercises running concurrent GHCi sessions, but
+-- although this test is expected to pass, running concurrent GHCi
+-- sessions is currently broken in other ways; see #24345.
{-# LANGUAGE MagicHash #-}
module Main where
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f699827724a3e95189fd9ddb7499a6a6abf11522...573b9729cabfbbc4810ae894ec7a6932ab24dcd3
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f699827724a3e95189fd9ddb7499a6a6abf11522...573b9729cabfbbc4810ae894ec7a6932ab24dcd3
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/20240328/675fabf5/attachment-0001.html>
More information about the ghc-commits
mailing list