X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FSysTools.lhs;h=006dd28588751996c0eb2592696bd63db237b786;hb=cb906a124e36cb5054784a5bc44eb9d099d20709;hp=17ed501deea7bcd5c627e617482df546b2457278;hpb=b1ab4b8a607addc4d097588db5761313c996a41f;p=ghc-hetmet.git diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index 17ed501..006dd28 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -8,28 +8,29 @@ \begin{code} module SysTools ( - -- Initialisation - initSysTools, - - -- Interface to system tools - runUnlit, runCpp, runCc, -- [Option] -> IO () - runPp, -- [Option] -> IO () - runMangle, runSplit, -- [Option] -> IO () - runAs, runLink, -- [Option] -> IO () - runMkDLL, - - touch, -- String -> String -> IO () - copy, + -- Initialisation + initSysTools, + + -- Interface to system tools + runUnlit, runCpp, runCc, -- [Option] -> IO () + runPp, -- [Option] -> IO () + runMangle, runSplit, -- [Option] -> IO () + runAs, runLink, -- [Option] -> IO () + runMkDLL, + runWindres, + + touch, -- String -> String -> IO () + copy, copyWithHeader, - normalisePath, -- FilePath -> FilePath - - -- Temporary-file management - setTmpDir, - newTempName, - cleanTempDirs, cleanTempFiles, cleanTempFilesExcept, - addFilesToClean, + getExtraViaCOpts, - Option(..) + -- Temporary-file management + setTmpDir, + newTempName, + cleanTempDirs, cleanTempFiles, cleanTempFilesExcept, + addFilesToClean, + + Option(..) ) where @@ -49,40 +50,30 @@ import Data.IORef import Control.Monad import System.Exit import System.Environment +import System.FilePath import System.IO -import SYSTEM_IO_ERROR as IO +import System.IO.Error as IO import System.Directory import Data.Char import Data.Maybe import Data.List #ifndef mingw32_HOST_OS -#if __GLASGOW_HASKELL__ > 504 import qualified System.Posix.Internals -#else -import qualified Posix -#endif #else /* Must be Win32 */ import Foreign -import CString ( CString, peekCString ) +import CString ( CString, peekCString ) #endif -#if __GLASGOW_HASKELL__ < 603 --- rawSystem comes from libghccompat.a in stage1 -import Compat.RawSystem ( rawSystem ) -import System.Cmd ( system ) -import GHC.IOBase ( IOErrorType(..) ) -#else -import System.Process ( runInteractiveProcess, getProcessExitCode ) -import Control.Concurrent( forkIO, newChan, readChan, writeChan ) -import FastString ( mkFastString ) +import System.Process ( runInteractiveProcess, getProcessExitCode ) +import Control.Concurrent +import FastString import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan ) -#endif \end{code} - The configuration story - ~~~~~~~~~~~~~~~~~~~~~~~ + The configuration story + ~~~~~~~~~~~~~~~~~~~~~~~ GHC needs various support files (library packages, RTS etc), plus various auxiliary programs (cp, gcc, etc). It finds these in one @@ -94,7 +85,7 @@ of two places: * When running *in-place* in a build tree, GHC finds most of this support stuff in the build tree. The path to the build tree is, again passed - to GHC via -B. + to GHC via -B. GHC tells which of the two is the case by seeing whether package.conf is in TopDir [installed] or in TopDir/ghc/driver [inplace] (what a hack). @@ -107,16 +98,16 @@ file containing variables whose value is figured out by the build system. Config.hs contains two sorts of things - cGCC, The *names* of the programs - cCPP e.g. cGCC = gcc - cUNLIT cCPP = gcc -E - etc They do *not* include paths - + cGCC, The *names* of the programs + cCPP e.g. cGCC = gcc + cUNLIT cCPP = gcc -E + etc They do *not* include paths + cUNLIT_DIR_REL The *path* to the directory containing unlit, split etc cSPLIT_DIR_REL *relative* to the root of the build tree, - for use when running *in-place* in a build tree (only) - + for use when running *in-place* in a build tree (only) + --------------------------------------------- @@ -139,223 +130,186 @@ Package Which would have the advantage that we get to collect together in one place the path-specific package stuff with the path-specific tool stuff. - End of NOTES + End of NOTES --------------------------------------------- %************************************************************************ -%* * +%* * \subsection{Initialisation} -%* * +%* * %************************************************************************ \begin{code} -initSysTools :: Maybe String -- Maybe TopDir path (without the '-B' prefix) +initSysTools :: Maybe String -- Maybe TopDir path (without the '-B' prefix) - -> DynFlags - -> IO DynFlags -- Set all the mutable variables above, holding - -- (a) the system programs - -- (b) the package-config file - -- (c) the GHC usage message + -> DynFlags + -> IO DynFlags -- Set all the mutable variables above, holding + -- (a) the system programs + -- (b) the package-config file + -- (c) the GHC usage message -initSysTools mbMinusB dflags +initSysTools mbMinusB dflags0 = do { (am_installed, top_dir) <- findTopDir mbMinusB - -- top_dir - -- for "installed" this is the root of GHC's support files - -- for "in-place" it is the root of the build tree - -- NB: top_dir is assumed to be in standard Unix - -- format, '/' separated - - ; let installed, installed_bin :: FilePath -> FilePath - installed_bin pgm = pgmPath top_dir pgm - installed file = pgmPath top_dir file - inplace dir pgm = pgmPath (top_dir `joinFileName` - cPROJECT_DIR `joinFileName` dir) pgm - - ; let pkgconfig_path - | am_installed = installed "package.conf" - | otherwise = inplace cGHC_DRIVER_DIR_REL "package.conf.inplace" - - ghc_usage_msg_path - | am_installed = installed "ghc-usage.txt" - | otherwise = inplace cGHC_DRIVER_DIR_REL "ghc-usage.txt" - - ghci_usage_msg_path - | am_installed = installed "ghci-usage.txt" - | otherwise = inplace cGHC_DRIVER_DIR_REL "ghci-usage.txt" - - -- For all systems, unlit, split, mangle are GHC utilities - -- architecture-specific stuff is done when building Config.hs - unlit_path - | am_installed = installed_bin cGHC_UNLIT_PGM - | otherwise = inplace cGHC_UNLIT_DIR_REL cGHC_UNLIT_PGM - - -- split and mangle are Perl scripts - split_script - | am_installed = installed_bin cGHC_SPLIT_PGM - | otherwise = inplace cGHC_SPLIT_DIR_REL cGHC_SPLIT_PGM - - mangle_script - | am_installed = installed_bin cGHC_MANGLER_PGM - | otherwise = inplace cGHC_MANGLER_DIR_REL cGHC_MANGLER_PGM - - ; let dflags0 = defaultDynFlags -#ifndef mingw32_HOST_OS - -- check whether TMPDIR is set in the environment - ; e_tmpdir <- IO.try (getEnv "TMPDIR") -- fails if not set -#else - -- On Win32, consult GetTempPath() for a temp dir. - -- => it first tries TMP, TEMP, then finally the - -- Windows directory(!). The directory is in short-path - -- form. - ; e_tmpdir <- - IO.try (do - let len = (2048::Int) - buf <- mallocArray len - ret <- getTempPath len buf - if ret == 0 then do - -- failed, consult TMPDIR. - free buf - getEnv "TMPDIR" - else do - s <- peekCString buf - free buf - return s) -#endif - ; let dflags1 = case e_tmpdir of - Left _ -> dflags0 - Right d -> setTmpDir d dflags0 - - -- Check that the package config exists - ; config_exists <- doesFileExist pkgconfig_path - ; when (not config_exists) $ - throwDyn (InstallationError - ("Can't find package.conf as " ++ pkgconfig_path)) - -#if defined(mingw32_HOST_OS) - -- WINDOWS-SPECIFIC STUFF - -- On Windows, gcc and friends are distributed with GHC, - -- so when "installed" we look in TopDir/bin - -- When "in-place" we look wherever the build-time configure - -- script found them - -- When "install" we tell gcc where its specs file + exes are (-B) - -- and also some places to pick up include files. We need - -- to be careful to put all necessary exes in the -B place - -- (as, ld, cc1, etc) since if they don't get found there, gcc - -- then tries to run unadorned "as", "ld", etc, and will - -- pick up whatever happens to be lying around in the path, - -- possibly including those from a cygwin install on the target, - -- which is exactly what we're trying to avoid. - ; let gcc_b_arg = Option ("-B" ++ installed "gcc-lib/") - (gcc_prog,gcc_args) - | am_installed = (installed_bin "gcc", [gcc_b_arg]) - | otherwise = (cGCC, []) - -- The trailing "/" is absolutely essential; gcc seems - -- to construct file names simply by concatenating to - -- this -B path with no extra slash We use "/" rather - -- than "\\" because otherwise "\\\" is mangled - -- later on; although gcc_args are in NATIVE format, - -- gcc can cope - -- (see comments with declarations of global variables) - -- - -- The quotes round the -B argument are in case TopDir - -- has spaces in it - - perl_path | am_installed = installed_bin cGHC_PERL - | otherwise = cGHC_PERL - - -- 'touch' is a GHC util for Windows, and similarly unlit, mangle - ; let touch_path | am_installed = installed_bin cGHC_TOUCHY_PGM - | otherwise = inplace cGHC_TOUCHY_DIR_REL cGHC_TOUCHY_PGM - - -- On Win32 we don't want to rely on #!/bin/perl, so we prepend - -- a call to Perl to get the invocation of split and mangle - ; let (split_prog, split_args) = (perl_path, [Option split_script]) - (mangle_prog, mangle_args) = (perl_path, [Option mangle_script]) - - ; let (mkdll_prog, mkdll_args) - | am_installed = - (pgmPath (installed "gcc-lib/") cMKDLL, - [ Option "--dlltool-name", - Option (pgmPath (installed "gcc-lib/") "dlltool"), - Option "--driver-name", - Option gcc_prog, gcc_b_arg ]) - | otherwise = (cMKDLL, []) -#else - -- UNIX-SPECIFIC STUFF - -- On Unix, the "standard" tools are assumed to be - -- in the same place whether we are running "in-place" or "installed" - -- That place is wherever the build-time configure script found them. - ; let gcc_prog = cGCC - gcc_args = [] - touch_path = "touch" - mkdll_prog = panic "Can't build DLLs on a non-Win32 system" - mkdll_args = [] - - -- On Unix, scripts are invoked using the '#!' method. Binary - -- installations of GHC on Unix place the correct line on the front - -- of the script at installation time, so we don't want to wire-in - -- our knowledge of $(PERL) on the host system here. - ; let (split_prog, split_args) = (split_script, []) - (mangle_prog, mangle_args) = (mangle_script, []) -#endif - - -- cpp is derived from gcc on all platforms + -- top_dir + -- for "installed" this is the root of GHC's support files + -- for "in-place" it is the root of the build tree + -- NB: top_dir is assumed to be in standard Unix + -- format, '/' separated + + ; let installed, installed_bin :: FilePath -> FilePath + installed_bin pgm = top_dir > pgm + installed file = top_dir > file + inplace dir pgm = top_dir > dir > pgm + + ; let pkgconfig_path + | am_installed = installed "package.conf" + | otherwise = inplace cGHC_DRIVER_DIR_REL "package.conf.inplace" + + ghc_usage_msg_path + | am_installed = installed "ghc-usage.txt" + | otherwise = inplace cGHC_DRIVER_DIR_REL "ghc-usage.txt" + + ghci_usage_msg_path + | am_installed = installed "ghci-usage.txt" + | otherwise = inplace cGHC_DRIVER_DIR_REL "ghci-usage.txt" + + -- For all systems, unlit, split, mangle are GHC utilities + -- architecture-specific stuff is done when building Config.hs + unlit_path + | am_installed = installed_bin cGHC_UNLIT_PGM + | otherwise = inplace cGHC_UNLIT_DIR_REL cGHC_UNLIT_PGM + + -- split and mangle are Perl scripts + split_script + | am_installed = installed_bin cGHC_SPLIT_PGM + | otherwise = inplace cGHC_SPLIT_DIR_REL cGHC_SPLIT_PGM + + mangle_script + | am_installed = installed_bin cGHC_MANGLER_PGM + | otherwise = inplace cGHC_MANGLER_DIR_REL cGHC_MANGLER_PGM + + windres_path + | am_installed = installed_bin "bin/windres" + | otherwise = "windres" + + ; tmpdir <- getTemporaryDirectory + ; let dflags1 = setTmpDir tmpdir dflags0 + + -- Check that the package config exists + ; config_exists <- doesFileExist pkgconfig_path + ; when (not config_exists) $ + throwDyn (InstallationError + ("Can't find package.conf as " ++ pkgconfig_path)) + + -- On Windows, gcc and friends are distributed with GHC, + -- so when "installed" we look in TopDir/bin + -- When "in-place", or when not on Windows, we look wherever + -- the build-time configure script found them + ; let + -- The trailing "/" is absolutely essential; gcc seems + -- to construct file names simply by concatenating to + -- this -B path with no extra slash We use "/" rather + -- than "\\" because otherwise "\\\" is mangled + -- later on; although gcc_args are in NATIVE format, + -- gcc can cope + -- (see comments with declarations of global variables) + gcc_b_arg = Option ("-B" ++ installed "gcc-lib/") + (gcc_prog,gcc_args) + | isWindowsHost && am_installed + -- We tell gcc where its specs file + exes are (-B) + -- and also some places to pick up include files. We need + -- to be careful to put all necessary exes in the -B place + -- (as, ld, cc1, etc) since if they don't get found there, + -- gcc then tries to run unadorned "as", "ld", etc, and + -- will pick up whatever happens to be lying around in + -- the path, possibly including those from a cygwin + -- install on the target, which is exactly what we're + -- trying to avoid. + = (installed_bin "gcc", [gcc_b_arg]) + | otherwise = (cGCC, []) + perl_path + | isWindowsHost && am_installed = installed_bin cGHC_PERL + | otherwise = cGHC_PERL + -- 'touch' is a GHC util for Windows + touch_path + | isWindowsHost + = if am_installed + then installed_bin cGHC_TOUCHY_PGM + else inplace cGHC_TOUCHY_DIR_REL cGHC_TOUCHY_PGM + | otherwise = "touch" + -- On Win32 we don't want to rely on #!/bin/perl, so we prepend + -- a call to Perl to get the invocation of split and mangle. + -- On Unix, scripts are invoked using the '#!' method. Binary + -- installations of GHC on Unix place the correct line on the + -- front of the script at installation time, so we don't want + -- to wire-in our knowledge of $(PERL) on the host system here. + (split_prog, split_args) + | isWindowsHost = (perl_path, [Option split_script]) + | otherwise = (split_script, []) + (mangle_prog, mangle_args) + | isWindowsHost = (perl_path, [Option mangle_script]) + | otherwise = (mangle_script, []) + (mkdll_prog, mkdll_args) + | not isWindowsHost + = panic "Can't build DLLs on a non-Win32 system" + | am_installed = + (installed "gcc-lib/" > cMKDLL, + [ Option "--dlltool-name", + Option (installed "gcc-lib/" > "dlltool"), + Option "--driver-name", + Option gcc_prog, gcc_b_arg ]) + | otherwise = (cMKDLL, []) + + -- cpp is derived from gcc on all platforms -- HACK, see setPgmP below. We keep 'words' here to remember to fix -- Config.hs one day. - ; let cpp_path = (gcc_prog, gcc_args ++ - (Option "-E"):(map Option (words cRAWCPP_FLAGS))) - - -- For all systems, copy and remove are provided by the host - -- system; architecture-specific stuff is done when building Config.hs - ; let cp_path = cGHC_CP - - -- Other things being equal, as and ld are simply gcc - ; let (as_prog,as_args) = (gcc_prog,gcc_args) - (ld_prog,ld_args) = (gcc_prog,gcc_args) - - ; return dflags1{ + ; let cpp_path = (gcc_prog, gcc_args ++ + (Option "-E"):(map Option (words cRAWCPP_FLAGS))) + + -- Other things being equal, as and ld are simply gcc + ; let (as_prog,as_args) = (gcc_prog,gcc_args) + (ld_prog,ld_args) = (gcc_prog,gcc_args) + + ; return dflags1{ ghcUsagePath = ghc_usage_msg_path, ghciUsagePath = ghci_usage_msg_path, topDir = top_dir, systemPackageConfig = pkgconfig_path, - pgm_L = unlit_path, - pgm_P = cpp_path, - pgm_F = "", - pgm_c = (gcc_prog,gcc_args), - pgm_m = (mangle_prog,mangle_args), - pgm_s = (split_prog,split_args), - pgm_a = (as_prog,as_args), - pgm_l = (ld_prog,ld_args), - pgm_dll = (mkdll_prog,mkdll_args), + pgm_L = unlit_path, + pgm_P = cpp_path, + pgm_F = "", + pgm_c = (gcc_prog,gcc_args), + pgm_m = (mangle_prog,mangle_args), + pgm_s = (split_prog,split_args), + pgm_a = (as_prog,as_args), + pgm_l = (ld_prog,ld_args), + pgm_dll = (mkdll_prog,mkdll_args), pgm_T = touch_path, - pgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan" - -- Hans: this isn't right in general, but you can - -- elaborate it in the same way as the others + pgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan", + pgm_windres = windres_path + -- Hans: this isn't right in general, but you can + -- elaborate it in the same way as the others } - } - -#if defined(mingw32_HOST_OS) -foreign import stdcall unsafe "GetTempPathA" getTempPath :: Int -> CString -> IO Int32 -#endif + } \end{code} \begin{code} -- Find TopDir --- for "installed" this is the root of GHC's support files --- for "in-place" it is the root of the build tree +-- for "installed" this is the root of GHC's support files +-- for "in-place" it is the root of the build tree -- -- Plan of action: -- 1. Set proto_top_dir --- if there is no given TopDir path, get the directory --- where GHC is running (only on Windows) +-- if there is no given TopDir path, get the directory +-- where GHC is running (only on Windows) -- -- 2. If package.conf exists in proto_top_dir, we are running --- installed; and TopDir = proto_top_dir +-- installed; and TopDir = proto_top_dir -- -- 3. Otherwise we are running in-place, so --- proto_top_dir will be /...stuff.../ghc/compiler --- Set TopDir to /...stuff..., which is the root of the build tree +-- proto_top_dir will be /...stuff.../ghc/compiler +-- Set TopDir to /...stuff..., which is the root of the build tree -- -- This is very gruesome indeed @@ -366,18 +320,18 @@ findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix). findTopDir mbMinusB = do { top_dir <- get_proto -- Discover whether we're running in a build tree or in an installation, - -- by looking for the package configuration file. - ; am_installed <- doesFileExist (top_dir `joinFileName` "package.conf") + -- by looking for the package configuration file. + ; am_installed <- doesFileExist (top_dir > "package.conf") ; return (am_installed, top_dir) } where -- get_proto returns a Unix-format path (relying on getBaseDir to do so too) get_proto = case mbMinusB of - Just minusb -> return (normalisePath minusb) + Just minusb -> return (normalise minusb) Nothing -> do maybe_exec_dir <- getBaseDir -- Get directory of executable - case maybe_exec_dir of -- (only works on Windows; + case maybe_exec_dir of -- (only works on Windows; -- returns Nothing on Unix) Nothing -> throwDyn (InstallationError "missing -B