\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,
+ runLlvmOpt,
+ runLlvmLlc,
+
+ 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
import Panic
import Util
import DynFlags
-import FiniteMap
-import Control.Exception
+import 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
#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 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<dir> 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/<something>.exe
+ where <something> may be "ghc", "ghc-stage2", or similar
+ - we strip off the "bin/<something>.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
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)
-
---------------------------------------------
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
-
- ; 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
+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 dflags0
+ = do { top_dir <- findTopDir mbMinusB
+ -- see [Note topdir]
+ -- NB: top_dir is assumed to be in standard Unix
+ -- format, '/' separated
+
+ ; let 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
+
+ ; 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 and mangle are Perl scripts
+ split_script = installed cGHC_SPLIT_PGM
+ mangle_script = installed cGHC_MANGLER_PGM
+
+ windres_path = installed_mingw_bin "windres"
+
+ ; tmpdir <- getTemporaryDirectory
+ ; let dflags1 = setTmpDir tmpdir dflags0
+
+ -- On Windows, mingw is distributed with GHC,
+ -- so we look in TopDir/../mingw/bin
+ ; let
+ gcc_prog
+ | isWindowsHost = installed_mingw_bin "gcc"
+ | otherwise = cGCC
+ perl_path
+ | isWindowsHost = installed_perl_bin cGHC_PERL
+ | otherwise = cGHC_PERL
+ -- '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 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"
+ | 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,
+ (Option "-E"):(map Option (words cRAWCPP_FLAGS)))
- -- 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))
+ -- Other things being equal, as and ld are simply gcc
+ ; let as_prog = gcc_prog
+ ld_prog = gcc_prog
-#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
+ -- figure out llvm location. (TODO: Acutally implement).
+ ; let lc_prog = "llc"
+ lo_prog = "opt"
- -- 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{
+ ; 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,[]),
+ pgm_m = (mangle_prog,mangle_args),
+ pgm_s = (split_prog,split_args),
+ pgm_a = (as_prog,[]),
+ pgm_l = (ld_prog,[]),
+ 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,
+ pgm_lo = (lo_prog,[]),
+ pgm_lc = (lc_prog,[])
+ -- 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
---
--- 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<dir> 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<dir> 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
-- 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
(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) = ("PATH", '\"' : head b_dirs ++ "\";" ++ paths)
+ 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
+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
+runLlvmOpt :: DynFlags -> [Option] -> IO ()
+runLlvmOpt dflags args = do
+ let (p,args0) = pgm_lo dflags
+ runSomething dflags "LLVM Optimiser" p (args0++args)
+
+runLlvmLlc :: DynFlags -> [Option] -> IO ()
+runLlvmLlc dflags args = do
+ let (p,args0) = pgm_lc dflags
+ runSomething dflags "LLVM Compiler" p (args0++args)
+
runLink :: DynFlags -> [Option] -> IO ()
-runLink dflags args = do
+runLink dflags args = do
let (p,args0) = pgm_l dflags
- runSomething dflags "Linker" p (args0++args)
+ args1 = args0 ++ args
+ mb_env <- getGccEnv args1
+ runSomethingFiltered dflags id "Linker" p args1 mb_env
runMkDLL :: DynFlags -> [Option] -> IO ()
runMkDLL dflags args = do
mb_env <- getGccEnv (args0++args)
runSomethingFiltered dflags id "Make DLL" p args1 mb_env
+runWindres :: DynFlags -> [Option] -> IO ()
+runWindres dflags args = do
+ 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 args' mb_env
+
touch :: DynFlags -> String -> String -> IO ()
touch dflags purpose arg =
runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
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
-
+ 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
+
+getExtraViaCOpts :: DynFlags -> IO [String]
+getExtraViaCOpts dflags = do
+ f <- readFile (topDir dflags </> "extra-gcc-opts")
+ return (words f)
\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
removeTmpFiles dflags to_delete
- writeIORef v_FilesToClean to_keep
+ writeIORef ref to_keep
-- find a temporary name that doesn't already exist.
newTempName dflags extn
= do d <- getTempDir dflags
x <- getProcessID
- findTempName (d ++ "/ghc" ++ show x ++ "_") 0
- where
+ 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
+ = do let ref = dirsToClean 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 ->
if isAlreadyExistsError 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 dflags remover f = remover f `IO.catch`
(\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
-- 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
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) <-
+#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) <-
IO.catch (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
-- 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)
- rc <- loop chan hProcess 2 1 ExitSuccess
+ _ <- 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.
+ rc <- loop chan hProcess (2::Integer) (1::Integer) ExitSuccess
+ -- after that, we're done here.
hClose hStdIn
hClose hStdOut
hClose hStdErr
-- 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
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
= BuildMsg !SDoc
| BuildError !SrcLoc !SDoc
| EOF
-#endif
-
-showOpt (FileOption pre f) = pre ++ platformPath f
-showOpt (Option "") = ""
-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
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
+
+ -- Test for -n flag
+ ; unless (dopt Opt_DryRun dflags) $ do {
+
+ -- And run it!
+ ; action `IO.catch` 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.
+-- Assuming we are running ghc, accessed by path $(stuff)/bin/ghc.exe,
+-- return the path $(stuff)/lib.
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))
+ 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))
where
- rootDir s = reverse (dropList "/bin/ghc.exe" (reverse (normalisePath 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', 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 "GetModuleFileNameA"
getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
#ifdef mingw32_HOST_OS
foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
-#elif __GLASGOW_HASKELL__ > 504
-getProcessID :: IO Int
-getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
#else
getProcessID :: IO Int
-getProcessID = Posix.getProcessID
+getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
#endif
-- Divvy up text stream into lines, taking platform dependent
linesPlatform ls = lines ls
#else
linesPlatform "" = []
-linesPlatform xs =
+linesPlatform xs =
case lineBreak xs of
(as,xs1) -> as : linesPlatform xs1
where