[Git][ghc/ghc][wip/romes/rts-linker-direct-symbol-lookup] 2 commits: rts: Make addDLL a wrapper around loadNativeObj
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Wed Apr 3 17:53:23 UTC 2024
Rodrigo Mesquita pushed to branch wip/romes/rts-linker-direct-symbol-lookup at Glasgow Haskell Compiler / GHC
Commits:
37b17f4e by Rodrigo Mesquita at 2024-04-03T18:53:01+01:00
rts: Make addDLL a wrapper around loadNativeObj
Rewrite the implementation of `addDLL` as a wrapper around the more
principled `loadNativeObj` rts linker function. The latter should be
preferred while the former is preserved for backwards compatibility.
`loadNativeObj` was previously only available on ELF platforms, so this
commit further refactors the rts linker to transform loadNativeObj_ELF
into loadNativeObj_POSIX, which is available in ELF and MachO platforms.
The refactor made it possible to remove the `dl_mutex` mutex in favour
of always using `linker_mutex` (rather than a combination of both).
Lastly, we implement `loadNativeObj` for Windows too.
- - - - -
83e7e694 by Rodrigo Mesquita at 2024-04-03T18:53:01+01: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.
- - - - -
18 changed files:
- compiler/GHC.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/Runtime/Interpreter/JS.hs
- compiler/GHC/Runtime/Interpreter/Types.hs
- libraries/ghci/GHCi/ObjLink.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/linker/PEi386.h
- rts/rts.cabal
- testsuite/tests/ghci/linking/dyn/T3372.hs
Changes:
=====================================
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/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/Runtime/Interpreter.hs
=====================================
@@ -152,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
@@ -441,52 +441,71 @@ 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 = case interpInstance interp of
+lookupSymbolInDLL interp dll str = withSymbolCache interp str $
+ case interpInstance interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
- InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (unpackFS str))
+ InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (unpackFS str))
#endif
- ExternalInterp _ -> panic "lookupSymbolInDLL: not implemented for external interpreter" -- FIXME
+ 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 = modifyMVar_ (interpLookupSymbolCache interp) (const (pure emptyUFM))
-- | loadDLL loads a dynamic library using the OS's native linker
-- (i.e. dlopen() on Unix, LoadLibrary() on Windows). It takes either
@@ -552,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/ObjLink.hs
=====================================
@@ -74,7 +74,7 @@ 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_lookupSymbolInDLL dll c_str
+ addr <- c_lookupSymbolInNativeObj dll c_str
if addr == nullPtr
then return Nothing
else return (Just addr)
@@ -99,8 +99,6 @@ prefixUnderscore
-- searches the standard locations for the appropriate library.
--
loadDLL :: String -> IO (Either String (Ptr LoadedDLL))
--- Nothing => success
--- Just err_msg => failure
loadDLL str0 = do
let
-- On Windows, addDLL takes a filename without an extension, because
@@ -112,7 +110,7 @@ loadDLL str0 = do
--
(maybe_handle, maybe_errmsg) <- withFilePath (normalise str) $ \dll ->
alloca $ \errmsg_ptr -> (,)
- <$> c_addDLL dll errmsg_ptr
+ <$> c_loadNativeObj dll errmsg_ptr
<*> peek errmsg_ptr
if maybe_handle == nullPtr
@@ -176,8 +174,8 @@ resolveObjs = do
-- Foreign declarations to RTS entry points which does the real work;
-- ---------------------------------------------------------------------------
-foreign import ccall unsafe "addDLL" c_addDLL :: CFilePath -> Ptr CString -> IO (Ptr LoadedDLL)
-foreign import ccall unsafe "lookupSymbolInDLL" c_lookupSymbolInDLL :: Ptr LoadedDLL -> CString -> IO (Ptr a)
+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
=====================================
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/lookupSymbolInNativeObj)
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
@@ -417,11 +421,8 @@ static int linker_init_done = 0 ;
#if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
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
+regex_t re_invalid;
+regex_t re_realso;
#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,87 +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 void *
-internal_dlopen(const char *dll_name, const char **errmsg_ptr)
-{
- OpenedSO* o_so;
- void *hdl;
-
- // 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
-
- if (hdl == NULL) {
- /* dlopen failed; return a ptr to the error msg. */
- char *errmsg = dlerror();
- if (errmsg == NULL) errmsg = "addDLL: unknown error";
- char *errmsg_copy = stgMallocBytes(strlen(errmsg)+1, "addDLL");
- strcpy(errmsg_copy, errmsg);
- *errmsg_ptr = 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 hdl;
-}
-
/*
Note [RTLD_LOCAL]
~~~~~~~~~~~~~~~~~
@@ -657,11 +571,10 @@ internal_dlopen(const char *dll_name, const char **errmsg_ptr)
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();
@@ -669,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) \
@@ -722,98 +634,37 @@ internal_dlsym(const char *symbol) {
// we failed to find the symbol
return NULL;
}
+# endif
-void *lookupSymbolInDLL(void *handle, const char *symbol_name)
+void *lookupSymbolInNativeObj(void *handle, const char *symbol_name)
{
+ ACQUIRE_LOCK(&linker_mutex);
+
#if defined(OBJFORMAT_MACHO)
CHECK(symbol_name[0] == '_');
symbol_name = symbol_name+1;
#endif
-
- ACQUIRE_LOCK(&dl_mutex); // dlsym alters dlerror
+#if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
void *result = dlsym(handle, symbol_name);
- RELEASE_LOCK(&dl_mutex);
+#elif defined(OBJFORMAT_PEi386)
+ void *result = lookupSymbolInDLL_PEi386(symbol_name, handle, NULL, NULL);
+#else
+ barf("lookupSymbolInNativeObj: Unsupported platform");
+#endif
+
+ RELEASE_LOCK(&linker_mutex);
return result;
}
-# endif
-void *addDLL(pathchar* dll_name, const char **errmsg_ptr)
+const char *addDLL(pathchar* dll_name)
{
-# if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
- /* ------------------- ELF DLL loader ------------------- */
-
-#define NMATCH 5
- regmatch_t match[NMATCH];
- void *handle;
- 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));
- handle = internal_dlopen(dll_name, &errmsg);
-
- if (handle != NULL) {
- return handle;
- }
-
- // 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) {
- *errmsg_ptr = errmsg; // 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
- handle = internal_dlopen(line+match[2].rm_so, errmsg_ptr);
- break;
- }
- // if control reaches here, no GROUP or INPUT ( ... ) directive
- // was found and the original error message is returned to the
- // caller
- }
- fclose(fp);
+ char *errmsg;
+ if (loadNativeObj(dll_name, &errmsg)) {
+ return NULL;
+ } else {
+ ASSERT(errmsg != NULL);
+ return errmsg;
}
- return handle;
-
-# elif defined(OBJFORMAT_PEi386)
- // FIXME
- return addDLL_PEi386(dll_name, NULL);
-
-# else
- barf("addDLL: not implemented on this platform");
-# endif
}
/* -----------------------------------------------------------------------------
@@ -1240,10 +1091,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);
+#if defined(OBJFORMAT_ELF) || defined(darwin_HOST_OS)
+ ACQUIRE_LOCK(&linker_mutex);
+ freeNativeCode_POSIX(oc);
+ RELEASE_LOCK(&linker_mutex);
#else
barf("freeObjectCode: This shouldn't happen");
#endif
@@ -1908,12 +1759,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;
}
@@ -2000,25 +1859,33 @@ addSection (Section *s, SectionKind kind, SectionAlloc alloc,
#define UNUSED(x) (void)(x)
-#if defined(OBJFORMAT_ELF)
void * loadNativeObj (pathchar *path, char **errmsg)
{
+ IF_DEBUG(linker, debugBelch("loadNativeObj: path = '%" PATH_FMT "'\n", path));
ACQUIRE_LOCK(&linker_mutex);
- void *r = loadNativeObj_ELF(path, errmsg);
- RELEASE_LOCK(&linker_mutex);
- return r;
-}
+
+#if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
+ void *r = loadNativeObj_POSIX(path, errmsg);
+#elif defined(OBJFORMAT_PEi386)
+ void *r = NULL;
+ *errmsg = (char*)addDLL_PEi386(path, (HINSTANCE*)&r);
#else
-void * STG_NORETURN
-loadNativeObj (pathchar *path, char **errmsg)
-{
- UNUSED(path);
- UNUSED(errmsg);
barf("loadNativeObj: not implemented on this platform");
-}
#endif
-HsInt unloadNativeObj (void *handle)
+#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;
+}
+
+static HsInt unloadNativeObj_(void *handle)
{
bool unloadedAnyObj = false;
@@ -2051,11 +1918,18 @@ HsInt unloadNativeObj (void *handle)
if (unloadedAnyObj) {
return 1;
} else {
- errorBelch("unloadObjNativeObj_ELF: can't find `%p' to unload", handle);
+ errorBelch("unloadObjNativeObj_: can't find `%p' to unload", handle);
return 0;
}
}
+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
=====================================
@@ -509,6 +509,7 @@ extern char **environ;
SymI_HasDataProto(stg_block_putmvar) \
MAIN_CAP_SYM \
SymI_HasProto(addDLL) \
+ SymI_HasProto(loadNativeObj) \
SymI_HasProto(addLibrarySearchPath) \
SymI_HasProto(removeLibrarySearchPath) \
SymI_HasProto(findSystemLibrary) \
@@ -619,7 +620,7 @@ extern char **environ;
SymI_HasProto(purgeObj) \
SymI_HasProto(insertSymbol) \
SymI_HasProto(lookupSymbol) \
- SymI_HasProto(lookupSymbolInDLL) \
+ SymI_HasProto(lookupSymbolInNativeObj) \
SymI_HasDataProto(stg_makeStablePtrzh) \
SymI_HasDataProto(stg_mkApUpd0zh) \
SymI_HasDataProto(stg_labelThreadzh) \
=====================================
rts/include/rts/Linker.h
=====================================
@@ -90,10 +90,10 @@ void *loadNativeObj( pathchar *path, char **errmsg );
Takes the handle returned from loadNativeObj() as an argument. */
HsInt unloadNativeObj( void *handle );
-/* load a dynamic library */
-void *addDLL(pathchar* dll_name, const char **errmsg);
+void *lookupSymbolInNativeObj(void *handle, const char *symbol_name);
-void *lookupSymbolInDLL(void *handle, const char *symbol_name);
+/* load a dynamic library */
+const char *addDLL(pathchar* dll_name);
/* add a path to the library search path */
HsPtr addLibrarySearchPath(pathchar* dll_path);
=====================================
rts/linker/Elf.c
=====================================
@@ -27,11 +27,15 @@
#include "sm/OSMem.h"
#include "linker/util.h"
#include "linker/elf_util.h"
+#include "linker/LoadNativeObjPosix.h"
+#include <fs_rts.h>
#include <link.h>
#include <stdlib.h>
#include <unistd.h>
#include <string.h>
+#include <regex.h> // regex is already used by dlopen() so this is OK
+ // to use here without requiring an additional lib
#if defined(HAVE_DLFCN_H)
#include <dlfcn.h>
#endif
@@ -2069,159 +2073,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 +2122,71 @@ int ocAllocateExtras_ELF( ObjectCode *oc )
#endif /* NEED_SYMBOL_EXTRAS */
+extern regex_t re_invalid;
+extern regex_t re_realso;
+
+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
+ 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,214 @@
+#include "LinkerInternals.h"
+#include "Rts.h"
+
+#if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
+
+#include "CheckUnload.h"
+#include "ForeignExports.h"
+#include "RtsUtils.h"
+#include "Profiling.h"
+
+#include "linker/LoadNativeObjPosix.h"
+
+#if defined(HAVE_DLFCN_H)
+#include <dlfcn.h>
+#endif
+
+#if defined(HAVE_DLINFO)
+#include <link.h>
+#endif
+
+#include <string.h>
+
+/*
+ * 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;
+}
+
+#endif /* elf + macho */
=====================================
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
=====================================
@@ -1017,7 +1017,10 @@ bool checkAndLoadImportLibrary( pathchar* arch_name, char* member_name, FILE* f
stgFree(dllName);
IF_DEBUG(linker, debugBelch("loadArchive: read symbol %s from lib `%" PATH_FMT "'\n", symbol, dll));
- const char* result = addDLL(dll);
+ // We must call `addDLL_PEi386` directly rather than `addDLL` because `addDLL`
+ // is now a wrapper around `loadNativeObj` which acquires a lock which we
+ // already have here.
+ const char* result = addDLL_PEi386(dll, NULL);
stgFree(image);
@@ -1141,47 +1144,57 @@ SymbolAddr*
lookupSymbolInDLLs ( const SymbolName* lbl, ObjectCode *dependent )
{
OpenedDLL* o_dll;
- SymbolAddr* sym;
+ SymbolAddr* res;
- for (o_dll = opened_dlls; o_dll != NULL; o_dll = o_dll->next) {
- /* debugBelch("look in %ls for %s\n", o_dll->name, lbl); */
+ for (o_dll = opened_dlls; o_dll != NULL; o_dll = o_dll->next)
+ if ((res = lookupSymbolInDLL_PEi386(lbl, o_dll->instance, o_dll->name, dependent)))
+ return res;
+ return NULL;
+}
- sym = GetProcAddress(o_dll->instance, lbl+STRIP_LEADING_UNDERSCORE);
- if (sym != NULL) {
- /*debugBelch("found %s in %s\n", lbl+1,o_dll->name);*/
- return sym;
- }
+SymbolAddr*
+lookupSymbolInDLL_PEi386 ( const SymbolName* lbl, HINSTANCE instance, pathchar* dll_name STG_UNUSED, ObjectCode *dependent)
+{
+ SymbolAddr* sym;
- // TODO: Drop this
- /* Ticket #2283.
- Long description: http://support.microsoft.com/kb/132044
- tl;dr:
- If C/C++ compiler sees __declspec(dllimport) ... foo ...
- it generates call *__imp_foo, and __imp_foo here has exactly
- the same semantics as in __imp_foo = GetProcAddress(..., "foo")
- */
- if (sym == NULL && strncmp (lbl, "__imp_", 6) == 0) {
- sym = GetProcAddress(o_dll->instance,
- lbl + 6 + STRIP_LEADING_UNDERSCORE);
- if (sym != NULL) {
- SymbolAddr** indirect = m32_alloc(dependent->rw_m32, sizeof(SymbolAddr*), 8);
- if (indirect == NULL) {
- barf("lookupSymbolInDLLs: Failed to allocation indirection");
- }
- *indirect = sym;
- IF_DEBUG(linker,
- debugBelch("warning: %s from %S is linked instead of %s\n",
- lbl+6+STRIP_LEADING_UNDERSCORE, o_dll->name, lbl));
- return (void*) indirect;
- }
- }
+ /* debugBelch("look in %ls for %s\n", dll_name, lbl); */
- sym = GetProcAddress(o_dll->instance, lbl);
+ sym = GetProcAddress(instance, lbl+STRIP_LEADING_UNDERSCORE);
+ if (sym != NULL) {
+ /*debugBelch("found %s in %ls\n", lbl+STRIP_LEADING_UNDERSCORE,dll_name);*/
+ return sym;
+ }
+
+ // TODO: Drop this
+ /* Ticket #2283.
+ Long description: http://support.microsoft.com/kb/132044
+ tl;dr:
+ If C/C++ compiler sees __declspec(dllimport) ... foo ...
+ it generates call *__imp_foo, and __imp_foo here has exactly
+ the same semantics as in __imp_foo = GetProcAddress(..., "foo")
+ */
+ if (sym == NULL && strncmp (lbl, "__imp_", 6) == 0) {
+ sym = GetProcAddress(instance,
+ lbl + 6 + STRIP_LEADING_UNDERSCORE);
if (sym != NULL) {
- /*debugBelch("found %s in %s\n", lbl,o_dll->name);*/
- return sym;
+ SymbolAddr** indirect = m32_alloc(dependent->rw_m32, sizeof(SymbolAddr*), 8);
+ if (indirect == NULL) {
+ barf("lookupSymbolInDLLs: Failed to allocation indirection");
+ }
+ *indirect = sym;
+ IF_DEBUG(linker,
+ debugBelch("warning: %s from %S is linked instead of %s\n",
+ lbl+6+STRIP_LEADING_UNDERSCORE, dll_name, lbl));
+ return (void*) indirect;
}
}
+
+ sym = GetProcAddress(instance, lbl);
+ if (sym != NULL) {
+ /*debugBelch("found %s in %s\n", lbl,dll_name);*/
+ return sym;
+ }
+
return NULL;
}
=====================================
rts/linker/PEi386.h
=====================================
@@ -60,6 +60,7 @@ bool ocRunFini_PEi386 ( ObjectCode *oc );
bool ocGetNames_PEi386 ( ObjectCode* oc );
bool ocVerifyImage_PEi386 ( ObjectCode* oc );
SymbolAddr *lookupSymbol_PEi386(SymbolName *lbl, ObjectCode *dependent, SymType *type);
+SymbolAddr *lookupSymbolInDLL_PEi386 (const SymbolName* lbl, HINSTANCE instance, pathchar* dll_name, ObjectCode *dependent);
/* See Note [mingw-w64 name decoration scheme] */
/* We use myindex to calculate array addresses, rather than
=====================================
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/39e5cb6c7092073f18a6442fac858d1a0fc70fdf...83e7e694278980c08874a66dd9d35330619c300d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/39e5cb6c7092073f18a6442fac858d1a0fc70fdf...83e7e694278980c08874a66dd9d35330619c300d
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/20240403/04ce91a1/attachment-0001.html>
More information about the ghc-commits
mailing list