diff options
| -rw-r--r-- | compiler/ghc.cabal.in | 1 | ||||
| -rw-r--r-- | compiler/main/SysTools.hs | 187 | ||||
| -rw-r--r-- | compiler/main/SysTools/BaseDir.hs | 208 |
3 files changed, 212 insertions, 184 deletions
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 3b99db10b0..1e3447b49f 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -366,6 +366,7 @@ Library PprTyThing StaticPtrTable SysTools + SysTools.BaseDir SysTools.Terminal SysTools.ExtraObj SysTools.Info diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs index 599ab2059f..dbc97a97de 100644 --- a/compiler/main/SysTools.hs +++ b/compiler/main/SysTools.hs @@ -45,69 +45,21 @@ import Packages import Config import Outputable import ErrUtils -import Panic import Platform import Util import DynFlags -#if defined(darwin_HOST_OS) || defined(linux_HOST_OS) -import System.Environment (getExecutablePath) -#endif - import System.FilePath import System.IO import System.Directory import SysTools.ExtraObj import SysTools.Info import SysTools.Tasks -import Data.List - -#if defined(mingw32_HOST_OS) -#if MIN_VERSION_Win32(2,5,0) -import qualified System.Win32.Types as Win32 -#else -import qualified System.Win32.Info as Win32 -#endif -import Data.Char -import Exception -import Foreign -import Foreign.C.String -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 - -#if defined(mingw32_HOST_OS) -# if defined(i386_HOST_ARCH) -# define WINDOWS_CCONV stdcall -# elif defined(x86_64_HOST_ARCH) -# define WINDOWS_CCONV ccall -# else -# error Unknown mingw32 arch -# endif -#endif +import SysTools.BaseDir {- -Note [topdir: How GHC finds its files] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -GHC needs various support files (library packages, RTS etc), plus -various auxiliary programs (cp, gcc, etc). It starts by finding topdir, -the root of GHC's support files - -On Unix: - - ghc always has a shell wrapper that passes a -B<dir> option - -On Windows: - - ghc never has a shell wrapper. - - we can find the location of the ghc binary, which is - $topdir/<foo>/<something>.exe - where <something> may be "ghc", "ghc-stage2", or similar - - we strip off the "<foo>/<something>.exe" to leave $topdir. - -from topdir we can find package.conf, ghc-asm, etc. - +Note [How GHC finds toolchain utilities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ SysTools.initSysProgs figures out exactly where all the auxiliary programs are, and initialises mutable variables to make it easy to call them. @@ -127,7 +79,6 @@ Config.hs contains two sorts of things for use when running *in-place* in a build tree (only) - --------------------------------------------- NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented): @@ -363,26 +314,6 @@ initSysTools mbMinusB sPlatformConstants = platformConstants } --- | Expand occurrences of the @$topdir@ interpolation in a string. -expandTopDir :: FilePath -> String -> String -expandTopDir top_dir str - | Just str' <- stripPrefix "$topdir" str - , null str' || isPathSeparator (head str') - = top_dir ++ expandTopDir top_dir str' -expandTopDir top_dir (x:xs) = x : expandTopDir top_dir xs -expandTopDir _ [] = [] - --- returns a Unix-format path (relying on getBaseDir to do so too) -findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix). - -> IO String -- TopDir (in Unix format '/' separated) -findTopDir (Just minusb) = return (normalise minusb) -findTopDir Nothing - = do -- Get directory of executable - maybe_exec_dir <- getBaseDir - case maybe_exec_dir of - -- "Just" on Windows, "Nothing" on unix - Nothing -> throwGhcExceptionIO (InstallationError "missing -B<dir> option") - Just dir -> return dir {- Note [Windows stack usage] @@ -447,118 +378,6 @@ copyWithHeader dflags purpose maybe_header from to = do ************************************************************************ -} ------------------------------------------------------------------------------ --- Define getBaseDir :: IO (Maybe String) - -getBaseDir :: IO (Maybe String) -#if defined(mingw32_HOST_OS) --- 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 - try_size size = allocaArray (fromIntegral size) $ \buf -> do - 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 - 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. - -- Unfortunately GHC isn't set up to handle these - -- So if the call succeeded, we need to drop the - -- \\?\ prefix. - sanitize s = if "\\\\?\\" `isPrefixOf` s - then drop 4 s - else s - - rootDir s = case splitFileName $ normalise s of - (d, ghc_exe) - | lower ghc_exe `elem` ["ghc.exe", - "ghc-stage1.exe", - "ghc-stage2.exe", - "ghc-stage3.exe"] -> - case splitFileName $ takeDirectory d of - -- ghc is in $topdir/bin/ghc.exe - (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 - --- Attempt to resolve symlinks in order to find the actual location GHC --- is located at. See Trac #11759. -getFinalPath :: FilePath -> IO (Maybe FilePath) -getFinalPath name = do - dllHwnd <- failIfNull "LoadLibrary" $ loadLibrary "kernel32.dll" - -- Note: The API GetFinalPathNameByHandleW is only available starting from Windows Vista. - -- This means that we can't bind directly to it since it may be missing. - -- Instead try to find it's address at runtime and if we don't succeed consider the - -- function failed. - addr_m <- (fmap Just $ failIfNull "getProcAddress" $ getProcAddress dllHwnd "GetFinalPathNameByHandleW") - `catch` (\(_ :: SomeException) -> return Nothing) - case addr_m of - Nothing -> return Nothing - Just addr -> do handle <- failIf (==iNVALID_HANDLE_VALUE) "CreateFile" - $ createFile name - gENERIC_READ - fILE_SHARE_READ - Nothing - oPEN_EXISTING - (fILE_ATTRIBUTE_NORMAL .|. fILE_FLAG_BACKUP_SEMANTICS) - Nothing - let fnPtr = makeGetFinalPathNameByHandle $ castPtrToFunPtr addr - -- First try to resolve the path to get the actual path - -- of any symlinks or other file system redirections that - -- may be in place. However this function can fail, and in - -- the event it does fail, we need to try using the - -- original path and see if we can decompose that. - -- If the call fails Win32.try will raise an exception - -- that needs to be caught. See #14159 - path <- (Win32.try "GetFinalPathName" - (\buf len -> fnPtr handle buf len 0) 512 - `finally` closeHandle handle) - `catch` - (\(_ :: IOException) -> return name) - return $ Just path - -type GetFinalPath = HANDLE -> LPTSTR -> DWORD -> DWORD -> IO DWORD - -foreign import WINDOWS_CCONV unsafe "dynamic" - makeGetFinalPathNameByHandle :: FunPtr GetFinalPath -> GetFinalPath -#elif defined(darwin_HOST_OS) || defined(linux_HOST_OS) --- on unix, this is a bit more confusing. --- The layout right now is somehting like --- --- /bin/ghc-X.Y.Z <- wrapper script (1) --- /bin/ghc <- symlink to wrapper script (2) --- /lib/ghc-X.Y.Z/bin/ghc <- ghc executable (3) --- /lib/ghc-X.Y.Z <- $topdir (4) --- --- As such, we first need to find the absolute location to the --- binary. --- --- getExecutablePath will return (3). One takeDirectory will --- give use /lib/ghc-X.Y.Z/bin, and another will give us (4). --- --- This of course only works due to the current layout. If --- the layout is changed, such that we have ghc-X.Y.Z/{bin,lib} --- this would need to be changed accordingly. --- -getBaseDir = Just . (\p -> p </> "lib") . takeDirectory . takeDirectory <$> getExecutablePath -#else -getBaseDir = return Nothing -#endif - linkDynLib :: DynFlags -> [String] -> [InstalledUnitId] -> IO () linkDynLib dflags0 o_files dep_packages = do diff --git a/compiler/main/SysTools/BaseDir.hs b/compiler/main/SysTools/BaseDir.hs new file mode 100644 index 0000000000..343be82c0b --- /dev/null +++ b/compiler/main/SysTools/BaseDir.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- +----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2001-2017 +-- +-- Finding the compiler's base directory. +-- +----------------------------------------------------------------------------- +-} + +module SysTools.BaseDir (expandTopDir, findTopDir) where + +#include "HsVersions.h" + +import GhcPrelude + +import Panic + +import System.FilePath +import Data.List + +-- POSIX +#if defined(darwin_HOST_OS) || defined(linux_HOST_OS) +import System.Environment (getExecutablePath) +#endif + +-- Windows +#if defined(mingw32_HOST_OS) +#if MIN_VERSION_Win32(2,5,0) +import qualified System.Win32.Types as Win32 +#else +import qualified System.Win32.Info as Win32 +#endif +import Data.Char +import Exception +import Foreign +import Foreign.C.String +import System.Directory +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 + +#if defined(mingw32_HOST_OS) +# if defined(i386_HOST_ARCH) +# define WINDOWS_CCONV stdcall +# elif defined(x86_64_HOST_ARCH) +# define WINDOWS_CCONV ccall +# else +# error Unknown mingw32 arch +# endif +#endif + +{- +Note [topdir: How GHC finds its files] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +GHC needs various support files (library packages, RTS etc), plus +various auxiliary programs (cp, gcc, etc). It starts by finding topdir, +the root of GHC's support files + +On Unix: + - ghc always has a shell wrapper that passes a -B<dir> option + +On Windows: + - ghc never has a shell wrapper. + - we can find the location of the ghc binary, which is + $topdir/<foo>/<something>.exe + where <something> may be "ghc", "ghc-stage2", or similar + - we strip off the "<foo>/<something>.exe" to leave $topdir. + +from topdir we can find package.conf, ghc-asm, etc. + +-} + +-- | Expand occurrences of the @$topdir@ interpolation in a string. +expandTopDir :: FilePath -> String -> String +expandTopDir top_dir str + | Just str' <- stripPrefix "$topdir" str + , null str' || isPathSeparator (head str') + = top_dir ++ expandTopDir top_dir str' +expandTopDir top_dir (x:xs) = x : expandTopDir top_dir xs +expandTopDir _ [] = [] + +-- | Returns a Unix-format path pointing to TopDir. +findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix). + -> IO String -- TopDir (in Unix format '/' separated) +findTopDir (Just minusb) = return (normalise minusb) +findTopDir Nothing + = do -- Get directory of executable + maybe_exec_dir <- getBaseDir + case maybe_exec_dir of + -- "Just" on Windows, "Nothing" on unix + Nothing -> throwGhcExceptionIO (InstallationError "missing -B<dir> option") + Just dir -> return dir + +getBaseDir :: IO (Maybe String) +#if defined(mingw32_HOST_OS) +-- 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 + try_size size = allocaArray (fromIntegral size) $ \buf -> do + 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 + 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. + -- Unfortunately GHC isn't set up to handle these + -- So if the call succeeded, we need to drop the + -- \\?\ prefix. + sanitize s = if "\\\\?\\" `isPrefixOf` s + then drop 4 s + else s + + rootDir s = case splitFileName $ normalise s of + (d, ghc_exe) + | lower ghc_exe `elem` ["ghc.exe", + "ghc-stage1.exe", + "ghc-stage2.exe", + "ghc-stage3.exe"] -> + case splitFileName $ takeDirectory d of + -- ghc is in $topdir/bin/ghc.exe + (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 + +-- Attempt to resolve symlinks in order to find the actual location GHC +-- is located at. See Trac #11759. +getFinalPath :: FilePath -> IO (Maybe FilePath) +getFinalPath name = do + dllHwnd <- failIfNull "LoadLibrary" $ loadLibrary "kernel32.dll" + -- Note: The API GetFinalPathNameByHandleW is only available starting from Windows Vista. + -- This means that we can't bind directly to it since it may be missing. + -- Instead try to find it's address at runtime and if we don't succeed consider the + -- function failed. + addr_m <- (fmap Just $ failIfNull "getProcAddress" $ getProcAddress dllHwnd "GetFinalPathNameByHandleW") + `catch` (\(_ :: SomeException) -> return Nothing) + case addr_m of + Nothing -> return Nothing + Just addr -> do handle <- failIf (==iNVALID_HANDLE_VALUE) "CreateFile" + $ createFile name + gENERIC_READ + fILE_SHARE_READ + Nothing + oPEN_EXISTING + (fILE_ATTRIBUTE_NORMAL .|. fILE_FLAG_BACKUP_SEMANTICS) + Nothing + let fnPtr = makeGetFinalPathNameByHandle $ castPtrToFunPtr addr + -- First try to resolve the path to get the actual path + -- of any symlinks or other file system redirections that + -- may be in place. However this function can fail, and in + -- the event it does fail, we need to try using the + -- original path and see if we can decompose that. + -- If the call fails Win32.try will raise an exception + -- that needs to be caught. See #14159 + path <- (Win32.try "GetFinalPathName" + (\buf len -> fnPtr handle buf len 0) 512 + `finally` closeHandle handle) + `catch` + (\(_ :: IOException) -> return name) + return $ Just path + +type GetFinalPath = HANDLE -> LPTSTR -> DWORD -> DWORD -> IO DWORD + +foreign import WINDOWS_CCONV unsafe "dynamic" + makeGetFinalPathNameByHandle :: FunPtr GetFinalPath -> GetFinalPath +#elif defined(darwin_HOST_OS) || defined(linux_HOST_OS) +-- on unix, this is a bit more confusing. +-- The layout right now is somehting like +-- +-- /bin/ghc-X.Y.Z <- wrapper script (1) +-- /bin/ghc <- symlink to wrapper script (2) +-- /lib/ghc-X.Y.Z/bin/ghc <- ghc executable (3) +-- /lib/ghc-X.Y.Z <- $topdir (4) +-- +-- As such, we first need to find the absolute location to the +-- binary. +-- +-- getExecutablePath will return (3). One takeDirectory will +-- give use /lib/ghc-X.Y.Z/bin, and another will give us (4). +-- +-- This of course only works due to the current layout. If +-- the layout is changed, such that we have ghc-X.Y.Z/{bin,lib} +-- this would need to be changed accordingly. +-- +getBaseDir = Just . (\p -> p </> "lib") . takeDirectory . takeDirectory <$> getExecutablePath +#else +getBaseDir = return Nothing +#endif |