filter the messages generated by gcc

Eliminate things like "warning: call-clobbered register used as global
register variable", which is an non-suppressible warning from gcc.

1 files changed, 48 insertions, 24 deletions

diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs
index 05153ceb82..5c434d0db3 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
@@ -462,7 +463,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 
@@ -599,12 +614,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 
@@ -636,18 +657,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
@@ -680,30 +701,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
@@ -711,10 +735,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]+:)?(.*)"