-- Initialisation
initSysTools,
- getTopDir, -- IO String -- The value of $topdir
- getPackageConfigPath, -- IO String -- Where package.conf is
- getUsageMsgPaths, -- IO (String,String)
-
-- Interface to system tools
runUnlit, runCpp, runCc, -- [Option] -> IO ()
runPp, -- [Option] -> IO ()
runMkDLL,
touch, -- String -> String -> IO ()
- copy, -- String -> String -> String -> IO ()
+ copy,
+ copyWithHeader,
normalisePath, -- FilePath -> FilePath
-- Temporary-file management
cleanTempDirs, cleanTempFiles, cleanTempFilesExcept,
addFilesToClean,
- -- System interface
- system, -- String -> IO ExitCode
-
- -- Misc
- getSysMan, -- IO String Parallel system only
-
Option(..)
) where
#include "HsVersions.h"
-import DriverPhases ( isHaskellUserSrcFilename )
+import DriverPhases
import Config
import Outputable
-import ErrUtils ( putMsg, debugTraceMsg, showPass, Severity(..), Messages )
-import Panic ( GhcException(..) )
-import Util ( Suffix, global, notNull, consIORef, joinFileName,
- normalisePath, pgmPath, platformPath, joinFileExt )
-import DynFlags ( DynFlags(..), DynFlag(..), dopt, Option(..),
- setTmpDir, defaultDynFlags )
-
-import EXCEPTION ( throwDyn, finally )
-import DATA_IOREF ( IORef, readIORef, writeIORef )
-import DATA_INT
-
-import Monad ( when, unless )
-import System ( ExitCode(..), getEnv, system )
-import IO ( try, catch, hGetContents,
- openFile, hPutStr, hClose, hFlush, IOMode(..),
- stderr, ioError, isDoesNotExistError,
- isAlreadyExistsError )
-import Directory ( doesFileExist, removeFile,
- createDirectory, removeDirectory )
-import Maybe ( isJust )
-import List ( partition )
-import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, eltsFM )
-
--- GHC <= 4.08 didn't have rawSystem, and runs into problems with long command
--- lines on mingw32, so we disallow it now.
-#if __GLASGOW_HASKELL__ < 500
-#error GHC >= 5.00 is required for bootstrapping GHC
-#endif
+import ErrUtils
+import Panic
+import Util
+import DynFlags
+import FiniteMap
+
+import Control.Exception
+import Data.IORef
+import Control.Monad
+import System.Exit
+import System.Environment
+import System.IO
+import SYSTEM_IO_ERROR as IO
+import System.Directory
+import Data.Maybe
+import Data.List
#ifndef mingw32_HOST_OS
#if __GLASGOW_HASKELL__ > 504
import qualified Posix
#endif
#else /* Must be Win32 */
-import List ( isPrefixOf )
-import Util ( dropList )
import Foreign
import CString ( CString, peekCString )
#endif
#if __GLASGOW_HASKELL__ < 603
-- rawSystem comes from libghccompat.a in stage1
-import Compat.RawSystem ( rawSystem )
+import Compat.RawSystem ( rawSystem )
+import System.Cmd ( system )
import GHC.IOBase ( IOErrorType(..) )
-import System.IO.Error ( ioeGetErrorType )
#else
import System.Process ( runInteractiveProcess, getProcessExitCode )
-import System.IO ( hSetBuffering, hGetLine, BufferMode(..) )
import Control.Concurrent( forkIO, newChan, readChan, writeChan )
import Data.Char ( isSpace )
import FastString ( mkFastString )
End of NOTES
---------------------------------------------
-
-%************************************************************************
-%* *
-\subsection{Global variables to contain system programs}
-%* *
-%************************************************************************
-
-All these pathnames are maintained IN THE NATIVE FORMAT OF THE HOST MACHINE.
-(See remarks under pathnames below)
-
-\begin{code}
-GLOBAL_VAR(v_Pgm_T, error "pgm_T", String) -- touch
-GLOBAL_VAR(v_Pgm_CP, error "pgm_CP", String) -- cp
-
-GLOBAL_VAR(v_Path_package_config, error "path_package_config", String)
-GLOBAL_VAR(v_Path_usages, error "ghc_usage.txt", (String,String))
-
-GLOBAL_VAR(v_TopDir, error "TopDir", String) -- -B<dir>
-
--- Parallel system only
-GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String) -- system manager
-
--- ways to get at some of these variables from outside this module
-getPackageConfigPath = readIORef v_Path_package_config
-getTopDir = readIORef v_TopDir
-\end{code}
-
-
%************************************************************************
%* *
\subsection{Initialisation}
initSysTools mbMinusB dflags
= do { (am_installed, top_dir) <- findTopDir mbMinusB
- ; writeIORef v_TopDir top_dir
-- 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
+ -- 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
; let (as_prog,as_args) = (gcc_prog,gcc_args)
(ld_prog,ld_args) = (gcc_prog,gcc_args)
- -- Initialise the global vars
- ; writeIORef v_Path_package_config pkgconfig_path
- ; writeIORef v_Path_usages (ghc_usage_msg_path,
- ghci_usage_msg_path)
-
- ; writeIORef v_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
-
- ; writeIORef v_Pgm_T touch_path
- ; writeIORef v_Pgm_CP cp_path
-
; 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_s = (split_prog,split_args),
pgm_a = (as_prog,as_args),
pgm_l = (ld_prog,ld_args),
- pgm_dll = (mkdll_prog,mkdll_args) }
+ pgm_dll = (mkdll_prog,mkdll_args),
+ pgm_T = touch_path,
+ pgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan"
+ -- Hans: this isn't right in general, but you can
+ -- elaborate it in the same way as the others
+ }
}
#if defined(mingw32_HOST_OS)
runCc :: DynFlags -> [Option] -> IO ()
runCc dflags args = do
let (p,args0) = pgm_c dflags
- runSomethingFiltered dflags cc_filter "C Compiler" p (args0++args)
+ (args1,mb_env) <- getGccEnv (args0++args)
+ runSomethingFiltered dflags cc_filter "C Compiler" p args1 mb_env
where
-- discard some harmless warnings from gcc that we can't turn off
cc_filter str = unlines (do_filter (lines str))
r_from = mkRegex "from.*:[0-9]+"
r_warn = mkRegex "warning: call-clobbered register used"
+-- Turn the -B<dir> option to gcc into the GCC_EXEC_PREFIX env var, to
+-- workaround a bug in MinGW gcc on Windows Vista, see bug #1110.
+getGccEnv :: [Option] -> IO ([Option], Maybe [(String,String)])
+getGccEnv opts =
+#if __GLASGOW_HASKELL__ < 603
+ return (opts,Nothing)
+#else
+ if null b_dirs
+ then return (opts,Nothing)
+ else do env <- getEnvironment
+ return (rest, Just (("GCC_EXEC_PREFIX", head b_dirs) : env))
+ where
+ (b_dirs, rest) = partitionWith get_b_opt opts
+
+ get_b_opt (Option ('-':'B':dir)) = Left dir
+ get_b_opt other = Right other
+#endif
+
runMangle :: DynFlags -> [Option] -> IO ()
runMangle dflags args = do
let (p,args0) = pgm_m dflags
runMkDLL :: DynFlags -> [Option] -> IO ()
runMkDLL dflags args = do
let (p,args0) = pgm_dll dflags
- runSomething dflags "Make DLL" p (args0++args)
+ (args1,mb_env) <- getGccEnv (args0++args)
+ runSomethingFiltered dflags id "Make DLL" p args1 mb_env
touch :: DynFlags -> String -> String -> IO ()
-touch dflags purpose arg = do
- p <- readIORef v_Pgm_T
- runSomething dflags purpose p [FileOption "" arg]
+touch dflags purpose arg =
+ runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
+
+copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()
+copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to
-copy :: DynFlags -> String -> String -> String -> IO ()
-copy dflags purpose from to = do
+copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath
+ -> IO ()
+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
\end{code}
-\begin{code}
-getSysMan :: IO String -- How to invoke the system manager
- -- (parallel system only)
-getSysMan = readIORef v_Pgm_sysman
-\end{code}
-
-\begin{code}
-getUsageMsgPaths :: IO (FilePath,FilePath)
- -- the filenames of the usage messages (ghc, ghci)
-getUsageMsgPaths = readIORef v_Path_usages
-\end{code}
-
-
%************************************************************************
%* *
\subsection{Managing temporary files
\begin{code}
cleanTempDirs :: DynFlags -> IO ()
cleanTempDirs dflags
- = do ds <- readIORef v_DirsToClean
+ = unless (dopt Opt_KeepTmpFiles dflags)
+ $ do ds <- readIORef v_DirsToClean
removeTmpDirs dflags (eltsFM ds)
writeIORef v_DirsToClean emptyFM
cleanTempFiles :: DynFlags -> IO ()
cleanTempFiles dflags
- = do fs <- readIORef v_FilesToClean
- removeTmpFiles dflags fs
- writeIORef v_FilesToClean []
+ = unless (dopt Opt_KeepTmpFiles dflags)
+ $ do fs <- readIORef v_FilesToClean
+ removeTmpFiles dflags fs
+ writeIORef v_FilesToClean []
cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
cleanTempFilesExcept dflags dont_delete
- = do files <- readIORef v_FilesToClean
- let (to_keep, to_delete) = partition (`elem` dont_delete) files
- removeTmpFiles dflags to_delete
- writeIORef v_FilesToClean to_keep
+ = unless (dopt Opt_KeepTmpFiles dflags)
+ $ do files <- readIORef v_FilesToClean
+ let (to_keep, to_delete) = partition (`elem` dont_delete) files
+ removeTmpFiles dflags to_delete
+ writeIORef v_FilesToClean to_keep
-- find a temporary name that doesn't already exist.
removeTmpDirs dflags ds
= traceCmd dflags "Deleting temp dirs"
("Deleting: " ++ unwords ds)
- (mapM_ rmdir ds)
- where
- rmdir d = removeDirectory d `IO.catch`
- (\_ignored ->
- debugTraceMsg dflags 2 (ptext SLIT("Warning: deleting") <+> text d <+> ptext SLIT("raised exception"))
- )
+ (mapM_ (removeWith dflags removeDirectory) ds)
removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
removeTmpFiles dflags fs
= warnNon $
traceCmd dflags "Deleting temp files"
("Deleting: " ++ unwords deletees)
- (mapM_ rm 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
(non_deletees, deletees) = partition isHaskellUserSrcFilename fs
- rm f = removeFile f `IO.catch`
- (\_ignored ->
- debugTraceMsg dflags 2 (ptext SLIT("Warning: deleting non-existent") <+> text f)
- )
-
+removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
+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")
+ <+> text f <> colon
+ $$ text (show e)
+ in debugTraceMsg dflags 2 msg
+ )
-----------------------------------------------------------------------------
-- Running an external program
-> IO ()
runSomething dflags phase_name pgm args =
- runSomethingFiltered dflags id phase_name pgm args
+ runSomethingFiltered dflags id phase_name pgm args Nothing
runSomethingFiltered
- :: DynFlags -> (String->String) -> String -> String -> [Option] -> IO ()
+ :: DynFlags -> (String->String) -> String -> String -> [Option]
+ -> Maybe [(String,String)] -> IO ()
-runSomethingFiltered dflags filter_fn phase_name pgm args = do
+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
- rc <- builderMainLoop dflags filter_fn pgm real_args
+ rc <- builderMainLoop dflags filter_fn pgm real_args mb_env
case rc of
ExitSuccess{} -> return (rc, False)
ExitFailure n
#if __GLASGOW_HASKELL__ < 603
-builderMainLoop dflags filter_fn pgm real_args = do
+builderMainLoop dflags filter_fn pgm real_args mb_env = do
rawSystem pgm real_args
#else
-builderMainLoop dflags filter_fn pgm real_args = do
+builderMainLoop dflags filter_fn pgm real_args mb_env = do
chan <- newChan
- (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing Nothing
+ (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
projects / ghc-hetmet.git / blobdiff