Fix archive loading on Windows by the runtime loader

The runtime loader is unable to find archive files `.a` shipping
with the inplace `GCC`.

It seems the issue is caused by `findArchive` being unable to
find any archives that are shipped using the in-place `GCC`.

- It works on Linux because `findArchive` would search
  the standard Linux include path.
- It works during compilation because `GCC` can find it's own libraries
  (we explicitly tell it where to look for libraries using the `gcc`
  wrapper around `realgcc`)

So fixing the issue means using `searchForLibUsingGcc` in `findArchive`
as well, which will then find the correct file.

The reason for the error as it is, is because if we can't locate the
library using any of the methods we have, we assume it is a system dll,
or something on the system search path.  e.g. if trying to load
`kernel32.dll`.

There is a slight issue in that the `GHCi` code (incorrectly) favors
`static archives` over `dynamic` ones

```
findDll        `orElse`
findArchive    `orElse`
tryGcc         `orElse`
tryGccPrefixed `orElse`
assumeDll
```
This has the unwanted effect of when `kernel32` is specified as a lib,
it will try to load `kernel32.a` instead of `kernel32.dll`.

To solve this I have added another search function that is able to
search the Windows search paths using `SearchPath` in order to find if
it is a dll on the system search path.

The new search order is:

```
findDll     `orElse`
findSysDll  `orElse`
tryGcc      `orElse`
findArchive `orElse`
assumeDll
```

(`tryGccPrefixed` was rolled into `tryGcc` so it is no longer needed at
top level)

Test Plan: ./validate added new windows tests T3242

Reviewers: thomie, erikd, hvr, austin, bgamari

Reviewed By: thomie, erikd, bgamari

Differential Revision: https://phabricator.haskell.org/D1455

GHC Trac Issues: #3242

7 files changed, 98 insertions, 22 deletions

diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs
index 13085090ef..d1f226aa9e 100644
--- a/compiler/ghci/Linker.hs
+++ b/compiler/ghci/Linker.hs
@@ -55,6 +55,7 @@ import SysTools
 
 -- Standard libraries
 import Control.Monad
+import Control.Applicative((<|>))
 
 import Data.IORef
 import Data.List
@@ -1209,20 +1210,25 @@ locateLib dflags is_hs dirs lib
     -- For non-Haskell libraries (e.g. gmp, iconv):
     --   first look in library-dirs for a dynamic library (libfoo.so)
     --   then  look in library-dirs for a static library (libfoo.a)
+    --   first look in library-dirs and inplace GCC for a dynamic library (libfoo.so)
+    --   then  check for system dynamic libraries (e.g. kernel32.dll on windows)
     --   then  try "gcc --print-file-name" to search gcc's search path
+    --   then  look in library-dirs and inplace GCC for a static library (libfoo.a)
     --       for a dynamic library (#5289)
     --   otherwise, assume loadDLL can find it
     --
-  = findDll `orElse`
+  = findDll     `orElse`
+    findSysDll  `orElse`
+    tryGcc      `orElse`
     findArchive `orElse`
-    tryGcc `orElse`
-    tryGccPrefixed `orElse`
     assumeDll
 
   | dynamicGhc
     -- When the GHC package was compiled as dynamic library (=DYNAMIC set),
     -- we search for .so libraries first.
-  = findHSDll `orElse` findDynObject `orElse` assumeDll
+  = findHSDll     `orElse`
+    findDynObject `orElse`
+    assumeDll
 
   | rtsIsProfiled
     -- When the GHC package is profiled, only a libHSfoo_p.a archive will do.
@@ -1232,7 +1238,7 @@ locateLib dflags is_hs dirs lib
   | otherwise
     -- HSfoo.o is the best, but only works for the normal way
     -- libHSfoo.a is the backup option.
-  = findObject `orElse`
+  = findObject  `orElse`
     findArchive `orElse`
     assumeDll
 
@@ -1253,11 +1259,15 @@ locateLib dflags is_hs dirs lib
 
      findObject     = liftM (fmap Object)  $ findFile dirs obj_file
      findDynObject  = liftM (fmap Object)  $ findFile dirs dyn_obj_file
-     findArchive    = liftM (fmap Archive) $ findFile dirs arch_file
+     findArchive    = let local  = liftM (fmap Archive) $ findFile dirs arch_file
+                          linked = liftM (fmap Archive) $ searchForLibUsingGcc dflags arch_file dirs
+                      in liftM2 (<|>) local linked
      findHSDll      = liftM (fmap DLLPath) $ findFile dirs hs_dyn_lib_file
      findDll        = liftM (fmap DLLPath) $ findFile dirs dyn_lib_file
-     tryGcc         = liftM (fmap DLLPath) $ searchForLibUsingGcc dflags so_name     dirs
-     tryGccPrefixed = liftM (fmap DLLPath) $ searchForLibUsingGcc dflags lib_so_name dirs
+     findSysDll     = fmap (fmap $ DLL . takeFileName) $ findSystemLibrary so_name
+     tryGcc         = let short = liftM (fmap DLLPath) $ searchForLibUsingGcc dflags so_name     dirs
+                          full  = liftM (fmap DLLPath) $ searchForLibUsingGcc dflags lib_so_name dirs
+                      in liftM2 (<|>) short full
 
      assumeDll   = return (DLL lib)
      infixr `orElse`
diff --git a/compiler/ghci/ObjLink.hs b/compiler/ghci/ObjLink.hs
index d5d4980387..b1cfe61da9 100644
--- a/compiler/ghci/ObjLink.hs
+++ b/compiler/ghci/ObjLink.hs
@@ -9,16 +9,17 @@
 -- | Primarily, this module consists of an interface to the C-land
 -- dynamic linker.
 module ObjLink (
-   initObjLinker,          -- :: IO ()
-   loadDLL,                -- :: String -> IO (Maybe String)
-   loadArchive,            -- :: String -> IO ()
-   loadObj,                -- :: String -> IO ()
-   unloadObj,              -- :: String -> IO ()
-   insertSymbol,           -- :: String -> String -> Ptr a -> IO ()
-   lookupSymbol,           -- :: String -> IO (Maybe (Ptr a))
-   resolveObjs,            -- :: IO SuccessFlag
-   addLibrarySearchPath,   -- :: CFilePath -> IO (Ptr ())
-   removeLibrarySearchPath -- :: Ptr() -> IO Bool
+   initObjLinker,           -- :: IO ()
+   loadDLL,                 -- :: String   -> IO (Maybe String)
+   loadArchive,             -- :: String   -> IO ()
+   loadObj,                 -- :: String   -> IO ()
+   unloadObj,               -- :: String   -> IO ()
+   insertSymbol,            -- :: String   -> String -> Ptr a -> IO ()
+   lookupSymbol,            -- :: String   -> IO (Maybe (Ptr a))
+   resolveObjs,             -- :: IO SuccessFlag
+   addLibrarySearchPath,    -- :: FilePath -> IO (Ptr ())
+   removeLibrarySearchPath, -- :: Ptr ()   -> IO Bool
+   findSystemLibrary        -- :: FilePath -> IO (Maybe FilePath)
   )  where
 
 import Panic
@@ -28,9 +29,10 @@ import Util
 
 import Control.Monad    ( when )
 import Foreign.C
+import Foreign.Marshal.Alloc ( free )
 import Foreign          ( nullPtr )
 import GHC.Exts         ( Ptr(..) )
-import System.Posix.Internals ( CFilePath, withFilePath )
+import System.Posix.Internals ( CFilePath, withFilePath, peekFilePath )
 import System.FilePath  ( dropExtension, normalise )
 
 
@@ -81,6 +83,7 @@ loadDLL str0 = do
   if maybe_errmsg == nullPtr
         then return Nothing
         else do str <- peekCString maybe_errmsg
+                free maybe_errmsg
                 return (Just str)
 
 loadArchive :: String -> IO ()
@@ -108,6 +111,15 @@ addLibrarySearchPath str =
 removeLibrarySearchPath :: Ptr () -> IO Bool
 removeLibrarySearchPath = c_removeLibrarySearchPath
 
+findSystemLibrary :: String -> IO (Maybe String)
+findSystemLibrary str = do
+    result <- withFilePath str c_findSystemLibrary
+    case result == nullPtr of
+        True  -> return Nothing
+        False -> do path <- peekFilePath result
+                    free result
+                    return $ Just path
+
 resolveObjs :: IO SuccessFlag
 resolveObjs = do
    r <- c_resolveObjs
@@ -120,10 +132,11 @@ resolveObjs = do
 foreign import ccall unsafe "addDLL"                  c_addDLL                  :: CFilePath -> IO CString
 foreign import ccall unsafe "initLinker"              initObjLinker             :: IO ()
 foreign import ccall unsafe "insertSymbol"            c_insertSymbol            :: CFilePath -> CString -> Ptr a -> IO ()
-foreign import ccall unsafe "lookupSymbol"            c_lookupSymbol            :: CString -> IO (Ptr a)
+foreign import ccall unsafe "lookupSymbol"            c_lookupSymbol            :: CString   -> IO (Ptr a)
 foreign import ccall unsafe "loadArchive"             c_loadArchive             :: CFilePath -> IO Int
 foreign import ccall unsafe "loadObj"                 c_loadObj                 :: CFilePath -> IO Int
 foreign import ccall unsafe "unloadObj"               c_unloadObj               :: CFilePath -> IO Int
 foreign import ccall unsafe "resolveObjs"             c_resolveObjs             :: IO Int
 foreign import ccall unsafe "addLibrarySearchPath"    c_addLibrarySearchPath    :: CFilePath -> IO (Ptr ())
-foreign import ccall unsafe "removeLibrarySearchPath" c_removeLibrarySearchPath :: Ptr() -> IO Bool
+foreign import ccall unsafe "removeLibrarySearchPath" c_removeLibrarySearchPath :: Ptr ()    -> IO Bool
+foreign import ccall unsafe "findSystemLibrary"       c_findSystemLibrary       :: CFilePath -> IO CFilePath
diff --git a/includes/rts/Linker.h b/includes/rts/Linker.h
index 47a5820bfb..34bf0df741 100644
--- a/includes/rts/Linker.h
+++ b/includes/rts/Linker.h
@@ -77,6 +77,13 @@ HsBool removeLibrarySearchPath(HsPtr dll_path_index);
    the linker work better */
 void warnMissingKBLibraryPaths( void );
 
+/* -----------------------------------------------------------------------------
+* Searches the system directories to determine if there is a system DLL that
+* satisfies the given name. This prevent GHCi from linking against a static
+* library if a DLL is available.
+*/
+pathchar* findSystemLibrary(pathchar* dll_name);
+
 /* called by the initialization code for a module, not a user API */
 StgStablePtr foreignExportStablePtr (StgPtr p);
 
diff --git a/rts/Linker.c b/rts/Linker.c
index 9cab5f228f..51142c57ce 100644
--- a/rts/Linker.c
+++ b/rts/Linker.c
@@ -917,6 +917,43 @@ error:
 #  endif
 }
 
+/* -----------------------------------------------------------------------------
+* Searches the system directories to determine if there is a system DLL that
+* satisfies the given name. This prevent GHCi from linking against a static
+* library if a DLL is available.
+*
+* Returns: NULL on failure or no DLL found, else the full path to the DLL
+*          that can be loaded.
+*/
+pathchar* findSystemLibrary(pathchar* dll_name)
+{
+
+    IF_DEBUG(linker, debugBelch("\nfindSystemLibrary: dll_name = `%" PATH_FMT "'\n", dll_name));
+
+#if defined(OBJFORMAT_PEi386)
+    const unsigned int init_buf_size = 1024;
+    unsigned int bufsize     = init_buf_size;
+    wchar_t* result = malloc(sizeof(wchar_t) * bufsize);
+    DWORD wResult   = SearchPathW(NULL, dll_name, NULL, bufsize, result, NULL);
+
+    if (wResult > bufsize) {
+        result  = realloc(result, sizeof(wchar_t) * wResult);
+        wResult = SearchPathW(NULL, dll_name, NULL, wResult, result, NULL);
+    }
+
+
+    if (!wResult) {
+        free(result);
+        return NULL;
+    }
+
+    return result;
+
+#else
+    (void)(dll_name); // Function not implemented for other platforms.
+    return NULL;
+#endif
+}
 
 /* -----------------------------------------------------------------------------
 * Emits a warning determining that the system is missing a required security
diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c
index 709c5bfca2..bac2fc9ec7 100644
--- a/rts/RtsSymbols.c
+++ b/rts/RtsSymbols.c
@@ -700,6 +700,7 @@
       SymI_HasProto(addDLL)                                             \
       SymI_HasProto(addLibrarySearchPath)                               \
       SymI_HasProto(removeLibrarySearchPath)                            \
+      SymI_HasProto(findSystemLibrary)                                  \
       SymI_HasProto(__int_encodeDouble)                                 \
       SymI_HasProto(__word_encodeDouble)                                \
       SymI_HasProto(__int_encodeFloat)                                  \
diff --git a/testsuite/tests/ghci/linking/dyn/Makefile b/testsuite/tests/ghci/linking/dyn/Makefile
index 8eb4aade15..bc330484e9 100644
--- a/testsuite/tests/ghci/linking/dyn/Makefile
+++ b/testsuite/tests/ghci/linking/dyn/Makefile
@@ -59,4 +59,7 @@ compile_libAB_dyn:
 
 .PHONY: T1407
 T1407:
-	cat T1407.script | LD_LIBRARY_PATH=. "$(TEST_HC)" -ignore-dot-ghci -v0 --interactive -L.
+	cat T1407.script | LD_LIBRARY_PATH=. "$(TEST_HC)" $(TEST_HC_OPTS) -ignore-dot-ghci -v0 --interactive -L.
+
+.PHONY: T3242
+	echo ":q" | '$(TEST_HC)' $(TEST_HC_OPTS) --interactive -ignore-dot-ghci -v0 -lm
diff --git a/testsuite/tests/ghci/linking/dyn/all.T b/testsuite/tests/ghci/linking/dyn/all.T
index abbc569a0f..e5b40d4751 100644
--- a/testsuite/tests/ghci/linking/dyn/all.T
+++ b/testsuite/tests/ghci/linking/dyn/all.T
@@ -11,6 +11,11 @@ test('T1407',
      extra_hc_opts('-L.')],
      run_command, ['$MAKE --no-print-directory -s T1407'])
 
+test('T3242',
+     [unless(doing_ghci, skip), unless(opsys('mingw32'), skip)],
+     run_command,
+     ['$MAKE -s --no-print-directory T3242'])
+
 test('T10955',
      [unless(doing_ghci, skip),unless(opsys('mingw32'), skip),
      extra_clean(['bin_dep/*', 'bin_dep']),