Abstract out the hFlush calls in the GHC API

stdout/stderr might be closed, so we can't just hFlush them.
So we instead allow configuration in the same way that log_action
is configurable.

3 files changed, 25 insertions, 7 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