X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FSysTools.lhs;h=eee3e1a38354a3e6b511288663466fb186dfb66b;hb=1187e57fab2b5904a808ac973e5d04b91f880920;hp=d6ed73743ea7d6d7532a9d5282c1f9a685b419af;hpb=78b72ed1e0ffab668e0d4bb31657942970515e4f;p=ghc-hetmet.git diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs index d6ed737..eee3e1a 100644 --- a/ghc/compiler/main/SysTools.lhs +++ b/ghc/compiler/main/SysTools.lhs @@ -54,16 +54,17 @@ import Util ( Suffix, global, notNull, consIORef, joinFileName, import DynFlags ( DynFlags(..), DynFlag(..), dopt, Option(..), setTmpDir, defaultDynFlags ) -import EXCEPTION ( throwDyn ) +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, +import IO ( try, catch, hGetContents, openFile, hPutStr, hClose, hFlush, IOMode(..), stderr, ioError, isDoesNotExistError ) import Directory ( doesFileExist, removeFile ) +import Maybe ( isJust ) import List ( partition ) -- GHC <= 4.08 didn't have rawSystem, and runs into problems with long command @@ -85,6 +86,8 @@ 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 ) @@ -94,7 +97,6 @@ import System.IO.Error ( ioeGetErrorType ) import System.Process ( runInteractiveProcess, getProcessExitCode ) import System.IO ( hSetBuffering, hGetLine, BufferMode(..) ) import Control.Concurrent( forkIO, newChan, readChan, writeChan ) -import Text.Regex import Data.Char ( isSpace ) import FastString ( mkFastString ) import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan ) @@ -198,7 +200,7 @@ getTopDir = readIORef v_TopDir %************************************************************************ \begin{code} -initSysTools :: [String] -- Command-line arguments starting "-B" +initSysTools :: Maybe String -- Maybe TopDir path (without the '-B' prefix) -> DynFlags -> IO DynFlags -- Set all the mutable variables above, holding @@ -207,8 +209,8 @@ initSysTools :: [String] -- Command-line arguments starting "-B" -- (c) the GHC usage message -initSysTools minusB_args dflags - = do { (am_installed, top_dir) <- findTopDir minusB_args +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 @@ -399,9 +401,8 @@ foreign import stdcall unsafe "GetTempPathA" getTempPath :: Int -> CString -> IO -- -- Plan of action: -- 1. Set proto_top_dir --- a) look for (the last) -B flag, and use it --- b) if there are no -B flags, get the directory --- where GHC is running (only on Windows) +-- 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 @@ -412,11 +413,11 @@ foreign import stdcall unsafe "GetTempPathA" getTempPath :: Int -> CString -> IO -- -- This is very gruesome indeed -findTopDir :: [String] - -> IO (Bool, -- True <=> am installed, False <=> in-place - String) -- TopDir (in Unix format '/' separated) +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 minusbs +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. @@ -426,15 +427,14 @@ findTopDir minusbs } where -- get_proto returns a Unix-format path (relying on getBaseDir to do so too) - get_proto | notNull minusbs - = return (normalisePath (drop 2 (last minusbs))) -- 2 for "-B" - | otherwise - = 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 option") - Just dir -> return dir - } + 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 option") + Just dir -> return dir \end{code} @@ -464,7 +464,21 @@ runPp dflags args = do runCc :: DynFlags -> [Option] -> IO () runCc dflags args = do let (p,args0) = pgm_c dflags - runSomething dflags "C Compiler" p (args0++args) + runSomethingFiltered dflags cc_filter "C Compiler" p (args0++args) + where + -- discard some harmless warnings from gcc that we can't turn off + cc_filter str = unlines (do_filter (lines str)) + + 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' + + r_from = mkRegex "from.*:[0-9]+" + r_warn = mkRegex "warning: call-clobbered register used" runMangle :: DynFlags -> [Option] -> IO () runMangle dflags args = do @@ -601,12 +615,18 @@ runSomething :: DynFlags -- runSomething will dos-ify them -> IO () -runSomething dflags phase_name pgm args = do +runSomething dflags phase_name pgm args = + runSomethingFiltered dflags id phase_name pgm args + +runSomethingFiltered + :: DynFlags -> (String->String) -> String -> String -> [Option] -> IO () + +runSomethingFiltered dflags filter_fn phase_name pgm args = 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 pgm real_args + rc <- builderMainLoop dflags filter_fn pgm real_args case rc of ExitSuccess{} -> return (rc, False) ExitFailure n @@ -638,18 +658,18 @@ runSomething dflags phase_name pgm args = do #if __GLASGOW_HASKELL__ < 603 -builderMainLoop dflags pgm real_args = do +builderMainLoop dflags filter_fn pgm real_args = do rawSystem pgm real_args #else -builderMainLoop dflags pgm real_args = do +builderMainLoop dflags filter_fn pgm real_args = do chan <- newChan (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing Nothing -- 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) - forkIO (readerProc chan hStdErr) + forkIO (readerProc chan hStdOut filter_fn) + forkIO (readerProc chan hStdErr filter_fn) rc <- loop chan hProcess 2 1 ExitSuccess hClose hStdIn hClose hStdOut @@ -682,30 +702,33 @@ builderMainLoop dflags pgm real_args = do loop chan hProcess (t-1) p exitcode | otherwise -> loop chan hProcess t p exitcode -readerProc chan hdl = loop Nothing `catch` \e -> writeChan chan EOF +readerProc chan hdl filter_fn = + (do str <- hGetContents hdl + loop (lines (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. where - loop in_err = do - l <- hGetLine hdl `catch` \e -> do - case in_err of - Just err -> writeChan chan err - Nothing -> return () - ioError e + 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 (Just (BuildError srcLoc (msg $$ text l))) + loop ls (Just (BuildError srcLoc (msg $$ text l))) | otherwise -> do writeChan chan err - checkError l + checkError l ls Nothing -> do - checkError l + checkError l ls - checkError l + checkError l ls = case matchRegex errRegex l of Nothing -> do writeChan chan (BuildMsg (text l)) - loop Nothing + loop ls Nothing Just (file':lineno':colno':msg:_) -> do let file = mkFastString file' lineno = read lineno'::Int @@ -713,10 +736,10 @@ readerProc chan hdl = loop Nothing `catch` \e -> writeChan chan EOF "" -> 0 _ -> read (init colno') :: Int srcLoc = mkSrcLoc file lineno colno - loop (Just (BuildError srcLoc (text msg))) + loop ls (Just (BuildError srcLoc (text msg))) - leading_whitespace [] = False - leading_whitespace (x:_) = isSpace x + leading_whitespace [] = False + leading_whitespace (x:_) = isSpace x errRegex = mkRegex "^([^:]*):([0-9]+):([0-9]+:)?(.*)"