diff options
| -rw-r--r-- | compiler/main/DynFlags.hs | 20 | ||||
| -rw-r--r-- | compiler/main/GHC.hs | 9 | ||||
| -rw-r--r-- | compiler/main/SysTools.lhs | 3 | ||||
| -rw-r--r-- | ghc/Main.hs | 2 | ||||
| -rw-r--r-- | utils/ghctags/Main.hs | 4 |
5 files changed, 28 insertions, 10 deletions
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 438c56b5ed..93fab1f66e 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -16,7 +16,7 @@ module DynFlags ( DynFlag(..), WarningFlag(..), ExtensionFlag(..), - LogAction, + LogAction, FlushOut(..), FlushErr(..), ProfAuto(..), glasgowExtsFlags, dopt, @@ -62,6 +62,8 @@ module DynFlags ( defaultDynFlags, -- Settings -> DynFlags initDynFlags, -- DynFlags -> IO DynFlags defaultLogAction, + defaultFlushOut, + defaultFlushErr, getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a] getVerbFlags, @@ -129,7 +131,7 @@ import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import System.FilePath -import System.IO ( stderr, hPutChar ) +import System.IO import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet @@ -586,6 +588,8 @@ data DynFlags = DynFlags { -- | MsgDoc output action: use "ErrUtils" instead of this if you can log_action :: LogAction, + flushOut :: FlushOut, + flushErr :: FlushErr, haddockOptions :: Maybe String, @@ -942,6 +946,8 @@ defaultDynFlags mySettings = extensions = [], extensionFlags = flattenExtensionFlags Nothing [], log_action = defaultLogAction, + flushOut = defaultFlushOut, + flushErr = defaultFlushErr, profAuto = NoProfAuto, llvmVersion = panic "defaultDynFlags: No llvmVersion" } @@ -960,6 +966,16 @@ defaultLogAction severity srcSpan style msg -- converting to string first and using hPutStr would -- just emit the low 8 bits of each unicode char. +newtype FlushOut = FlushOut (IO ()) + +defaultFlushOut :: FlushOut +defaultFlushOut = FlushOut $ hFlush stdout + +newtype FlushErr = FlushErr (IO ()) + +defaultFlushErr :: FlushErr +defaultFlushErr = FlushErr $ hFlush stderr + {- Note [Verbosity levels] ~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index d3a8bb11de..c3206aab11 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -323,11 +323,12 @@ import Prelude hiding (init) -- Unless you want to handle exceptions yourself, you should wrap this around -- the top level of your program. The default handlers output the error -- message(s) to stderr and exit cleanly. -defaultErrorHandler :: (ExceptionMonad m, MonadIO m) => LogAction -> m a -> m a -defaultErrorHandler la inner = +defaultErrorHandler :: (ExceptionMonad m, MonadIO m) + => LogAction -> FlushOut -> m a -> m a +defaultErrorHandler la (FlushOut flushOut) inner = -- top-level exception handler: any unrecognised exception is a compiler bug. ghandle (\exception -> liftIO $ do - hFlush stdout + flushOut case fromException exception of -- an IO exception probably isn't our fault, so don't panic Just (ioe :: IOException) -> @@ -347,7 +348,7 @@ defaultErrorHandler la inner = -- error messages propagated as exceptions handleGhcException (\ge -> liftIO $ do - hFlush stdout + flushOut case ge of PhaseFailed _ code -> exitWith code Signal _ -> exitWith (ExitFailure 1) diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index b46ca17f49..5d643f1319 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -922,7 +922,8 @@ traceCmd dflags phase_name cmd_line action = do { let verb = verbosity dflags ; showPass dflags phase_name ; debugTraceMsg dflags 3 (text cmd_line) - ; hFlush stderr + ; case flushErr dflags of + FlushErr io -> io -- And run it! ; action `catchIO` handle_exn verb diff --git a/ghc/Main.hs b/ghc/Main.hs index a1943cff50..38066dbd68 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -78,7 +78,7 @@ import Data.Maybe main :: IO () main = do hSetBuffering stdout NoBuffering - GHC.defaultErrorHandler defaultLogAction $ do + GHC.defaultErrorHandler defaultLogAction defaultFlushOut $ do -- 1. extract the -B flag from the args argv0 <- getArgs diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs index c0e51802a1..ea3300c66a 100644 --- a/utils/ghctags/Main.hs +++ b/utils/ghctags/Main.hs @@ -11,7 +11,7 @@ import HscTypes ( msHsFilePath ) import Name ( getOccString ) --import ErrUtils ( printBagOfErrors ) import Panic ( panic ) -import DynFlags ( defaultLogAction ) +import DynFlags ( defaultLogAction, defaultFlushOut ) import Bag import Exception import FastString @@ -102,7 +102,7 @@ main = do then Just `liftM` openFile "TAGS" openFileMode else return Nothing - GHC.defaultErrorHandler defaultLogAction $ + GHC.defaultErrorHandler defaultLogAction defaultFlushOut $ runGhc (Just ghc_topdir) $ do --liftIO $ print "starting up session" dflags <- getSessionDynFlags |