X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FSysTools.lhs;h=e40312cd7e7326d274bdd904b5a4d12deca1b9fa;hp=26c2f1b132f7172b244837094fb5ffe2bb57bd8a;hb=79f275092de54ba5f7e7336c13231ad5198befdf;hpb=5af10d51868a48e1ecb0b246f56bfff2e428aedd diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index 26c2f1b..e40312c 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -7,38 +7,34 @@ ----------------------------------------------------------------------------- \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - +{-# OPTIONS -fno-warn-unused-do-bind #-} 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, + -- Initialisation + initSysTools, + + -- Interface to system tools + runUnlit, runCpp, runCc, -- [Option] -> IO () + runPp, -- [Option] -> IO () + runSplit, -- [Option] -> IO () + runAs, runLink, -- [Option] -> IO () + runMkDLL, runWindres, + runLlvmOpt, + runLlvmLlc, + figureLlvmVersion, + readElfSection, - touch, -- String -> String -> IO () - copy, + touch, -- String -> String -> IO () + copy, copyWithHeader, - normalisePath, -- FilePath -> FilePath - getExtraViaCOpts, - - -- Temporary-file management - setTmpDir, - newTempName, - cleanTempDirs, cleanTempFiles, cleanTempFilesExcept, - addFilesToClean, - Option(..) + -- Temporary-file management + setTmpDir, + newTempName, + cleanTempDirs, cleanTempFiles, cleanTempFilesExcept, + addFilesToClean, + + Option(..) ) where @@ -51,58 +47,56 @@ import ErrUtils import Panic import Util import DynFlags -import FiniteMap +import StaticFlags +import Exception -import Control.Exception 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 +import qualified Data.Map as Map +import Text.ParserCombinators.ReadP hiding (char) +import qualified Text.ParserCombinators.ReadP as R #ifndef mingw32_HOST_OS import qualified System.Posix.Internals #else /* Must be Win32 */ import Foreign -import CString ( CString, peekCString ) +import Foreign.C.String #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 +import Control.Concurrent +import FastString import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan ) -#endif \end{code} +How GHC finds its files +~~~~~~~~~~~~~~~~~~~~~~~ - The configuration story - ~~~~~~~~~~~~~~~~~~~~~~~ +[Note topdir] GHC needs various support files (library packages, RTS etc), plus -various auxiliary programs (cp, gcc, etc). It finds these in one -of two places: +various auxiliary programs (cp, gcc, etc). It starts by finding topdir, +the root of GHC's support files -* When running as an *installed program*, GHC finds most of this support - stuff in the installed library tree. The path to this tree is passed - to GHC via the -B flag, and given to initSysTools . +On Unix: + - ghc always has a shell wrapper that passes a -B option -* 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. +On Windows: + - ghc never has a shell wrapper. + - we can find the location of the ghc binary, which is + $topdir/bin/.exe + where may be "ghc", "ghc-stage2", or similar + - we strip off the "bin/.exe" to leave $topdir. -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). +from topdir we can find package.conf, ghc-asm, etc. SysTools.initSysProgs figures out exactly where all the auxiliary programs @@ -112,16 +106,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 The *path* to the directory containing unlit, split etc + cSPLIT_DIR *relative* to the root of the build tree, + for use when running *in-place* in a build tree (only) - 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) - --------------------------------------------- @@ -144,278 +138,196 @@ 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) - - -> 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 - = 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 - - windres_path - | am_installed = installed_bin "bin/windres" - | otherwise = "windres" - - ; 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) - - 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 +initSysTools :: Maybe String -- Maybe TopDir path (without the '-B' prefix) + -> IO Settings -- Set all the mutable variables above, holding + -- (a) the system programs + -- (b) the package-config file + -- (c) the GHC usage message +initSysTools mbMinusB + = do { top_dir <- findTopDir mbMinusB + -- see [Note topdir] + -- NB: top_dir is assumed to be in standard Unix + -- format, '/' separated + + ; let settingsFile = top_dir "settings" + installed :: FilePath -> FilePath + installed file = top_dir file + installed_mingw_bin file = top_dir ".." "mingw" "bin" file + installed_perl_bin file = top_dir ".." "perl" file + + ; settingsStr <- readFile settingsFile + ; mySettings <- case maybeReadFuzzy settingsStr of + Just s -> + return s + Nothing -> + pgmError ("Can't parse " ++ show settingsFile) + ; let getSetting key = case lookup key mySettings of + Just xs -> + return xs + Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile) + ; myExtraGccViaCFlags <- getSetting "GCC extra via C opts" + -- On Windows, mingw is distributed with GHC, + -- so we look in TopDir/../mingw/bin + -- 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 <- if isWindowsHost then return $ installed_mingw_bin "gcc" + else getSetting "C compiler command" + ; gcc_args_str <- if isWindowsHost then return [] + else getSetting "C compiler flags" + ; let gcc_args = map Option (words gcc_args_str) + ; perl_path <- if isWindowsHost + then return $ installed_perl_bin "perl" + else getSetting "perl command" + + ; let pkgconfig_path = installed "package.conf.d" + ghc_usage_msg_path = installed "ghc-usage.txt" + ghci_usage_msg_path = installed "ghci-usage.txt" + + -- For all systems, unlit, split, mangle are GHC utilities + -- architecture-specific stuff is done when building Config.hs + unlit_path = installed cGHC_UNLIT_PGM + + -- split is a Perl script + split_script = installed cGHC_SPLIT_PGM + + windres_path = installed_mingw_bin "windres" + + ; tmpdir <- getTemporaryDirectory + + ; let + -- 'touch' is a GHC util for Windows + touch_path + | isWindowsHost = installed 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. + -- 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, []) + (mkdll_prog, mkdll_args) + | not isWindowsHost + = panic "Can't build DLLs on a non-Win32 system" + | otherwise = + (installed_mingw_bin 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{ - 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_T = touch_path, - 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 + ; let cpp_prog = gcc_prog + cpp_args = Option "-E" + : map Option (words cRAWCPP_FLAGS) + ++ gcc_args + + -- Other things being equal, as and ld are simply gcc + ; let as_prog = gcc_prog + as_args = gcc_args + ld_prog = gcc_prog + ld_args = gcc_args + + -- We just assume on command line + ; let lc_prog = "llc" + lo_prog = "opt" + + ; return $ Settings { + sTmpDir = normalise tmpdir, + sGhcUsagePath = ghc_usage_msg_path, + sGhciUsagePath = ghci_usage_msg_path, + sTopDir = top_dir, + sRawSettings = mySettings, + sExtraGccViaCFlags = words myExtraGccViaCFlags, + sSystemPackageConfig = pkgconfig_path, + sPgm_L = unlit_path, + sPgm_P = (cpp_prog, cpp_args), + sPgm_F = "", + sPgm_c = (gcc_prog, gcc_args), + sPgm_s = (split_prog,split_args), + sPgm_a = (as_prog, as_args), + sPgm_l = (ld_prog, ld_args), + sPgm_dll = (mkdll_prog,mkdll_args), + sPgm_T = touch_path, + sPgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan", + sPgm_windres = windres_path, + sPgm_lo = (lo_prog,[]), + sPgm_lc = (lc_prog,[]), + -- Hans: this isn't right in general, but you can + -- elaborate it in the same way as the others + sOpt_L = [], + sOpt_P = (if opt_PIC + then -- this list gets reversed + ["-D__PIC__", "-U __PIC__"] + else []), + sOpt_F = [], + sOpt_c = [], + sOpt_a = [], + sOpt_m = [], + sOpt_l = [], + sOpt_windres = [], + sOpt_lo = [], + sOpt_lc = [] } - } - -#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 --- --- 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) --- --- 2. If package.conf exists in proto_top_dir, we are running --- 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 --- --- This is very gruesome indeed - -findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix). - -> IO (Bool, -- True <=> am installed, False <=> in-place - String) -- TopDir (in Unix format '/' separated) - -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") - - ; 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) - Nothing - -> do maybe_exec_dir <- getBaseDir -- Get directory of executable - case maybe_exec_dir of -- (only works on Windows; - -- returns Nothing on Unix) - Nothing -> throwDyn (InstallationError "missing -B option") - Just dir -> return dir +-- 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 -> ghcError (InstallationError "missing -B option") + Just dir -> return dir \end{code} %************************************************************************ -%* * +%* * \subsection{Running an external program} -%* * +%* * %************************************************************************ \begin{code} runUnlit :: DynFlags -> [Option] -> IO () -runUnlit dflags args = do +runUnlit dflags args = do let p = pgm_L dflags runSomething dflags "Literate pre-processor" p args runCpp :: DynFlags -> [Option] -> IO () -runCpp dflags args = do +runCpp dflags args = do let (p,args0) = pgm_P dflags - runSomething dflags "C pre-processor" p (args0 ++ args) + args1 = args0 ++ args + args2 = if dopt Opt_WarnIsError dflags + then Option "-Werror" : args1 + else args1 + mb_env <- getGccEnv args2 + runSomethingFiltered dflags id "C pre-processor" p args2 mb_env runPp :: DynFlags -> [Option] -> IO () -runPp dflags args = do +runPp dflags args = do let p = pgm_F dflags runSomething dflags "Haskell pre-processor" p args runCc :: DynFlags -> [Option] -> IO () -runCc dflags args = do +runCc dflags args = do let (p,args0) = pgm_c dflags args1 = args0 ++ args mb_env <- getGccEnv args1 @@ -478,10 +390,7 @@ xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys) -- a bug in gcc on Windows Vista where it can't find its auxiliary -- binaries (see bug #1110). getGccEnv :: [Option] -> IO (Maybe [(String,String)]) -getGccEnv opts = -#if __GLASGOW_HASKELL__ < 603 - return Nothing -#else +getGccEnv opts = if null b_dirs then return Nothing else do env <- getEnvironment @@ -490,32 +399,74 @@ getGccEnv opts = (b_dirs, _) = partitionWith get_b_opt opts get_b_opt (Option ('-':'B':dir)) = Left dir - get_b_opt other = Right other + get_b_opt other = Right other - mangle_path (path,paths) | map toUpper path == "PATH" + mangle_path (path,paths) | map toUpper path == "PATH" = (path, '\"' : head b_dirs ++ "\";" ++ paths) mangle_path other = other -#endif - -runMangle :: DynFlags -> [Option] -> IO () -runMangle dflags args = do - let (p,args0) = pgm_m dflags - runSomething dflags "Mangler" p (args0++args) runSplit :: DynFlags -> [Option] -> IO () -runSplit dflags args = do +runSplit dflags args = do let (p,args0) = pgm_s dflags runSomething dflags "Splitter" p (args0++args) runAs :: DynFlags -> [Option] -> IO () -runAs dflags args = do +runAs dflags args = do let (p,args0) = pgm_a dflags args1 = args0 ++ args mb_env <- getGccEnv args1 runSomethingFiltered dflags id "Assembler" p args1 mb_env +-- | Run the LLVM Optimiser +runLlvmOpt :: DynFlags -> [Option] -> IO () +runLlvmOpt dflags args = do + let (p,args0) = pgm_lo dflags + runSomething dflags "LLVM Optimiser" p (args0++args) + +-- | Run the LLVM Compiler +runLlvmLlc :: DynFlags -> [Option] -> IO () +runLlvmLlc dflags args = do + let (p,args0) = pgm_lc dflags + runSomething dflags "LLVM Compiler" p (args0++args) + +-- | Figure out which version of LLVM we are running this session +figureLlvmVersion :: DynFlags -> IO (Maybe Int) +figureLlvmVersion dflags = do + let (pgm,opts) = pgm_lc dflags + args = filter notNull (map showOpt opts) + -- we grab the args even though they should be useless just in + -- case the user is using a customised 'llc' that requires some + -- of the options they've specified. llc doesn't care what other + -- options are specified when '-version' is used. + args' = args ++ ["-version"] + ver <- catchIO (do + (pin, pout, perr, _) <- runInteractiveProcess pgm args' + Nothing Nothing + {- > llc -version + Low Level Virtual Machine (http://llvm.org/): + llvm version 2.8 (Ubuntu 2.8-0Ubuntu1) + ... + -} + hSetBinaryMode pout False + _ <- hGetLine pout + vline <- hGetLine pout + v <- case filter isDigit vline of + [] -> fail "no digits!" + [x] -> fail $ "only 1 digit! (" ++ show x ++ ")" + (x:y:_) -> return ((read [x,y]) :: Int) + hClose pin + hClose pout + hClose perr + return $ Just v + ) + (\err -> do + putMsg dflags $ text $ "Warning: " ++ show err + return Nothing) + return ver + + runLink :: DynFlags -> [Option] -> IO () -runLink dflags args = do +runLink dflags args = do let (p,args0) = pgm_l dflags args1 = args0 ++ args mb_env <- getGccEnv args1 @@ -530,25 +481,24 @@ runMkDLL dflags args = do runWindres :: DynFlags -> [Option] -> IO () runWindres dflags args = do - let (gcc,gcc_args) = pgm_c dflags - windres = pgm_windres dflags + let (gcc, gcc_args) = pgm_c dflags + windres = pgm_windres dflags + quote x = "\"" ++ x ++ "\"" + args' = -- If windres.exe and gcc.exe are in a directory containing + -- spaces then windres fails to run gcc. We therefore need + -- to tell it what command to use... + Option ("--preprocessor=" ++ + unwords (map quote (gcc : + map showOpt gcc_args ++ + ["-E", "-xc", "-DRC_INVOKED"]))) + -- ...but if we do that then if windres calls popen then + -- it can't understand the quoting, so we have to use + -- --use-temp-file so that it interprets it correctly. + -- See #1828. + : Option "--use-temp-file" + : args mb_env <- getGccEnv gcc_args - runSomethingFiltered dflags id "Windres" windres - -- we must tell windres where to find gcc: it might not be on PATH - (Option ("--preprocessor=" ++ - unwords (map quote (gcc : map showOpt gcc_args ++ - ["-E", "-xc", "-DRC_INVOKED"]))) - -- -- use-temp-file is required for windres to interpret the - -- quoting in the preprocessor arg above correctly. Without - -- this, windres calls the preprocessor with popen, which gets - -- the quoting wrong (discovered by experimentation and - -- reading the windres sources). See #1828. - : Option "--use-temp-file" - : args) - -- we must use the PATH workaround here too, since windres invokes gcc - mb_env - where - quote x = '\"' : x ++ "\"" + runSomethingFiltered dflags id "Windres" windres args' mb_env touch :: DynFlags -> String -> String -> IO () touch dflags purpose arg = @@ -562,52 +512,67 @@ copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath copyWithHeader dflags purpose maybe_header from to = do showPass dflags purpose - h <- openFile to WriteMode - ls <- readFile from -- inefficient, but it'll do for now. - -- ToDo: speed up via slurping. - maybe (return ()) (hPutStr h) maybe_header - hPutStr h ls - hClose h - -getExtraViaCOpts :: DynFlags -> IO [String] -getExtraViaCOpts dflags = do - f <- readFile (topDir dflags `joinFileName` "extra-gcc-opts") - return (words f) + hout <- openBinaryFile to WriteMode + hin <- openBinaryFile from ReadMode + ls <- hGetContents hin -- inefficient, but it'll do for now. ToDo: speed up + maybe (return ()) (hPutStr hout) maybe_header + hPutStr hout ls + hClose hout + hClose hin + +-- | read the contents of the named section in an ELF object as a +-- String. +readElfSection :: DynFlags -> String -> FilePath -> IO (Maybe String) +readElfSection _dflags section exe = do + let + prog = "readelf" + args = [Option "-p", Option section, FileOption "" exe] + -- + r <- readProcessWithExitCode prog (filter notNull (map showOpt args)) "" + case r of + (ExitSuccess, out, _err) -> return (doFilter (lines out)) + _ -> return Nothing + where + doFilter [] = Nothing + doFilter (s:r) = case readP_to_S parse s of + [(p,"")] -> Just p + _r -> doFilter r + where parse = do + skipSpaces; R.char '['; skipSpaces; string "0]"; skipSpaces; + munch (const True) \end{code} %************************************************************************ -%* * +%* * \subsection{Managing temporary files -%* * +%* * %************************************************************************ \begin{code} -GLOBAL_VAR(v_FilesToClean, [], [String] ) -GLOBAL_VAR(v_DirsToClean, emptyFM, FiniteMap FilePath FilePath ) -\end{code} - -\begin{code} cleanTempDirs :: DynFlags -> IO () cleanTempDirs dflags = unless (dopt Opt_KeepTmpFiles dflags) - $ do ds <- readIORef v_DirsToClean - removeTmpDirs dflags (eltsFM ds) - writeIORef v_DirsToClean emptyFM + $ do let ref = dirsToClean dflags + ds <- readIORef ref + removeTmpDirs dflags (Map.elems ds) + writeIORef ref Map.empty cleanTempFiles :: DynFlags -> IO () cleanTempFiles dflags = unless (dopt Opt_KeepTmpFiles dflags) - $ do fs <- readIORef v_FilesToClean + $ do let ref = filesToClean dflags + fs <- readIORef ref removeTmpFiles dflags fs - writeIORef v_FilesToClean [] + writeIORef ref [] cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO () cleanTempFilesExcept dflags dont_delete = unless (dopt Opt_KeepTmpFiles dflags) - $ do files <- readIORef v_FilesToClean + $ do let ref = filesToClean dflags + files <- readIORef ref let (to_keep, to_delete) = partition (`elem` dont_delete) files + writeIORef ref to_keep removeTmpFiles dflags to_delete - writeIORef v_FilesToClean to_keep -- find a temporary name that doesn't already exist. @@ -615,78 +580,81 @@ newTempName :: DynFlags -> Suffix -> IO FilePath newTempName dflags extn = do d <- getTempDir dflags x <- getProcessID - findTempName (d ++ "/ghc" ++ show x ++ "_") 0 + findTempName (d "ghc" ++ show x ++ "_") 0 where findTempName :: FilePath -> Integer -> IO FilePath findTempName prefix x - = do let filename = (prefix ++ show x) `joinFileExt` extn - b <- doesFileExist filename - if b then findTempName prefix (x+1) - else do consIORef v_FilesToClean filename -- clean it up later - return filename + = do let filename = (prefix ++ show x) <.> extn + b <- doesFileExist filename + if b then findTempName prefix (x+1) + else do -- clean it up later + consIORef (filesToClean dflags) filename + return filename -- return our temporary directory within tmp_dir, creating one if we -- don't have one yet getTempDir :: DynFlags -> IO FilePath -getTempDir dflags@(DynFlags{tmpDir=tmp_dir}) - = do mapping <- readIORef v_DirsToClean - case lookupFM mapping tmp_dir of +getTempDir dflags + = do let ref = dirsToClean dflags + tmp_dir = tmpDir dflags + mapping <- readIORef ref + case Map.lookup tmp_dir mapping of Nothing -> do x <- getProcessID - let prefix = tmp_dir ++ "/ghc" ++ show x ++ "_" + let prefix = tmp_dir "ghc" ++ show x ++ "_" let mkTempDir :: Integer -> IO FilePath mkTempDir x = let dirname = prefix ++ show x in do createDirectory dirname - let mapping' = addToFM mapping tmp_dir dirname - writeIORef v_DirsToClean mapping' - debugTraceMsg dflags 2 (ptext SLIT("Created temporary directory:") <+> text dirname) + let mapping' = Map.insert tmp_dir dirname mapping + writeIORef ref mapping' + debugTraceMsg dflags 2 (ptext (sLit "Created temporary directory:") <+> text dirname) return dirname - `IO.catch` \e -> + `catchIO` \e -> if isAlreadyExistsError e then mkTempDir (x+1) else ioError e mkTempDir 0 Just d -> return d -addFilesToClean :: [FilePath] -> IO () +addFilesToClean :: DynFlags -> [FilePath] -> IO () -- May include wildcards [used by DriverPipeline.run_phase SplitMangle] -addFilesToClean files = mapM_ (consIORef v_FilesToClean) files +addFilesToClean dflags files = mapM_ (consIORef (filesToClean dflags)) files removeTmpDirs :: DynFlags -> [FilePath] -> IO () removeTmpDirs dflags ds = traceCmd dflags "Deleting temp dirs" - ("Deleting: " ++ unwords ds) - (mapM_ (removeWith dflags removeDirectory) ds) + ("Deleting: " ++ unwords ds) + (mapM_ (removeWith dflags removeDirectory) ds) removeTmpFiles :: DynFlags -> [FilePath] -> IO () removeTmpFiles dflags fs = warnNon $ - traceCmd dflags "Deleting temp files" - ("Deleting: " ++ unwords deletees) - (mapM_ (removeWith dflags removeFile) deletees) + traceCmd dflags "Deleting temp files" + ("Deleting: " ++ unwords deletees) + (mapM_ (removeWith dflags removeFile) deletees) where -- Flat out refuse to delete files that are likely to be source input -- files (is there a worse bug than having a compiler delete your source -- files?) - -- + -- -- Deleting source files is a sign of a bug elsewhere, so prominently flag -- the condition. warnNon act | null non_deletees = act | otherwise = do putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees)) - act + act (non_deletees, deletees) = partition isHaskellUserSrcFilename fs removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO () -removeWith dflags remover f = remover f `IO.catch` +removeWith dflags remover f = remover f `catchIO` (\e -> let msg = if isDoesNotExistError e - then ptext SLIT("Warning: deleting non-existent") <+> text f - else ptext SLIT("Warning: exception raised when deleting") + then ptext (sLit "Warning: deleting non-existent") <+> text f + else ptext (sLit "Warning: exception raised when deleting") <+> text f <> colon $$ text (show e) in debugTraceMsg dflags 2 msg @@ -696,14 +664,14 @@ removeWith dflags remover f = remover f `IO.catch` -- Running an external program runSomething :: DynFlags - -> String -- For -v message - -> String -- Command name (possibly a full path) - -- assumed already dos-ified - -> [Option] -- Arguments - -- runSomething will dos-ify them - -> IO () - -runSomething dflags phase_name pgm args = + -> String -- For -v message + -> String -- Command name (possibly a full path) + -- assumed already dos-ified + -> [Option] -- Arguments + -- runSomething will dos-ify them + -> IO () + +runSomething dflags phase_name pgm args = runSomethingFiltered dflags id phase_name pgm args Nothing runSomethingFiltered @@ -712,44 +680,41 @@ runSomethingFiltered runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do let real_args = filter notNull (map showOpt args) - traceCmd dflags phase_name (unwords (pgm:real_args)) $ do - (exit_code, doesn'tExist) <- - IO.catch (do +#if __GLASGOW_HASKELL__ >= 701 + cmdLine = showCommandForUser pgm real_args +#else + cmdLine = unwords (pgm:real_args) +#endif + traceCmd dflags phase_name cmdLine $ do + (exit_code, doesn'tExist) <- + catchIO (do rc <- builderMainLoop dflags filter_fn pgm real_args mb_env - case rc of - ExitSuccess{} -> return (rc, False) - ExitFailure n + case rc of + ExitSuccess{} -> return (rc, False) + ExitFailure n -- rawSystem returns (ExitFailure 127) if the exec failed for any -- reason (eg. the program doesn't exist). This is the only clue -- we have, but we need to report something to the user because in -- the case of a missing program there will otherwise be no output -- at all. - | n == 127 -> return (rc, True) - | otherwise -> return (rc, False)) - -- Should 'rawSystem' generate an IO exception indicating that - -- 'pgm' couldn't be run rather than a funky return code, catch - -- this here (the win32 version does this, but it doesn't hurt - -- to test for this in general.) - (\ err -> - if IO.isDoesNotExistError err -#if defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ < 604 - -- the 'compat' version of rawSystem under mingw32 always - -- maps 'errno' to EINVAL to failure. - || case (ioeGetErrorType err ) of { InvalidArgument{} -> True ; _ -> False} -#endif - then return (ExitFailure 1, True) - else IO.ioError err) + | n == 127 -> return (rc, True) + | otherwise -> return (rc, False)) + -- Should 'rawSystem' generate an IO exception indicating that + -- 'pgm' couldn't be run rather than a funky return code, catch + -- this here (the win32 version does this, but it doesn't hurt + -- to test for this in general.) + (\ err -> + if IO.isDoesNotExistError err + then return (ExitFailure 1, True) + else IO.ioError err) case (doesn'tExist, exit_code) of - (True, _) -> throwDyn (InstallationError ("could not execute: " ++ pgm)) + (True, _) -> ghcError (InstallationError ("could not execute: " ++ pgm)) (_, ExitSuccess) -> return () - _ -> throwDyn (PhaseFailed phase_name exit_code) - - + _ -> ghcError (PhaseFailed phase_name exit_code) -#if __GLASGOW_HASKELL__ < 603 -builderMainLoop dflags filter_fn pgm real_args mb_env = do - rawSystem pgm real_args -#else +builderMainLoop :: DynFlags -> (String -> String) -> FilePath + -> [String] -> Maybe [(String, String)] + -> IO ExitCode builderMainLoop dflags filter_fn pgm real_args mb_env = do chan <- newChan (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing mb_env @@ -757,8 +722,8 @@ builderMainLoop dflags filter_fn pgm real_args mb_env = do -- and run a loop piping the output from the compiler to the log_action in DynFlags hSetBuffering hStdOut LineBuffering hSetBuffering hStdErr LineBuffering - forkIO (readerProc chan hStdOut filter_fn) - forkIO (readerProc chan hStdErr filter_fn) + _ <- forkIO (readerProc chan hStdOut filter_fn) + _ <- forkIO (readerProc chan hStdErr filter_fn) -- we don't want to finish until 2 streams have been completed -- (stdout and stderr) -- nor until 1 exit code has been retrieved. @@ -774,16 +739,16 @@ builderMainLoop dflags filter_fn pgm real_args mb_env = do -- for all of these to happen (status==3). -- ToDo: we should really have a contingency plan in case any of -- the threads dies, such as a timeout. - loop chan hProcess 0 0 exitcode = return exitcode + loop _ _ 0 0 exitcode = return exitcode loop chan hProcess t p exitcode = do mb_code <- if p > 0 then getProcessExitCode hProcess else return Nothing case mb_code of Just code -> loop chan hProcess t (p-1) code - Nothing - | t > 0 -> do - msg <- readChan chan + Nothing + | t > 0 -> do + msg <- readChan chan case msg of BuildMsg msg -> do log_action dflags SevInfo noSrcSpan defaultUserStyle msg @@ -795,39 +760,41 @@ builderMainLoop dflags filter_fn pgm real_args mb_env = do loop chan hProcess (t-1) p exitcode | otherwise -> loop chan hProcess t p exitcode +readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO () readerProc chan hdl filter_fn = (do str <- hGetContents hdl - loop (linesPlatform (filter_fn str)) Nothing) + loop (linesPlatform (filter_fn str)) Nothing) `finally` writeChan chan EOF - -- ToDo: check errors more carefully - -- ToDo: in the future, the filter should be implemented as - -- a stream transformer. + -- ToDo: check errors more carefully + -- ToDo: in the future, the filter should be implemented as + -- a stream transformer. where - loop [] Nothing = return () - loop [] (Just err) = writeChan chan err - loop (l:ls) in_err = - case in_err of - Just err@(BuildError srcLoc msg) - | leading_whitespace l -> do - loop ls (Just (BuildError srcLoc (msg $$ text l))) - | otherwise -> do - writeChan chan err - checkError l ls - Nothing -> do - checkError l ls - - checkError l ls - = case parseError l of - Nothing -> do - writeChan chan (BuildMsg (text l)) - loop ls Nothing - Just (file, lineNum, colNum, msg) -> do - let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum - loop ls (Just (BuildError srcLoc (text msg))) - - leading_whitespace [] = False - leading_whitespace (x:_) = isSpace x + loop [] Nothing = return () + loop [] (Just err) = writeChan chan err + loop (l:ls) in_err = + case in_err of + Just err@(BuildError srcLoc msg) + | leading_whitespace l -> do + loop ls (Just (BuildError srcLoc (msg $$ text l))) + | otherwise -> do + writeChan chan err + checkError l ls + Nothing -> do + checkError l ls + _ -> panic "readerProc/loop" + + checkError l ls + = case parseError l of + Nothing -> do + writeChan chan (BuildMsg (text l)) + loop ls Nothing + Just (file, lineNum, colNum, msg) -> do + let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum + loop ls (Just (BuildError srcLoc (text msg))) + + leading_whitespace [] = False + leading_whitespace (x:_) = isSpace x parseError :: String -> Maybe (String, Int, Int, String) parseError s0 = case breakColon s0 of @@ -858,58 +825,63 @@ data BuildMessage = BuildMsg !SDoc | BuildError !SrcLoc !SDoc | EOF -#endif - -showOpt (FileOption pre f) = pre ++ platformPath f -showOpt (Option s) = s traceCmd :: DynFlags -> String -> String -> IO () -> IO () --- a) trace the command (at two levels of verbosity) --- b) don't do it at all if dry-run is set +-- trace the command (at two levels of verbosity) traceCmd dflags phase_name cmd_line action - = do { let verb = verbosity dflags - ; showPass dflags phase_name - ; debugTraceMsg dflags 3 (text cmd_line) - ; hFlush stderr - - -- Test for -n flag - ; unless (dopt Opt_DryRun dflags) $ do { - - -- And run it! - ; action `IO.catch` handle_exn verb - }} + = do { let verb = verbosity dflags + ; showPass dflags phase_name + ; debugTraceMsg dflags 3 (text cmd_line) + ; hFlush stderr + + -- And run it! + ; action `catchIO` handle_exn verb + } where - handle_exn verb exn = do { debugTraceMsg dflags 2 (char '\n') - ; debugTraceMsg dflags 2 (ptext SLIT("Failed:") <+> text cmd_line <+> text (show exn)) - ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) } + handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n') + ; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn)) + ; ghcError (PhaseFailed phase_name (ExitFailure 1)) } \end{code} %************************************************************************ -%* * +%* * \subsection{Support code} -%* * +%* * %************************************************************************ \begin{code} ----------------------------------------------------------------------------- --- Define getBaseDir :: IO (Maybe String) +-- Define getBaseDir :: IO (Maybe String) getBaseDir :: IO (Maybe String) #if defined(mingw32_HOST_OS) --- Assuming we are running ghc, accessed by path $()/bin/ghc.exe, --- return the path $(stuff). Note that we drop the "bin/" directory too. -getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32. - buf <- mallocArray len - ret <- getModuleFileName nullPtr buf len - if ret == 0 then free buf >> return Nothing - else do s <- peekCString buf - free buf - return (Just (rootDir s)) +-- Assuming we are running ghc, accessed by path $(stuff)/bin/ghc.exe, +-- return the path $(stuff)/lib. +getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32. where - rootDir s = reverse (dropList "/bin/ghc.exe" (reverse (normalisePath s))) - -foreign import stdcall unsafe "GetModuleFileNameA" - getModuleFileName :: Ptr () -> CString -> Int -> IO Int32 + try_size size = allocaArray (fromIntegral size) $ \buf -> do + ret <- c_GetModuleFileName nullPtr buf size + case ret of + 0 -> return Nothing + _ | ret < size -> fmap (Just . rootDir) $ peekCWString buf + | otherwise -> try_size (size * 2) + + 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', bin) | lower bin == "bin" -> takeDirectory d' "lib" + _ -> fail + _ -> fail + where fail = panic ("can't decompose ghc.exe path: " ++ show s) + lower = map toLower + +foreign import stdcall unsafe "windows.h GetModuleFileNameW" + c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 #else getBaseDir = return Nothing #endif @@ -928,7 +900,7 @@ linesPlatform :: String -> [String] linesPlatform ls = lines ls #else linesPlatform "" = [] -linesPlatform xs = +linesPlatform xs = case lineBreak xs of (as,xs1) -> as : linesPlatform xs1 where