diff options
| -rw-r--r-- | compiler/main/SysTools.hs | 6 | ||||
| -rw-r--r-- | compiler/main/SysTools/BaseDir.hs | 26 | ||||
| -rw-r--r-- | 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 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 $ diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 69137eb4e4..3aa4186db4 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 |