Make the linker API thread-safe

We used to be able to rely on the client to use the API in a
single-threaded way, but now that the GC calls into the linker to
unload objects this isn't a safe assumption.

7 files changed, 89 insertions, 41 deletions

diff --git a/docs/users_guide/7.10.1-notes.xml b/docs/users_guide/7.10.1-notes.xml
index 596ec16f1b..b18c4d0fad 100644
--- a/docs/users_guide/7.10.1-notes.xml
+++ b/docs/users_guide/7.10.1-notes.xml
@@ -243,7 +243,11 @@
         <itemizedlist>
             <listitem>
                 <para>
-                    TODO FIXME
+                    The linker API is now thread-safe.  The main
+                    user-facing impact of this change is that you must
+                    now call <literal>initLinker</literal> before
+                    calling <literal>loadObj</literal> or any of the
+                    other linker APIs.
                </para>
            </listitem>
        </itemizedlist>
diff --git a/rts/CheckUnload.c b/rts/CheckUnload.c
index c63a35a24e..73573fbb34 100644
--- a/rts/CheckUnload.c
+++ b/rts/CheckUnload.c
@@ -260,6 +260,8 @@ void checkUnload (StgClosure *static_objects)
 
   if (unloaded_objects == NULL) return;
 
+  ACQUIRE_LOCK(&linker_mutex);
+
   // Mark every unloadable object as unreferenced initially
   for (oc = unloaded_objects; oc; oc = oc->next) {
       IF_DEBUG(linker, debugBelch("Checking whether to unload %" PATH_FMT "\n",
@@ -317,4 +319,6 @@ void checkUnload (StgClosure *static_objects)
   }
 
   freeHashTable(addrs, NULL);
+
+  RELEASE_LOCK(&linker_mutex);
 }
diff --git a/rts/Linker.c b/rts/Linker.c
index 2c74a0dd35..6d9abfe695 100644
--- a/rts/Linker.c
+++ b/rts/Linker.c
@@ -155,6 +155,10 @@ ObjectCode *objects = NULL;     /* initially empty */
    to be actually freed via checkUnload() */
 ObjectCode *unloaded_objects = NULL; /* initially empty */
 
+#ifdef THREADED_RTS
+Mutex linker_mutex;
+#endif
+
 /* Type of the initializer */
 typedef void (*init_t) (int argc, char **argv, char **env);
 
@@ -1639,6 +1643,7 @@ initLinker_ (int retain_cafs)
 
 #if defined(THREADED_RTS) && (defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO))
     initMutex(&dl_mutex);
+    initMutex(&linker_mutex);
 #endif
     symhash = allocStrHashTable();
 
@@ -1728,6 +1733,9 @@ exitLinker( void ) {
    if (linker_init_done == 1) {
        freeHashTable(symhash, free);
    }
+#ifdef THREADED_RTS
+   closeMutex(&linker_mutex);
+#endif
 }
 
 /* -----------------------------------------------------------------------------
@@ -1889,8 +1897,6 @@ addDLL( pathchar *dll_name )
    char line[MAXLINE];
    int result;
 
-   initLinker();
-
    IF_DEBUG(linker, debugBelch("addDLL: dll_name = '%s'\n", dll_name));
    errmsg = internal_dlopen(dll_name);
 
@@ -1952,8 +1958,6 @@ addDLL( pathchar *dll_name )
    OpenedDLL* o_dll;
    HINSTANCE  instance;
 
-   initLinker();
-
    /* debugBelch("\naddDLL; dll_name = `%s'\n", dll_name); */
 
    /* See if we've already got it, and ignore if so. */
@@ -2022,12 +2026,11 @@ HsInt insertSymbol(pathchar* obj_name, char* key, void* data)
 /* -----------------------------------------------------------------------------
  * lookup a symbol in the hash table
  */
-void *
-lookupSymbol( char *lbl )
+static void* lookupSymbol_ (char *lbl)
 {
     void *val;
     IF_DEBUG(linker, debugBelch("lookupSymbol: looking up %s\n", lbl));
-    initLinker() ;
+
     ASSERT(symhash != NULL);
 
     if (!ghciLookupSymbolTable(symhash, lbl, &val)) {
@@ -2060,14 +2063,15 @@ lookupSymbol( char *lbl )
         void* sym;
 
         sym = lookupSymbolInDLLs((unsigned char*)lbl);
-        if (sym != NULL) { return sym; };
+        if (sym != NULL) {
+            return sym;
+        };
 
         // Also try looking up the symbol without the @N suffix.  Some
         // DLLs have the suffixes on their symbols, some don't.
         zapTrailingAtSign ( (unsigned char*)lbl );
         sym = lookupSymbolInDLLs((unsigned char*)lbl);
-        if (sym != NULL) { return sym; };
-        return NULL;
+        return sym; // might be NULL if not found
 
 #       else
         ASSERT(2+2 == 5);
@@ -2079,6 +2083,14 @@ lookupSymbol( char *lbl )
     }
 }
 
+void* lookupSymbol( char *lbl )
+{
+    ACQUIRE_LOCK(&linker_mutex);
+    char *r = lookupSymbol_(lbl);
+    RELEASE_LOCK(&linker_mutex);
+    return r;
+}
+
 /* -----------------------------------------------------------------------------
    Create a StablePtr for a foreign export.  This is normally called by
    a C function with __attribute__((constructor)), which is generated
@@ -2125,8 +2137,6 @@ void ghci_enquire ( char* addr )
    const int DELTA = 64;
    ObjectCode* oc;
 
-   initLinker();
-
    for (oc = objects; oc; oc = oc->next) {
       for (i = 0; i < oc->n_symbols; i++) {
          sym = oc->symbols[i];
@@ -2409,8 +2419,7 @@ isAlreadyLoaded( pathchar *path )
     return 0; /* not loaded yet */
 }
 
-HsInt
-loadArchive( pathchar *path )
+static HsInt loadArchive_ (pathchar *path)
 {
     ObjectCode* oc;
     char *image;
@@ -2451,8 +2460,6 @@ loadArchive( pathchar *path )
      * all resources correctly.  This function is pretty complex, so it needs
      * to be refactored to make this practical. */
 
-    initLinker();
-
     IF_DEBUG(linker, debugBelch("loadArchive: start\n"));
     IF_DEBUG(linker, debugBelch("loadArchive: Loading archive `%" PATH_FMT" '\n", path));
 
@@ -2877,13 +2884,20 @@ loadArchive( pathchar *path )
     return 1;
 }
 
+HsInt loadArchive (pathchar *path)
+{
+   ACQUIRE_LOCK(&linker_mutex);
+   HsInt r = loadArchive_(path);
+   RELEASE_LOCK(&linker_mutex);
+   return r;
+}
+
 /* -----------------------------------------------------------------------------
  * Load an obj (populate the global symbol table, but don't resolve yet)
  *
  * Returns: 1 if ok, 0 on error.
  */
-HsInt
-loadObj( pathchar *path )
+static HsInt loadObj_ (pathchar *path)
 {
    ObjectCode* oc;
    char *image;
@@ -2900,8 +2914,6 @@ loadObj( pathchar *path )
 #endif
    IF_DEBUG(linker, debugBelch("loadObj %" PATH_FMT "\n", path));
 
-   initLinker();
-
    /* debugBelch("loadObj %s\n", path ); */
 
    /* Check that we haven't already loaded this object.
@@ -2938,7 +2950,9 @@ loadObj( pathchar *path )
 
    image = mmapForLinker(fileSize, 0, fd);
    close(fd);
-   if (image == NULL) return 0;
+   if (image == NULL) {
+       return 0;
+   }
 
 #else /* !USE_MMAP */
    /* load the image into memory */
@@ -3010,6 +3024,14 @@ loadObj( pathchar *path )
    return 1;
 }
 
+HsInt loadObj (pathchar *path)
+{
+   ACQUIRE_LOCK(&linker_mutex);
+   HsInt r = loadObj_(path);
+   RELEASE_LOCK(&linker_mutex);
+   return r;
+}
+
 static HsInt
 loadOc( ObjectCode* oc ) {
    int r;
@@ -3074,14 +3096,12 @@ loadOc( ObjectCode* oc ) {
  *
  * Returns: 1 if ok, 0 on error.
  */
-HsInt
-resolveObjs( void )
+static HsInt resolveObjs_ (void)
 {
     ObjectCode *oc;
     int r;
 
     IF_DEBUG(linker, debugBelch("resolveObjs: start\n"));
-    initLinker();
 
     for (oc = objects; oc; oc = oc->next) {
         if (oc->status != OBJECT_RESOLVED) {
@@ -3119,11 +3139,18 @@ resolveObjs( void )
     return 1;
 }
 
+HsInt resolveObjs (void)
+{
+    ACQUIRE_LOCK(&linker_mutex);
+    HsInt r = resolveObjs_();
+    RELEASE_LOCK(&linker_mutex);
+    return r;
+}
+
 /* -----------------------------------------------------------------------------
  * delete an object from the pool
  */
-HsInt
-unloadObj( pathchar *path )
+static HsInt unloadObj_ (pathchar *path)
 {
     ObjectCode *oc, *prev, *next;
     HsBool unloadedAnyObj = HS_BOOL_FALSE;
@@ -3131,8 +3158,6 @@ unloadObj( pathchar *path )
     ASSERT(symhash != NULL);
     ASSERT(objects != NULL);
 
-    initLinker();
-
     IF_DEBUG(linker, debugBelch("unloadObj: %" PATH_FMT "\n", path));
 
     prev = NULL;
@@ -3182,6 +3207,14 @@ unloadObj( pathchar *path )
     }
 }
 
+HsInt unloadObj (pathchar *path)
+{
+    ACQUIRE_LOCK(&linker_mutex);
+    HsInt r = unloadObj_(path);
+    RELEASE_LOCK(&linker_mutex);
+    return r;
+}
+
 /* -----------------------------------------------------------------------------
  * Sanity checking.  For each ObjectCode, maintain a list of address ranges
  * which may be prodded during relocation, and abort if we try and write
@@ -4573,7 +4606,7 @@ ocResolve_PEi386 ( ObjectCode* oc )
               + ((size_t)(sym->Value));
          } else {
             copyName ( sym->Name, strtab, symbol, 1000-1 );
-            S = (size_t) lookupSymbol( (char*)symbol );
+            S = (size_t) lookupSymbol_( (char*)symbol );
             if ((void*)S != NULL) goto foundit;
             errorBelch("%" PATH_FMT ": unknown symbol `%s'", oc->fileName, symbol);
             return 0;
@@ -5435,7 +5468,7 @@ do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC,
 
          } else {
             symbol = strtab + sym.st_name;
-            S_tmp = lookupSymbol( symbol );
+            S_tmp = lookupSymbol_( symbol );
             if (S_tmp == NULL) return 0;
             S = (Elf_Addr)S_tmp;
          }
@@ -5746,7 +5779,7 @@ do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC,
          } else {
             /* No, so look up the name in our global table. */
             symbol = strtab + sym.st_name;
-            S_tmp = lookupSymbol( symbol );
+            S_tmp = lookupSymbol_( symbol );
             S = (Elf_Addr)S_tmp;
 
 #ifdef ELF_FUNCTION_DESC
@@ -6295,7 +6328,7 @@ resolveImports(
             addr = (void*) (symbol->n_value);
             IF_DEBUG(linker, debugBelch("resolveImports: undefined external %s has value %p\n", nm, addr));
         } else {
-            addr = lookupSymbol(nm);
+            addr = lookupSymbol_(nm);
             IF_DEBUG(linker, debugBelch("resolveImports: looking up %s, %p\n", nm, addr));
         }
 
@@ -6451,7 +6484,7 @@ relocateSection(
                     // symtab, or it is undefined, meaning dlsym must be used
                     // to resolve it.
 
-                    addr = lookupSymbol(nm);
+                    addr = lookupSymbol_(nm);
                     IF_DEBUG(linker, debugBelch("relocateSection: looked up %s, "
                                                 "external X86_64_RELOC_GOT or X86_64_RELOC_GOT_LOAD\n", nm));
                     IF_DEBUG(linker, debugBelch("               : addr = %p\n", addr));
@@ -6503,7 +6536,7 @@ relocateSection(
                 IF_DEBUG(linker, debugBelch("relocateSection, defined external symbol %s, relocated address %p\n", nm, (void *)value));
             }
             else {
-                addr = lookupSymbol(nm);
+                addr = lookupSymbol_(nm);
                 if (addr == NULL)
                 {
                      errorBelch("\nlookupSymbol failed in relocateSection (relocate external)\n"
@@ -6806,7 +6839,7 @@ relocateSection(
                 else {
                     struct nlist *symbol = &nlist[reloc->r_symbolnum];
                     char *nm = image + symLC->stroff + symbol->n_un.n_strx;
-                    void *symbolAddress = lookupSymbol(nm);
+                    void *symbolAddress = lookupSymbol_(nm);
 
                     if (!symbolAddress) {
                         errorBelch("\nunknown symbol `%s'", nm);
@@ -7033,7 +7066,7 @@ ocGetNames_MachO(ObjectCode* oc)
                 if(nlist[i].n_type & N_EXT)
                 {
                     char *nm = image + symLC->stroff + nlist[i].n_un.n_strx;
-                    if ((nlist[i].n_desc & N_WEAK_DEF) && lookupSymbol(nm)) {
+                    if ((nlist[i].n_desc & N_WEAK_DEF) && lookupSymbol_(nm)) {
                         // weak definition, and we already have a definition
                         IF_DEBUG(linker, debugBelch("    weak: %s\n", nm));
                     }
diff --git a/rts/LinkerInternals.h b/rts/LinkerInternals.h
index e1942bc8ae..4fe533b903 100644
--- a/rts/LinkerInternals.h
+++ b/rts/LinkerInternals.h
@@ -144,6 +144,10 @@ typedef struct _ObjectCode {
 extern ObjectCode *objects;
 extern ObjectCode *unloaded_objects;
 
+#ifdef THREADED_RTS
+extern Mutex linker_mutex;
+#endif
+
 void exitLinker( void );
 
 void freeObjectCode (ObjectCode *oc);
diff --git a/testsuite/tests/rts/Makefile b/testsuite/tests/rts/Makefile
index 8a7cb8af02..c943bb4135 100644
--- a/testsuite/tests/rts/Makefile
+++ b/testsuite/tests/rts/Makefile
@@ -124,7 +124,7 @@ linker_unload:
 	$(RM) Test.o Test.hi
 	"$(TEST_HC)" $(TEST_HC_OPTS) -c Test.hs -v0
 	# -rtsopts causes a warning
-	"$(TEST_HC)" $(filter-out -rtsopts, $(TEST_HC_OPTS)) linker_unload.c -o linker_unload -no-hs-main -optc-Werror -debug -optc-g
+	"$(TEST_HC)" $(filter-out -rtsopts, $(TEST_HC_OPTS)) linker_unload.c -o linker_unload -no-hs-main -optc-Werror -threaded
 	./linker_unload $(BASE) $(GHC_PRIM) $(INTEGER_GMP)
 
 # -----------------------------------------------------------------------------
@@ -142,7 +142,7 @@ linker_unload:
 .PHONY: linker_error1
 linker_error1:
 	"$(TEST_HC)" -c linker_error.c -o linker_error1.o
-	"$(TEST_HC)" linker_error1.o -o linker_error1 -no-hs-main -optc-g -debug
+	"$(TEST_HC)" linker_error1.o -o linker_error1 -no-hs-main -optc-g -debug -threaded
 	./linker_error1 linker_error.c
 
 # linker_error2: the object file has an unknown symbol (fails in
@@ -152,7 +152,7 @@ linker_error1:
 linker_error2:
 	"$(TEST_HC)" -c linker_error.c -o linker_error2.o
 	"$(TEST_HC)" -c linker_error2.c -o linker_error2_o.o
-	"$(TEST_HC)" linker_error2.o -o linker_error2 -no-hs-main -optc-g -debug
+	"$(TEST_HC)" linker_error2.o -o linker_error2 -no-hs-main -optc-g -debug -threaded
 	./linker_error2 linker_error2_o.o
 
 # linker_error3: the object file duplicates an existing symbol (fails
@@ -162,5 +162,5 @@ linker_error2:
 linker_error3:
 	"$(TEST_HC)" -c linker_error.c -o linker_error3.o
 	"$(TEST_HC)" -c linker_error3.c -o linker_error3_o.o
-	"$(TEST_HC)" linker_error3.o -o linker_error3 -no-hs-main -optc-g -debug
+	"$(TEST_HC)" linker_error3.o -o linker_error3 -no-hs-main -optc-g -debug -threaded
 	./linker_error3 linker_error3_o.o
diff --git a/testsuite/tests/rts/T2615.hs b/testsuite/tests/rts/T2615.hs
index ee04d93bcf..53c2d13ceb 100644
--- a/testsuite/tests/rts/T2615.hs
+++ b/testsuite/tests/rts/T2615.hs
@@ -3,6 +3,7 @@ import ObjLink
 library_name = "libfoo_script_T2615.so" -- this is really a linker script
 
 main = do
+  initObjLinker
   result <- loadDLL library_name
   case result of
     Nothing -> putStrLn (library_name ++ " loaded successfully")
diff --git a/testsuite/tests/rts/rdynamic.hs b/testsuite/tests/rts/rdynamic.hs
index 5fb4651ff9..17f8df76cd 100644
--- a/testsuite/tests/rts/rdynamic.hs
+++ b/testsuite/tests/rts/rdynamic.hs
@@ -26,6 +26,7 @@ loadFunction :: Maybe String
              -> String
            -> IO (Maybe a)
 loadFunction mpkg m valsym = do
+    c_initLinker
     let symbol = prefixUnderscore
                    ++ maybe "" (\p -> zEncodeString p ++ "_") mpkg
                    ++ zEncodeString m ++ "_" ++ zEncodeString valsym
@@ -39,3 +40,4 @@ loadFunction mpkg m valsym = do
     prefixUnderscore = if elem os ["darwin","mingw32","cygwin"] then "_" else ""
 
 foreign import ccall safe "lookupSymbol" c_lookupSymbol :: CString -> IO (Ptr a)
+foreign import ccall safe "initLinker" c_initLinker :: IO ()