ghc, ghc-pkg: use getExecutablePath on Windows when base >= 4.11.0

Summary:
This completes the work started in D4227 by using just 'getExecutablePath'
in ghc and ghc-pkg when building with base >= 4.11.0.

On the long term, we will be able to simply kill the existing code that
follows (or not) symlinks and just get this behaviour for free from
getExecutable. For now we however have to require base >= 4.11.0 to be able
to just use getExecutablePath under Windows, and use the current code when
building with an older base.

Original code by @alpmestan commandeering since patch has been stale
and bug remains open.

Test Plan: Validate

Reviewers: angerman, bgamari, erikd, alpmestan

Reviewed By: bgamari

Subscribers: carter, rwbarton, thomie

GHC Trac Issues: #14483

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

2 files changed, 28 insertions, 4 deletions

diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs
index ff36c04ecf..9bbce19602 100644
--- a/compiler/main/SysTools.hs
+++ b/compiler/main/SysTools.hs
@@ -141,12 +141,12 @@ initSysTools top_dir
        mtool_dir <- findToolDir top_dir
              -- see Note [tooldir: How GHC finds mingw and perl on Windows]
 
-       let settingsFile = top_dir </> "settings"
-           platformConstantsFile = top_dir </> "platformConstants"
-           installed :: FilePath -> FilePath
+       let installed :: FilePath -> FilePath
            installed file = top_dir </> file
            libexec :: FilePath -> FilePath
            libexec file = top_dir </> "bin" </> file
+           settingsFile = installed "settings"
+           platformConstantsFile = installed "platformConstants"
 
        settingsStr <- readFile settingsFile
        platformConstantsStr <- readFile platformConstantsFile
diff --git a/compiler/main/SysTools/BaseDir.hs b/compiler/main/SysTools/BaseDir.hs
index 625baec8d9..f858c8ffad 100644
--- a/compiler/main/SysTools/BaseDir.hs
+++ b/compiler/main/SysTools/BaseDir.hs
@@ -33,7 +33,18 @@ import System.Environment (getExecutablePath)
 
 -- Windows
 #if defined(mingw32_HOST_OS)
+#  if MIN_VERSION_Win32(2,5,0)
+#    if !MIN_VERSION_base(4,11,0)
 import qualified System.Win32.Types as Win32
+#    endif
+#  else
+import qualified System.Win32.Info as Win32
+#  endif
+#  if MIN_VERSION_base(4,11,0)
+import System.Environment (getExecutablePath)
+import System.Directory (doesDirectoryExist)
+#  else
+import Data.Char
 import Exception
 import Foreign
 import Foreign.C.String
@@ -42,6 +53,7 @@ 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)
+#  endif
 #endif
 
 #if defined(mingw32_HOST_OS)
@@ -133,7 +145,18 @@ findTopDir Nothing
                      Just dir -> return dir
 
 getBaseDir :: IO (Maybe String)
+
 #if defined(mingw32_HOST_OS)
+
+-- locate the "base dir" when given the path
+-- to the real ghc executable (as opposed to symlink)
+-- that is running this function.
+rootDir :: FilePath -> FilePath
+rootDir = takeDirectory . takeDirectory . normalise
+
+#if MIN_VERSION_base(4,11,0)
+getBaseDir = Just . (\p -> p </> "lib") . rootDir <$> getExecutablePath
+#else
 -- 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.
@@ -209,6 +232,7 @@ type GetFinalPath = HANDLE -> LPTSTR -> DWORD -> DWORD -> IO DWORD
 
 foreign import WINDOWS_CCONV unsafe "dynamic"
   makeGetFinalPathNameByHandle :: FunPtr GetFinalPath -> GetFinalPath
+#endif
 #elif defined(darwin_HOST_OS) || defined(linux_HOST_OS)
 -- on unix, this is a bit more confusing.
 -- The layout right now is something like
@@ -242,7 +266,7 @@ findToolDir
   -> IO (Maybe FilePath)
 #if defined(mingw32_HOST_OS)
 findToolDir top_dir = go 0 (top_dir </> "..")
-  where maxDepth = 2
+  where maxDepth = 3
         go :: Int -> FilePath -> IO (Maybe FilePath)
         go k path
           | k == maxDepth = throwGhcExceptionIO $