X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FSysTools.lhs;h=a76cb53b5d23b2b30b5ea3c3d7da541cba52668b;hp=594407e766d2ec210ffc87bd4f3ab5b07f4e78dd;hb=9bbcd77cf9b66940058dbea1827db594e8ff6d7f;hpb=ee565d464248078a4f2d46f98667aa4fcdc56db4 diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index 594407e..a76cb53 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -19,7 +19,8 @@ module SysTools ( runMkDLL, touch, -- String -> String -> IO () - copy, -- String -> String -> String -> IO () + copy, + copyWithHeader, normalisePath, -- FilePath -> FilePath -- Temporary-file management @@ -28,46 +29,32 @@ module SysTools ( 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.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 @@ -76,24 +63,18 @@ import qualified System.Posix.Internals 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 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 ) import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan ) #endif @@ -429,21 +410,85 @@ 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 option is set, add 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 __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 @@ -458,31 +503,43 @@ runSplit 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 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 + \end{code} %************************************************************************ @@ -499,22 +556,25 @@ GLOBAL_VAR(v_DirsToClean, emptyFM, FiniteMap FilePath FilePath ) \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. @@ -608,17 +668,18 @@ runSomething :: DynFlags -> 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 @@ -650,12 +711,12 @@ runSomethingFiltered dflags filter_fn phase_name pgm args = do #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 @@ -717,23 +778,41 @@ readerProc chan hdl filter_fn = 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