[commit: ghc] master: ghc, ghc-pkg: use getExecutablePath on Windows when base >= 4.11.0 (c523525)
git at git.haskell.org
git at git.haskell.org
Sat Aug 25 10:24:53 UTC 2018
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/c523525b0e434d848f6e47ea3f9a37485965fa79/ghc
>---------------------------------------------------------------
commit c523525b0e434d848f6e47ea3f9a37485965fa79
Author: Tamar Christina <tamar at zhox.com>
Date: Sat Aug 11 19:25:09 2018 +0100
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
>---------------------------------------------------------------
c523525b0e434d848f6e47ea3f9a37485965fa79
compiler/main/SysTools.hs | 6 +++---
compiler/main/SysTools/BaseDir.hs | 26 +++++++++++++++++++++++++-
utils/ghc-pkg/Main.hs | 38 +++++++++++++++++++++++++-------------
3 files changed, 53 insertions(+), 17 deletions(-)
diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs
index ff36c04..9bbce19 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 625baec..f858c8f 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 $
diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 69137eb..3aa4186 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -17,6 +17,24 @@
#endif
#endif
+-- The SIMPLE_WIN_GETLIBDIR macro will only be set when
+-- building on windows.
+--
+-- Its purpose is to let us know whether the Windows implementation of
+-- 'getExecutablePath' follows symlinks or not (it does follow them in
+-- base >= 4.11). If it does, the implementation of getLibDir is straightforward
+-- but if it does not follow symlinks, we need to follow them ourselves here.
+-- Once we do not have to support building ghc-pkg with base < 4.11 anymore,
+-- we can keep only the simple, straightforward implementation that just uses
+-- 'getExecutablePath'.
+#if defined(mingw32_HOST_OS)
+#if MIN_VERSION_base(4,11,0)
+#define SIMPLE_WIN_GETLIBDIR 1
+#else
+#define SIMPLE_WIN_GETLIBDIR 0
+#endif
+#endif
+
-----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 2004-2009.
@@ -66,7 +84,7 @@ import System.Directory ( doesDirectoryExist, getDirectoryContents,
getCurrentDirectory )
import System.Exit ( exitWith, ExitCode(..) )
import System.Environment ( getArgs, getProgName, getEnv )
-#if defined(darwin_HOST_OS) || defined(linux_HOST_OS)
+#if defined(darwin_HOST_OS) || defined(linux_HOST_OS) || SIMPLE_WIN_GETLIBDIR
import System.Environment ( getExecutablePath )
#endif
import System.IO
@@ -80,10 +98,12 @@ import qualified Data.Set as Set
import qualified Data.Map as Map
#if defined(mingw32_HOST_OS)
--- mingw32 needs these for getExecDir
+#if !SIMPLE_WIN_GETLIBDIR
+-- mingw32 needs these for getExecDir when base < 4.11
import Foreign
import Foreign.C
import System.Directory ( canonicalizePath )
+#endif
import GHC.ConsoleHandler
#else
import System.Posix hiding (fdToHandle)
@@ -2194,7 +2214,8 @@ dieForcible s = die (s ++ " (use --force to override)")
-- Cut and pasted from ghc/compiler/main/SysTools
getLibDir :: IO (Maybe String)
-#if defined(mingw32_HOST_OS)
+
+#if defined(mingw32_HOST_OS) && !SIMPLE_WIN_GETLIBDIR
subst :: Char -> Char -> String -> String
subst a b ls = map (\ x -> if x == a then b else x) ls
@@ -2233,16 +2254,7 @@ getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
-#elif defined(darwin_HOST_OS) || defined(linux_HOST_OS)
--- TODO: a) this is copy-pasta from SysTools.hs / getBaseDir. Why can't we reuse
--- this here? and parameterise getBaseDir over the executable (for
--- windows)?
--- Answer: we can not, because if we share `getBaseDir` via `ghc-boot`,
--- that would add `base` as a dependency for windows.
--- b) why is the windows getBaseDir logic, not part of getExecutablePath?
--- it would be much wider available then and we could drop all the
--- custom logic?
--- Answer: yes this should happen. No one has found the time just yet.
+#elif SIMPLE_WIN_GETLIBDIR || defined(darwin_HOST_OS) || defined(linux_HOST_OS)
getLibDir = Just . (\p -> p </> "lib") . takeDirectory . takeDirectory <$> getExecutablePath
#else
getLibDir = return Nothing
More information about the ghc-commits
mailing list