Allow the GHCi Linker to resolve related dependencies when loading DLLs

Summary:
GHCi does not correctly tell the Windows Loader how to handle dependencies to DLL's
that are not on the standard Windows load path:

1. The directory from which the application loaded.
2. The current directory.
3. The system directory. Use the GetSystemDirectory function to get the path of this directory.
4. The 16-bit system directory. There is no function that obtains the path of this directory,
   but it is searched.
5. The Windows directory. Use the GetWindowsDirectory function to get the path of this directory.
6. The directories that are listed in the PATH environment variable.
   Note that this does not include the per-application path specified by the
   AppPaths registry key. The App Paths key is not used when computing the DLL search path.

So what this means is given two DLLs `A` and `B` and `B` depending on `A`.
If we put both DLLs into a new folder bin and then call GHC with:

`ghc -L$(PWD)/bin -lB`

the loading will fail as the Windows loader will try to load the dependency of `B` and fail
since it cannot find `A`.

*IMPORTANT* this patch drops XP Support.
The  APIs being used were natively added to Windows 8+ and backported to Windows 7 and Vista
via a mandatory security patch (in 2011). This means that there is a chance that KB2533623 has
not been installed on certain machines. For those machines I display a warning and
temporarily expand the `PATH` to allow it to load.

This patch will make sure that paths provided by the user with `-L` *and* the folder in which a
DLL is found are added to the search path. It does so using one of two methods depending upon how
new of a Windows version we are running on:

- If the APIs are available it will use `addDllDirectory` and `removeDllDirectory`.
   The order of which these directories are searched is nondeterministic.
- If the APIs are not available it means that we're running on a pretty old unpatched machine.
  But if it's being used in an environment with no internet access it may be the case.
  So if the APIs are not available we temporarily extend the `PATH` with the directories.
  A warning is also displayed to the user informing them that the linking may fail,
  and if it does, install the needed patch. The `PATH` variable has limitations.

Test Plan:
./validate

Added two new test T10955 and T10955dyn

Reviewers: erikd, bgamari, thomie, hvr, austin

Reviewed By: erikd, thomie

Subscribers: #ghc_windows_task_force

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

GHC Trac Issues: #10955

2 files changed, 80 insertions, 53 deletions

diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs
index 9fa89fec5e..13085090ef 100644
--- a/compiler/ghci/Linker.hs
+++ b/compiler/ghci/Linker.hs
@@ -299,39 +299,47 @@ linkCmdLineLibs dflags = do
 linkCmdLineLibs' :: DynFlags -> PersistentLinkerState -> IO PersistentLinkerState
 linkCmdLineLibs' dflags@(DynFlags { ldInputs     = cmdline_ld_inputs
                                   , libraryPaths = lib_paths}) pls =
-  do  {   -- (c) Link libraries from the command-line
-        ; let minus_ls = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ]
-        ; libspecs <- mapM (locateLib dflags False lib_paths) minus_ls
-
-          -- (d) Link .o files from the command-line
-        ; classified_ld_inputs <- mapM (classifyLdInput dflags)
-                                    [ f | FileOption _ f <- cmdline_ld_inputs ]
-
-          -- (e) Link any MacOS frameworks
-        ; let platform = targetPlatform dflags
-        ; let (framework_paths, frameworks) =
-                if platformUsesFrameworks platform
-                 then (frameworkPaths dflags, cmdlineFrameworks dflags)
-                  else ([],[])
-
-          -- Finally do (c),(d),(e)
-        ; let cmdline_lib_specs = catMaybes classified_ld_inputs
-                               ++ libspecs
-                               ++ map Framework frameworks
-        ; if null cmdline_lib_specs then return pls
-                                    else do
-
-        { pls1 <- foldM (preloadLib dflags lib_paths framework_paths) pls
-                        cmdline_lib_specs
-        ; maybePutStr dflags "final link ... "
-        ; ok <- resolveObjs
-
-        ; if succeeded ok then maybePutStrLn dflags "done"
-          else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed")
-
-        ; return pls1
-        }}
-
+  do  -- (c) Link libraries from the command-line
+      let minus_ls = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ]
+      libspecs <- mapM (locateLib dflags False lib_paths) minus_ls
+
+      -- (d) Link .o files from the command-line
+      classified_ld_inputs <- mapM (classifyLdInput dflags)
+                                [ f | FileOption _ f <- cmdline_ld_inputs ]
+
+      -- (e) Link any MacOS frameworks
+      let platform = targetPlatform dflags
+      let (framework_paths, frameworks) =
+            if platformUsesFrameworks platform
+             then (frameworkPaths dflags, cmdlineFrameworks dflags)
+              else ([],[])
+
+      -- Finally do (c),(d),(e)
+      let cmdline_lib_specs = catMaybes classified_ld_inputs
+                           ++ libspecs
+                           ++ map Framework frameworks
+      if null cmdline_lib_specs then return pls
+                                else do
+
+      -- Add directories to library search paths
+      let all_paths = let paths = framework_paths
+                               ++ lib_paths
+                               ++ [ takeDirectory dll | DLLPath dll <- libspecs ]
+                      in nub $ map normalise paths
+      pathCache <- mapM addLibrarySearchPath all_paths
+
+      pls1 <- foldM (preloadLib dflags lib_paths framework_paths) pls
+                    cmdline_lib_specs
+      maybePutStr dflags "final link ... "
+      ok <- resolveObjs
+
+      -- DLLs are loaded, reset the search paths
+      mapM_ removeLibrarySearchPath $ reverse pathCache
+
+      if succeeded ok then maybePutStrLn dflags "done"
+      else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed")
+
+      return pls1
 
 {- Note [preload packages]
 
@@ -1021,7 +1029,7 @@ data LibrarySpec
 
    | DLL String         -- "Unadorned" name of a .DLL/.so
                         --  e.g.    On unix     "qt"  denotes "libqt.so"
-                        --          On WinDoze  "burble"  denotes "burble.DLL"
+                        --          On Windows  "burble"  denotes "burble.DLL" or "libburble.dll"
                         --  loadDLL is platform-specific and adds the lib/.so/.DLL
                         --  suffixes platform-dependently
 
@@ -1115,7 +1123,7 @@ linkPackage dflags pkg
         -- Because of slight differences between the GHC dynamic linker and
         -- the native system linker some packages have to link with a
         -- different list of libraries when using GHCi. Examples include: libs
-        -- that are actually gnu ld scripts, and the possability that the .a
+        -- that are actually gnu ld scripts, and the possibility that the .a
         -- libs do not exactly match the .so/.dll equivalents. So if the
         -- package file provides an "extra-ghci-libraries" field then we use
         -- that instead of the "extra-libraries" field.
@@ -1135,6 +1143,11 @@ linkPackage dflags pkg
             objs       = [ obj  | Object obj     <- classifieds ]
             archs      = [ arch | Archive arch   <- classifieds ]
 
+        -- Add directories to library search paths
+        let dll_paths  = map takeDirectory known_dlls
+            all_paths  = nub $ map normalise $ dll_paths ++ dirs
+        pathCache <- mapM addLibrarySearchPath all_paths
+
         maybePutStr dflags
             ("Loading package " ++ sourcePackageIdString pkg ++ " ... ")
 
@@ -1143,6 +1156,9 @@ linkPackage dflags pkg
             loadFrameworks platform pkg
             mapM_ load_dyn (known_dlls ++ map (mkSOName platform) dlls)
 
+        -- DLLs are loaded, reset the search paths
+        mapM_ removeLibrarySearchPath $ reverse pathCache
+
         -- After loading all the DLLs, we can load the static objects.
         -- Ordering isn't important here, because we do one final link
         -- step to resolve everything.
diff --git a/compiler/ghci/ObjLink.hs b/compiler/ghci/ObjLink.hs
index c9cf78cc4d..d5d4980387 100644
--- a/compiler/ghci/ObjLink.hs
+++ b/compiler/ghci/ObjLink.hs
@@ -9,14 +9,16 @@
 -- | 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
+   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
   )  where
 
 import Panic
@@ -29,7 +31,7 @@ import Foreign.C
 import Foreign          ( nullPtr )
 import GHC.Exts         ( Ptr(..) )
 import System.Posix.Internals ( CFilePath, withFilePath )
-import System.FilePath  ( dropExtension )
+import System.FilePath  ( dropExtension, normalise )
 
 
 -- ---------------------------------------------------------------------------
@@ -75,7 +77,7 @@ loadDLL str0 = do
      str | isWindowsHost = dropExtension str0
          | otherwise     = str0
   --
-  maybe_errmsg <- withFilePath str $ \dll -> c_addDLL dll
+  maybe_errmsg <- withFilePath (normalise str) $ \dll -> c_addDLL dll
   if maybe_errmsg == nullPtr
         then return Nothing
         else do str <- peekCString maybe_errmsg
@@ -99,6 +101,13 @@ unloadObj str =
      r <- c_unloadObj c_str
      when (r == 0) (panic ("unloadObj " ++ show str ++ ": failed"))
 
+addLibrarySearchPath :: String -> IO (Ptr ())
+addLibrarySearchPath str =
+   withFilePath str c_addLibrarySearchPath
+
+removeLibrarySearchPath :: Ptr () -> IO Bool
+removeLibrarySearchPath = c_removeLibrarySearchPath
+
 resolveObjs :: IO SuccessFlag
 resolveObjs = do
    r <- c_resolveObjs
@@ -108,11 +117,13 @@ 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 "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 "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 "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 "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