[Git][ghc/ghc][wip/romes/rts-linker-direct-symbol-lookup] 7 commits: rts: free error message before returning
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Wed Mar 20 17:24:43 UTC 2024
Rodrigo Mesquita pushed to branch wip/romes/rts-linker-direct-symbol-lookup at Glasgow Haskell Compiler / GHC
Commits:
359b7ecb by Rodrigo Mesquita at 2024-03-20T17:13:32+00:00
rts: free error message before returning
Fixes a memory leak in rts/linker/PEi386.c
- - - - -
2f043908 by Rodrigo Mesquita at 2024-03-20T17:13:32+00:00
Start writing test
- - - - -
a9994389 by Alexis King at 2024-03-20T17:13:32+00:00
wip: avoid linear search when looking up Haskell symbols via dlsym
- - - - -
fe505ac1 by Alexis King at 2024-03-20T17:23:43+00:00
wip: make addDLL wrapper around loadNativeObj
- - - - -
d3606fe9 by Alexis King at 2024-03-20T17:24:04+00:00
wip: use loadNativeObj to implement addDLL
- - - - -
7ceaacb4 by Rodrigo Mesquita at 2024-03-20T17:24:05+00:00
Refactor loadNativeObj_ELF to _POSIX and delete dl_mutex
CPP Support loadNativeObj in MachO
- - - - -
f49e5a18 by Rodrigo Mesquita at 2024-03-20T17:24:05+00:00
Fail if no symbol is found in the relevant DLLs
- - - - -
25 changed files:
- + T23415/Makefile
- + T23415/main.hs
- + T23415/make_shared_libs.sh
- + T23415/new-main.hs
- + T23415/run_test.sh
- compiler/GHC/ByteCode/Linker.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
- 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/ByteCode/Linker.hs
=====================================
@@ -38,6 +38,7 @@ import GHC.Utils.Outputable
import GHC.Types.Name
import GHC.Types.Name.Env
+import GHC.Types.Unique.DFM
import Language.Haskell.Syntax.Module.Name
@@ -52,31 +53,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 +92,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,14 +112,14 @@ 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"
@@ -133,11 +135,12 @@ lookupPrimOp interp primop = do
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,7 +152,7 @@ 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)
@@ -158,11 +161,27 @@ resolvePtr interp le bco_ix ptr = case ptr of
-> ResolvedBCOStaticPtr <$> lookupPrimOp interp 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 [] = panic "lookupHsSymbol: symbol not found in the loaded_dlls associated with this pkg_id"
+
+ go loaded_dlls
+
linkFail :: String -> String -> IO a
linkFail who what
= throwGhcExceptionIO (ProgramError $
=====================================
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 =
@@ -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,7 +615,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 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)
@@ -677,7 +678,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 } }
@@ -858,8 +859,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 +900,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 +915,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 +923,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 +932,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 +1094,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 +1147,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 +1170,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 +1196,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 +1249,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 )
@@ -146,11 +147,13 @@ data LoadedPkgInfo
{ loaded_pkg_uid :: !UnitId
, loaded_pkg_hs_objs :: ![LibrarySpec]
, loaded_pkg_non_hs_objs :: ![LibrarySpec]
+ , loaded_pkg_hs_dlls :: ![RemotePtr LoadedDLL]
+ -- ^ TODO: write Note
, 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
=====================================
compiler/GHC/Runtime/Interpreter.hs
=====================================
@@ -35,6 +35,7 @@ module GHC.Runtime.Interpreter
-- * The object-code linker
, initObjLinker
, lookupSymbol
+ , lookupSymbolInDLL
, lookupClosure
, loadDLL
, loadArchive
@@ -467,6 +468,13 @@ lookupSymbol interp str = case interpInstance interp of
ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)
+lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> FastString -> IO (Maybe (Ptr ()))
+lookupSymbolInDLL interp dll str = case interpInstance interp of
+#if defined(HAVE_INTERNAL_INTERPRETER)
+ InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (unpackFS str))
+#endif
+ ExternalInterp _ -> panic "lookupSymbolInDLL: not implemented for external interpreter" -- FIXME
+
lookupClosure :: Interp -> String -> IO (Maybe HValueRef)
lookupClosure interp str =
interpCmd interp (LookupClosure str)
@@ -485,12 +493,7 @@ purgeLookupSymbolCache interp = case interpInstance interp of
-- 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 ()
=====================================
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
@@ -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);
+ // ROMES:TODO: This previously acquired dl_mutex. Check that acquiring linker_mutex here is fine.
+ ACQUIRE_LOCK(&linker_mutex);
freeNativeCode_ELF(oc);
- RELEASE_LOCK(&dl_mutex);
+ 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(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/d408a07a0b5e9888d1c33a7a202880c06869b317...f49e5a187adeebb9015c25ea90b0fb6638e4c553
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d408a07a0b5e9888d1c33a7a202880c06869b317...f49e5a187adeebb9015c25ea90b0fb6638e4c553
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/20240320/b6b09958/attachment-0001.html>
More information about the ghc-commits
mailing list