Introduce a $tooldir variable for nicer toolchain detection on Windows

Summary:
This patch affects several files that affect how we detect mingw and perl
on Windows. The initial motivation is:

    https://github.com/snowleopard/hadrian/issues/564

where, with Hadrian building relocatable (non-inplace) GHCs, the current
detection mechanism falls short by e.g only trying $topdir/../mingw. But
in Hadrian, for reasons given in that issue, we would need to store e.g mingw
under $topdir/../../mingw except for binary distributions, where we want
to follow the existing structure, in which case $topdir/../mingw is correct. So
we need to support both, which is what this patch hopefully implements.

Test Plan: ./validate

Reviewers: Phyx, hvr, bgamari, erikd

Reviewed By: Phyx

Subscribers: snowleopard, thomie, carter

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

2 files changed, 72 insertions, 16 deletions

diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs
index 35935cacb0..baf70df8a9 100644
--- a/compiler/main/SysTools.hs
+++ b/compiler/main/SysTools.hs
@@ -134,6 +134,8 @@ initSysTools mbMinusB
              -- see Note [topdir: How GHC finds its files]
              -- NB: top_dir is assumed to be in standard Unix
              -- format, '/' separated
+       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"
@@ -158,6 +160,7 @@ initSysTools mbMinusB
        let getSetting key = case lookup key mySettings of
                             Just xs -> return $ expandTopDir top_dir xs
                             Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
+           getToolSetting key = expandToolDir mtool_dir <$> getSetting key
            getBooleanSetting key = case lookup key mySettings of
                                    Just "YES" -> return True
                                    Just "NO" -> return False
@@ -179,14 +182,15 @@ initSysTools mbMinusB
        targetHasSubsectionsViaSymbols <- readSetting "target has subsections via symbols"
        myExtraGccViaCFlags <- getSetting "GCC extra via C opts"
        -- On Windows, mingw is distributed with GHC,
-       -- so we look in TopDir/../mingw/bin
+       -- so we look in TopDir/../mingw/bin,
+       -- as well as TopDir/../../mingw/bin for hadrian.
        -- It would perhaps be nice to be able to override this
        -- with the settings file, but it would be a little fiddly
        -- to make that possible, so for now you can't.
-       gcc_prog <- getSetting "C compiler command"
+       gcc_prog <- getToolSetting "C compiler command"
        gcc_args_str <- getSetting "C compiler flags"
        gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie"
-       cpp_prog <- getSetting "Haskell CPP command"
+       cpp_prog <- getToolSetting "Haskell CPP command"
        cpp_args_str <- getSetting "Haskell CPP flags"
        let unreg_gcc_args = if targetUnregisterised
                             then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]
@@ -204,7 +208,7 @@ initSysTools mbMinusB
        ldSupportsBuildId       <- getBooleanSetting "ld supports build-id"
        ldSupportsFilelist      <- getBooleanSetting "ld supports filelist"
        ldIsGnuLd               <- getBooleanSetting "ld is GNU ld"
-       perl_path <- getSetting "perl command"
+       perl_path <- getToolSetting "perl command"
 
        let pkgconfig_path = installed "package.conf.d"
            ghc_usage_msg_path  = installed "ghc-usage.txt"
@@ -217,14 +221,14 @@ initSysTools mbMinusB
              -- split is a Perl script
            split_script  = libexec cGHC_SPLIT_PGM
 
-       windres_path <- getSetting "windres command"
-       libtool_path <- getSetting "libtool command"
-       ar_path <- getSetting "ar command"
-       ranlib_path <- getSetting "ranlib command"
+       windres_path <- getToolSetting "windres command"
+       libtool_path <- getToolSetting "libtool command"
+       ar_path <- getToolSetting "ar command"
+       ranlib_path <- getToolSetting "ranlib command"
 
        tmpdir <- getTemporaryDirectory
 
-       touch_path <- getSetting "touch command"
+       touch_path <- getToolSetting "touch command"
 
        let -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
            -- a call to Perl to get the invocation of split.
@@ -235,7 +239,7 @@ initSysTools mbMinusB
            (split_prog,  split_args)
              | isWindowsHost = (perl_path,    [Option split_script])
              | otherwise     = (split_script, [])
-       mkdll_prog <- getSetting "dllwrap command"
+       mkdll_prog <- getToolSetting "dllwrap command"
        let mkdll_args = []
 
        -- cpp is derived from gcc on all platforms
diff --git a/compiler/main/SysTools/BaseDir.hs b/compiler/main/SysTools/BaseDir.hs
index c707dac7e7..7cd1998da8 100644
--- a/compiler/main/SysTools/BaseDir.hs
+++ b/compiler/main/SysTools/BaseDir.hs
@@ -11,7 +11,10 @@
 -----------------------------------------------------------------------------
 -}
 
-module SysTools.BaseDir (expandTopDir, findTopDir) where
+module SysTools.BaseDir
+  ( expandTopDir, expandToolDir
+  , findTopDir, findToolDir
+  ) where
 
 #include "HsVersions.h"
 
@@ -70,16 +73,42 @@ On Windows:
 
 from topdir we can find package.conf, ghc-asm, etc.
 
+
+Note [tooldir: How GHC finds mingw and perl on Windows]
+
+GHC has some custom logic on Windows for finding the mingw
+toolchain and perl. Depending on whether GHC is built
+with the make build system or Hadrian, and on whether we're
+running a bindist, we might find the mingw toolchain and perl
+either under $topdir/../{mingw, perl}/ or
+$topdir/../../{mingw, perl}/.
+
 -}
 
 -- | Expand occurrences of the @$topdir@ interpolation in a string.
 expandTopDir :: FilePath -> String -> String
-expandTopDir top_dir str
-  | Just str' <- stripPrefix "$topdir" str
+expandTopDir = expandPathVar "topdir"
+
+-- | Expand occurrences of the @$tooldir@ interpolation in a string
+-- on Windows, leave the string untouched otherwise.
+expandToolDir :: Maybe FilePath -> String -> String
+#if defined(mingw32_HOST_OS)
+expandToolDir (Just tool_dir) s = expandPathVar "tooldir" tool_dir s
+expandToolDir Nothing         _ = panic "Could not determine $tooldir"
+#else
+expandToolDir _ s = s
+#endif
+
+-- | @expandPathVar var value str@
+--
+--   replaces occurences of variable @$var@ with @value@ in str.
+expandPathVar :: String -> FilePath -> String -> String
+expandPathVar var value str
+  | Just str' <- stripPrefix ('$':var) str
   , null str' || isPathSeparator (head str')
-  = top_dir ++ expandTopDir top_dir str'
-expandTopDir top_dir (x:xs) = x : expandTopDir top_dir xs
-expandTopDir _ [] = []
+  = value ++ expandPathVar var value str'
+expandPathVar var value (x:xs) = x : expandPathVar var value xs
+expandPathVar _ _ [] = []
 
 -- | Returns a Unix-format path pointing to TopDir.
 findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix).
@@ -193,3 +222,26 @@ getBaseDir = Just . (\p -> p </> "lib") . takeDirectory . takeDirectory <$> getE
 #else
 getBaseDir = return Nothing
 #endif
+
+-- See Note [tooldir: How GHC finds mingw and perl on Windows]
+-- Returns @Nothing@ when not on Windows.
+-- When called on Windows, it either throws an error when the
+-- tooldir can't be located, or returns @Just tooldirpath@.
+findToolDir
+  :: FilePath -- ^ topdir
+  -> IO (Maybe FilePath)
+#if defined(mingw32_HOST_OS)
+findToolDir top_dir = go 0 (top_dir </> "..")
+  where maxDepth = 2
+        go :: Int -> FilePath -> IO (Maybe FilePath)
+        go k path
+          | k == maxDepth = throwGhcExceptionIO $
+              InstallationError "could not detect mingw toolchain"
+          | otherwise = do
+              oneLevel <- doesDirectoryExist (path </> "mingw")
+              if oneLevel
+                then return (Just path)
+                else go (k+1) (path </> "..")
+#else
+findToolDir _ = return Nothing
+#endif