-----------------------------------------------------------------------------
\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,
runMangle, runSplit, -- [Option] -> IO ()
runAs, runLink, -- [Option] -> IO ()
runMkDLL,
+ runWindres,
touch, -- String -> String -> IO ()
- copy, -- String -> String -> String -> IO ()
- normalisePath, -- FilePath -> FilePath
+ copy,
+ copyWithHeader,
+ getExtraViaCOpts,
-- Temporary-file management
setTmpDir,
cleanTempDirs, cleanTempFiles, cleanTempFilesExcept,
addFilesToClean,
- -- System interface
- system, -- String -> IO ExitCode
-
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.FilePath
+import System.IO
+import SYSTEM_IO_ERROR as IO
+import System.Directory
+import Data.Char
+import Data.Maybe
+import Data.List
#ifndef mingw32_HOST_OS
-#if __GLASGOW_HASKELL__ > 504
import qualified System.Posix.Internals
-#else
-import qualified Posix
-#endif
#else /* Must be Win32 */
-import List ( isPrefixOf )
-import Util ( dropList )
import Foreign
import CString ( CString, peekCString )
#endif
-import Text.Regex
-
-#if __GLASGOW_HASKELL__ < 603
--- rawSystem comes from libghccompat.a in stage1
-import Compat.RawSystem ( rawSystem )
-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 )
+import FastString
import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
-#endif
\end{code}
-- 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
+ installed_bin pgm = top_dir </> pgm
+ installed file = top_dir </> file
+ inplace dir pgm = top_dir </>
+#ifndef darwin_TARGET_OS
+-- Not sure where cPROJECT_DIR makes sense, on Mac OS, building with
+-- xcodebuild, it surely is a *bad* idea! -=chak
+ cPROJECT_DIR </>
+#endif
+ dir </> pgm
; let pkgconfig_path
| am_installed = installed "package.conf"
| 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
+
+ ; tmpdir <- getTemporaryDirectory
+ ; let dflags1 = setTmpDir tmpdir dflags0
-- Check that the package config exists
; config_exists <- doesFileExist pkgconfig_path
-- 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
; let (mkdll_prog, mkdll_args)
| am_installed =
- (pgmPath (installed "gcc-lib/") cMKDLL,
+ (installed "gcc-lib/" </> cMKDLL,
[ Option "--dlltool-name",
- Option (pgmPath (installed "gcc-lib/") "dlltool"),
+ Option (installed "gcc-lib/" </> "dlltool"),
Option "--driver-name",
Option gcc_prog, gcc_b_arg ])
| otherwise = (cMKDLL, [])
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_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
}
= 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")
+ ; am_installed <- doesFileExist (top_dir </> "package.conf")
; return (am_installed, top_dir)
}
where
-- get_proto returns a Unix-format path (relying on getBaseDir to do so too)
get_proto = case mbMinusB of
- Just minusb -> return (normalisePath minusb)
+ Just minusb -> return (normalise minusb)
Nothing
-> do maybe_exec_dir <- getBaseDir -- Get directory of executable
case maybe_exec_dir of -- (only works on Windows;
runCpp :: DynFlags -> [Option] -> IO ()
runCpp dflags args = do
let (p,args0) = pgm_P dflags
- runSomething dflags "C pre-processor" p (args0 ++ args)
+ args1 = args0 ++ args
+ mb_env <- getGccEnv args1
+ runSomethingFiltered dflags id "C pre-processor" p args1 mb_env
runPp :: DynFlags -> [Option] -> IO ()
runPp dflags args = do
runCc :: DynFlags -> [Option] -> IO ()
runCc dflags args = do
let (p,args0) = pgm_c dflags
- runSomethingFiltered dflags cc_filter "C Compiler" p (args0++args)
+ args1 = args0 ++ args
+ mb_env <- getGccEnv args1
+ 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))
+ cc_filter = unlines . doFilter . lines
+
+ {-
+ gcc gives warnings in chunks like so:
+ In file included from /foo/bar/baz.h:11,
+ from /foo/bar/baz2.h:22,
+ from wibble.c:33:
+ /foo/flibble:14: global register variable ...
+ /foo/flibble:15: warning: call-clobbered r...
+ We break it up into its chunks, remove any call-clobbered register
+ warnings from each chunk, and then delete any chunks that we have
+ emptied of warnings.
+ -}
+ doFilter = unChunkWarnings . filterWarnings . chunkWarnings []
+ -- We can't assume that the output will start with an "In file inc..."
+ -- line, so we start off expecting a list of warnings rather than a
+ -- location stack.
+ chunkWarnings :: [String] -- The location stack to use for the next
+ -- list of warnings
+ -> [String] -- The remaining lines to look at
+ -> [([String], [String])]
+ chunkWarnings loc_stack [] = [(loc_stack, [])]
+ chunkWarnings loc_stack xs
+ = case break loc_stack_start xs of
+ (warnings, lss:xs') ->
+ case span loc_start_continuation xs' of
+ (lsc, xs'') ->
+ (loc_stack, warnings) : chunkWarnings (lss : lsc) xs''
+ _ -> [(loc_stack, xs)]
+
+ filterWarnings :: [([String], [String])] -> [([String], [String])]
+ filterWarnings [] = []
+ -- If the warnings are already empty then we are probably doing
+ -- something wrong, so don't delete anything
+ filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs
+ filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of
+ [] -> filterWarnings zs
+ ys' -> (xs, ys') : filterWarnings zs
+
+ unChunkWarnings :: [([String], [String])] -> [String]
+ unChunkWarnings [] = []
+ unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs
+
+ loc_stack_start s = "In file included from " `isPrefixOf` s
+ loc_start_continuation s = " from " `isPrefixOf` s
+ wantedWarning w
+ | "warning: call-clobbered register used" `isContainedIn` w = False
+ | otherwise = True
+
+isContainedIn :: String -> String -> Bool
+xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)
+
+-- If the -B<dir> option is set, add <dir> to PATH. This works around
+-- 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 defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603
+ return Nothing
+#else
+ if null b_dirs
+ then return Nothing
+ else do env <- getEnvironment
+ return (Just (map mangle_path env))
+ where
+ (b_dirs, _) = partitionWith get_b_opt opts
- do_filter [] = []
- do_filter ls@(l:ls')
- | (w:rest) <- dropWhile (isJust .matchRegex r_from) ls,
- isJust (matchRegex r_warn w)
- = do_filter rest
- | otherwise
- = l : do_filter ls'
+ get_b_opt (Option ('-':'B':dir)) = Left dir
+ get_b_opt other = Right other
- r_from = mkRegex "from.*:[0-9]+"
- r_warn = mkRegex "warning: call-clobbered register used"
+ 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
runAs :: DynFlags -> [Option] -> IO ()
runAs dflags args = do
let (p,args0) = pgm_a dflags
- runSomething dflags "Assembler" p (args0++args)
+ args1 = args0 ++ args
+ mb_env <- getGccEnv args1
+ runSomethingFiltered dflags id "Assembler" p args1 mb_env
runLink :: DynFlags -> [Option] -> IO ()
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
let (p,args0) = pgm_dll dflags
- runSomething dflags "Make DLL" p (args0++args)
+ args1 = args0 ++ args
+ 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
+ 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 ++ "\""
touch :: DynFlags -> String -> String -> IO ()
touch dflags purpose arg =
runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
-copy :: DynFlags -> String -> String -> String -> IO ()
-copy dflags purpose from to = do
+copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()
+copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to
+
+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
+
+getExtraViaCOpts :: DynFlags -> IO [String]
+getExtraViaCOpts dflags = do
+ f <- readFile (topDir dflags </> "extra-gcc-opts")
+ return (words f)
\end{code}
%************************************************************************
\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.
= do d <- getTempDir dflags
x <- getProcessID
findTempName (d ++ "/ghc" ++ show x ++ "_") 0
- where
+ 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 consIORef v_FilesToClean filename -- clean it up later
+ return filename
-- return our temporary directory within tmp_dir, creating one if we
-- don't have one yet
Nothing ->
do x <- getProcessID
let prefix = tmp_dir ++ "/ghc" ++ show x ++ "_"
+ let
+ mkTempDir :: Integer -> IO FilePath
mkTempDir x
= let dirname = prefix ++ show x
in do createDirectory dirname
-> 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
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603
+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
hSetBuffering hStdErr LineBuffering
forkIO (readerProc chan hStdOut filter_fn)
forkIO (readerProc chan hStdErr filter_fn)
- rc <- loop chan hProcess 2 1 ExitSuccess
+ -- 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
checkError l ls
checkError l ls
- = case matchRegex errRegex l of
+ = case parseError l of
Nothing -> do
writeChan chan (BuildMsg (text l))
loop ls Nothing
- Just (file':lineno':colno':msg:_) -> do
- let file = mkFastString file'
- lineno = read lineno'::Int
- colno = case colno' of
- "" -> 0
- _ -> read (init colno') :: Int
- srcLoc = mkSrcLoc file lineno colno
+ 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
-errRegex = mkRegex "^([^:]*):([0-9]+):([0-9]+:)?(.*)"
+parseError :: String -> Maybe (String, Int, Int, String)
+parseError s0 = case breakColon s0 of
+ Just (filename, s1) ->
+ case breakIntColon s1 of
+ Just (lineNum, s2) ->
+ case breakIntColon s2 of
+ Just (columnNum, s3) ->
+ Just (filename, lineNum, columnNum, s3)
+ Nothing ->
+ Just (filename, lineNum, 0, s2)
+ Nothing -> Nothing
+ Nothing -> Nothing
+
+breakColon :: String -> Maybe (String, String)
+breakColon xs = case break (':' ==) xs of
+ (ys, _:zs) -> Just (ys, zs)
+ _ -> Nothing
+
+breakIntColon :: String -> Maybe (Int, String)
+breakIntColon xs = case break (':' ==) xs of
+ (ys, _:zs)
+ | not (null ys) && all isAscii ys && all isDigit ys ->
+ Just (read ys, zs)
+ _ -> Nothing
data BuildMessage
= BuildMsg !SDoc
| EOF
#endif
-showOpt (FileOption pre f) = pre ++ platformPath f
-showOpt (Option "") = ""
+showOpt (FileOption pre f) = pre ++ f
showOpt (Option s) = s
traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
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") ->
+ case splitFileName $ takeDirectory d of
+ (d', "bin") -> takeDirectory d'
+ _ -> panic ("Expected \"bin\" in " ++ show s)
+ _ -> panic ("Expected \"ghc.exe\" in " ++ show s)
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
projects / ghc-hetmet.git / blobdiff