[commit: ghc] master: Correct Windows libdir assumptions. (8d64395)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/8d64395b43cb73d110767cab512a368b3db018de/ghc

>---------------------------------------------------------------

commit 8d64395b43cb73d110767cab512a368b3db018de
Author: Tamar Christina <tamar at zhox.com>
Date:   Thu Feb 23 18:07:19 2017 -0500

    Correct Windows libdir assumptions.
    
    GHC and ghc-pkg make some pretty hard assumptions about where they're
    running on Windows. They assume that they are always running from
    `foo/bin/ghc.exe` and that to find the `lib` folder they can drop
    `bin/ghc.exe` from the base path and append `lib`.
    
    This is already false for the testsuite, which when testing thenbindist
     has one test which puts the binaries in `inplace/test   spaces`.
    
    For some reason before this was either being skipped or mysteriously
    passing.
    But as of `2017.02.11` our luck ran out.
    
    the testsuite triggers a failure such as those in #13310
    
    Let's soften the assumption and just check that `../lib` exists instead.
    
    80 chars
    
    Test Plan: ./validate
    
    Reviewers: austin, erikd, bgamari
    
    Reviewed By: bgamari
    
    Subscribers: thomie, #ghc_windows_task_force
    
    Differential Revision: https://phabricator.haskell.org/D3158


>---------------------------------------------------------------

8d64395b43cb73d110767cab512a368b3db018de
 compiler/main/SysTools.hs | 30 ++++++++++++++++--------------
 utils/ghc-pkg/Main.hs     | 14 ++++++++++----
 2 files changed, 26 insertions(+), 18 deletions(-)

diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs
index b34b1b8..9a9f899 100644
--- a/compiler/main/SysTools.hs
+++ b/compiler/main/SysTools.hs
@@ -91,13 +91,10 @@ import qualified System.Win32.Types as Win32
 #else
 import qualified System.Win32.Info as Win32
 #endif
-import Control.Exception (finally)
-import Foreign.Ptr (FunPtr, castPtrToFunPtr)
 import System.Win32.Types (DWORD, LPTSTR, HANDLE)
 import System.Win32.Types (failIfNull, failIf, iNVALID_HANDLE_VALUE)
 import System.Win32.File (createFile,closeHandle, gENERIC_READ, fILE_SHARE_READ, oPEN_EXISTING, fILE_ATTRIBUTE_NORMAL, fILE_FLAG_BACKUP_SEMANTICS )
 import System.Win32.DLL (loadLibrary, getProcAddress)
-import Data.Bits((.|.))
 #endif
 
 import System.Process
@@ -131,9 +128,9 @@ On Unix:
 On Windows:
   - ghc never has a shell wrapper.
   - we can find the location of the ghc binary, which is
-        $topdir/bin/<something>.exe
+        $topdir/<foo>/<something>.exe
     where <something> may be "ghc", "ghc-stage2", or similar
-  - we strip off the "bin/<something>.exe" to leave $topdir.
+  - we strip off the "<foo>/<something>.exe" to leave $topdir.
 
 from topdir we can find package.conf, ghc-asm, etc.
 
@@ -1463,7 +1460,7 @@ traceCmd dflags phase_name cmd_line action
 
 getBaseDir :: IO (Maybe String)
 #if defined(mingw32_HOST_OS)
--- Assuming we are running ghc, accessed by path  $(stuff)/bin/ghc.exe,
+-- Assuming we are running ghc, accessed by path  $(stuff)/<foo>/ghc.exe,
 -- return the path $(stuff)/lib.
 getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
   where
@@ -1471,9 +1468,14 @@ getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
         ret <- c_GetModuleFileName nullPtr buf size
         case ret of
           0 -> return Nothing
-          _ | ret < size -> do path <- peekCWString buf
-                               real <- getFinalPath path -- try to resolve symlinks paths
-                               return $ (Just . rootDir . sanitize . maybe path id) real
+          _ | ret < size -> do
+                path <- peekCWString buf
+                real <- getFinalPath path -- try to resolve symlinks paths
+                let libdir = (rootDir . sanitize . maybe path id) real
+                exists <- doesDirectoryExist libdir
+                if exists
+                   then return $ Just libdir
+                   else fail path
             | otherwise  -> try_size (size * 2)
 
     -- getFinalPath returns paths in full raw form.
@@ -1492,11 +1494,11 @@ getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
                                          "ghc-stage3.exe"] ->
                     case splitFileName $ takeDirectory d of
                     -- ghc is in $topdir/bin/ghc.exe
-                    (d', bin) | lower bin == "bin" -> takeDirectory d' </> "lib"
-                    _ -> fail
-                _ -> fail
-        where fail = panic ("can't decompose ghc.exe path: " ++ show s)
-              lower = map toLower
+                    (d', _) -> takeDirectory d' </> "lib"
+                _ -> fail s
+
+    fail s = panic ("can't decompose ghc.exe path: " ++ show s)
+    lower = map toLower
 
 foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
   c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index b350e08..3355838 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -62,9 +62,7 @@ import qualified Data.ByteString.Char8 as BS
 -- mingw32 needs these for getExecDir
 import Foreign
 import Foreign.C
-#endif
-
-#ifdef mingw32_HOST_OS
+import System.Directory ( canonicalizePath )
 import GHC.ConsoleHandler
 #else
 import System.Posix hiding (fdToHandle)
@@ -1947,7 +1945,15 @@ unDosifyPath :: FilePath -> FilePath
 unDosifyPath xs = subst '\\' '/' xs
 
 getLibDir :: IO (Maybe String)
-getLibDir = fmap (fmap (</> "lib")) $ getExecDir "/bin/ghc-pkg.exe"
+getLibDir = do base   <- getExecDir "/ghc-pkg.exe"
+               case base of
+                 Nothing    -> return Nothing
+                 Just base' -> do
+                    libdir <- canonicalizePath $ base' </> "../lib"
+                    exists <- doesDirectoryExist libdir
+                    if exists
+                       then return $ Just libdir
+                       else return Nothing
 
 -- (getExecDir cmd) returns the directory in which the current
 --                  executable, which should be called 'cmd', is running