-----------------------------------------------------------------------------
\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
-
module SysTools (
-- Initialisation
initSysTools,
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
#endif
import System.Process ( runInteractiveProcess, getProcessExitCode )
-import Control.Concurrent( forkIO, newChan, readChan, writeChan )
+import Control.Concurrent
import FastString
import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
\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:
+
+ for "installed" topdir is the root of GHC's support files ($libdir)
+ for "in-place" topdir is the root of the build tree
-* 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
+ - in an installation, <dir> is $libdir
+ - in a build tree, <dir> is $TOP/inplace-datadir
+ - so we detect the build-tree case and add ".." to get us back to $TOP
-* 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/ghc.exe in an installation, or
+ $topdir/ghc/stage1-inplace/ghc.exe in a build tree.
+ - we detect which one of these we have, and calculate $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, which contains the locations of
+almost everything else, whether we're in a build tree or installed.
SysTools.initSysProgs figures out exactly where all the auxiliary programs
-- (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
+ -- see [Note topdir]
-- 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
+ 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"
+ | otherwise = inplace "inplace-datadir" "package.conf"
ghc_usage_msg_path
| am_installed = installed "ghc-usage.txt"
| am_installed = installed_bin "bin/windres"
| otherwise = "windres"
- ; let dflags0 = defaultDynFlags
-
; tmpdir <- getTemporaryDirectory
; let dflags1 = setTmpDir tmpdir dflags0
-- Check that the package config exists
; config_exists <- doesFileExist pkgconfig_path
; when (not config_exists) $
- throwDyn (InstallationError
+ ghcError (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/")
+ -- 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_mingw_include_arg = Option ("-I" ++ installed "include/mingw/")
(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)
+ | 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, gcc_mingw_include_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 ])
+ Option gcc_prog, gcc_b_arg, gcc_mingw_include_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
-- HACK, see setPgmP below. We keep 'words' here to remember to fix
; 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)
-- 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 </> "package.conf")
+ ; exists1 <- doesFileExist (top_dir </> "package.conf")
+ ; exists2 <- doesFileExist (top_dir </> "inplace")
+ ; let amInplace = not exists1 -- On Windows, package.conf doesn't exist
+ -- when we are inplace
+ || exists2 -- On Linux, the presence of inplace signals
+ -- that we are inplace
- ; return (am_installed, top_dir)
+ ; let real_top = if exists2 then top_dir </> ".." else top_dir
+
+ ; return (not amInplace, real_top)
}
where
-- get_proto returns a Unix-format path (relying on getBaseDir to do so too)
-> 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")
+ Nothing -> ghcError (InstallationError "missing -B<dir> option")
Just dir -> return dir
\end{code}
-- binaries (see bug #1110).
getGccEnv :: [Option] -> IO (Maybe [(String,String)])
getGccEnv opts =
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603
- return Nothing
-#else
if null b_dirs
then return Nothing
else do env <- getEnvironment
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
%************************************************************************
\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
+ $ do let ref = dirsToClean dflags
+ ds <- readIORef ref
removeTmpDirs dflags (eltsFM ds)
- writeIORef v_DirsToClean emptyFM
+ writeIORef ref emptyFM
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.
= do let filename = (prefix ++ show x) <.> extn
b <- doesFileExist filename
if b then findTempName prefix (x+1)
- else do consIORef v_FilesToClean filename -- clean it up later
+ 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
+ = do let ref = dirsToClean dflags
+ mapping <- readIORef ref
case lookupFM mapping tmp_dir of
Nothing ->
do x <- getProcessID
= let dirname = prefix ++ show x
in do createDirectory dirname
let mapping' = addToFM mapping tmp_dir dirname
- writeIORef v_DirsToClean mapping'
+ writeIORef ref mapping'
debugTraceMsg dflags 2 (ptext (sLit "Created temporary directory:") <+> text dirname)
return dirname
`IO.catch` \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
-- 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)
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 defined(__GLASGOW_HASKELL__) && __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
-- 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
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)
checkError l ls
Nothing -> do
checkError l ls
+ _ -> panic "readerProc/loop"
checkError l ls
= case parseError l of
= BuildMsg !SDoc
| BuildError !SrcLoc !SDoc
| EOF
-#endif
+showOpt :: Option -> String
showOpt (FileOption pre f) = pre ++ f
showOpt (Option s) = s
; 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}
%************************************************************************
return (Just (rootDir s))
where
rootDir s = case splitFileName $ normalise s of
- (d, "ghc.exe") ->
+ (d, ghc_exe) | lower ghc_exe == "ghc.exe" ->
case splitFileName $ takeDirectory d of
- (d', "bin") -> takeDirectory d'
- _ -> panic ("Expected \"bin\" in " ++ show s)
- _ -> panic ("Expected \"ghc.exe\" in " ++ show s)
+ -- installed ghc.exe is in $topdir/bin/ghc.exe
+ (d', bin) | lower bin == "bin" -> takeDirectory d'
+ -- inplace ghc.exe is in $topdir/ghc/stage1-inplace/ghc.exe
+ (d', x) | "-inplace" `isSuffixOf` lower x ->
+ takeDirectory d' </> ".."
+ _ -> 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