import DriverPhases ( isHaskellUserSrcFilename )
import Config
import Outputable
-import ErrUtils ( putMsg, debugTraceMsg )
+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 )
+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
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.Cmd ( rawSystem )
+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
\end{code}
%************************************************************************
\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
-- (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
--
-- 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
--
-- 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.
}
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<dir> 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<dir> option")
+ Just dir -> return dir
\end{code}
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
copy :: DynFlags -> String -> String -> String -> IO ()
copy dflags purpose from to = do
- debugTraceMsg dflags 2 ("*** " ++ purpose)
+ showPass dflags purpose
h <- openFile to WriteMode
ls <- readFile from -- inefficient, but it'll do for now.
warnNon act
| null non_deletees = act
| otherwise = do
- putMsg ("WARNING - NOT deleting source files: " ++ unwords non_deletees)
+ putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
act
(non_deletees, deletees) = partition isHaskellUserSrcFilename fs
rm f = removeFile f `IO.catch`
(\_ignored ->
- debugTraceMsg dflags 2 ("Warning: deleting non-existent " ++ f)
+ debugTraceMsg dflags 2 (ptext SLIT("Warning: deleting non-existent") <+> text f)
)
-- 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 <- rawSystem pgm real_args
+ rc <- builderMainLoop dflags filter_fn pgm real_args
case rc of
ExitSuccess{} -> return (rc, False)
ExitFailure n
(_, ExitSuccess) -> return ()
_ -> throwDyn (PhaseFailed phase_name exit_code)
+
+
+#if __GLASGOW_HASKELL__ < 603
+builderMainLoop dflags filter_fn pgm real_args = do
+ rawSystem pgm real_args
+#else
+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 filter_fn)
+ forkIO (readerProc chan hStdErr filter_fn)
+ rc <- loop chan hProcess 2 1 ExitSuccess
+ hClose hStdIn
+ hClose hStdOut
+ hClose hStdErr
+ return rc
+ where
+ -- status starts at zero, and increments each time either
+ -- a reader process gets EOF, or the build proc exits. We wait
+ -- for all of these to happen (status==3).
+ -- ToDo: we should really have a contingency plan in case any of
+ -- the threads dies, such as a timeout.
+ loop chan hProcess 0 0 exitcode = return exitcode
+ loop chan hProcess t p exitcode = do
+ mb_code <- if p > 0
+ then getProcessExitCode hProcess
+ else return Nothing
+ case mb_code of
+ Just code -> loop chan hProcess t (p-1) code
+ Nothing
+ | t > 0 -> do
+ msg <- readChan chan
+ case msg of
+ BuildMsg msg -> do
+ log_action dflags SevInfo noSrcSpan defaultUserStyle msg
+ loop chan hProcess t p exitcode
+ BuildError loc msg -> do
+ log_action dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
+ loop chan hProcess t p exitcode
+ EOF ->
+ loop chan hProcess (t-1) p exitcode
+ | otherwise -> loop chan hProcess t p exitcode
+
+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 [] 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 ls (Just (BuildError srcLoc (msg $$ text l)))
+ | otherwise -> do
+ writeChan chan err
+ checkError l ls
+ Nothing -> do
+ checkError l ls
+
+ checkError l ls
+ = case matchRegex errRegex 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
+ loop ls (Just (BuildError srcLoc (text msg)))
+
+ leading_whitespace [] = False
+ leading_whitespace (x:_) = isSpace x
+
+errRegex = mkRegex "^([^:]*):([0-9]+):([0-9]+:)?(.*)"
+
+data BuildMessage
+ = BuildMsg !SDoc
+ | BuildError !SrcLoc !SDoc
+ | EOF
+#endif
+
showOpt (FileOption pre f) = pre ++ platformPath f
showOpt (Option "") = ""
showOpt (Option s) = s
-- b) don't do it at all if dry-run is set
traceCmd dflags phase_name cmd_line action
= do { let verb = verbosity dflags
- ; debugTraceMsg dflags 2 ("*** " ++ phase_name)
- ; debugTraceMsg dflags 3 cmd_line
+ ; showPass dflags phase_name
+ ; debugTraceMsg dflags 3 (text cmd_line)
; hFlush stderr
-- Test for -n flag
; action `IO.catch` handle_exn verb
}}
where
- handle_exn verb exn = do { debugTraceMsg dflags 2 "\n"
- ; debugTraceMsg dflags 2 ("Failed: " ++ cmd_line ++ (show exn))
+ handle_exn verb exn = do { debugTraceMsg dflags 2 (char '\n')
+ ; debugTraceMsg dflags 2 (ptext SLIT("Failed:") <+> text cmd_line <+> text (show exn))
; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
\end{code}