Commit 5716a2f8 authored by Ian Lynagh's avatar Ian Lynagh

Pass DynFlags to the LogAction

A side-effect is that we can no longer use the LogAction in
defaultErrorHandler, as we don't have DynFlags at that point.
But all that defaultErrorHandler did is to print Strings as
SevFatal, so now it takes a 'FatalMessager' instead.
parent 65152943
......@@ -110,7 +110,7 @@ addTicksToBinds dflags mod mod_loc exports tyCons binds =
modBreaks <- mkModBreaks count entries
doIfSet_dyn dflags Opt_D_dump_ticked $
log_action dflags SevDump noSrcSpan defaultDumpStyle
log_action dflags dflags SevDump noSrcSpan defaultDumpStyle
(pprLHsBinds binds1)
return (binds1, HpcInfo count hashNo, modBreaks)
......
......@@ -163,7 +163,7 @@ showTerm term = do
-- XXX: this tries to disable logging of errors
-- does this still do what it is intended to do
-- with the changed error handling and logging?
let noop_log _ _ _ _ = return ()
let noop_log _ _ _ _ _ = return ()
expr = "show " ++ showSDoc (ppr bname)
_ <- GHC.setSessionDynFlags dflags{log_action=noop_log}
txt_ <- withExtendedLinkEnv [(bname, val)]
......
......@@ -238,7 +238,7 @@ filterNameMap mods env
showLinkerState :: DynFlags -> IO ()
showLinkerState dflags
= do pls <- readIORef v_PersistentLinkerState >>= readMVar
log_action dflags SevDump noSrcSpan defaultDumpStyle
log_action dflags dflags SevDump noSrcSpan defaultDumpStyle
(vcat [text "----- Linker state -----",
text "Pkgs:" <+> ppr (pkgs_loaded pls),
text "Objs:" <+> ppr (objs_loaded pls),
......@@ -330,7 +330,7 @@ classifyLdInput dflags f
| isObjectFilename f = return (Just (Object f))
| isDynLibFilename f = return (Just (DLLPath f))
| otherwise = do
log_action dflags SevInfo noSrcSpan defaultUserStyle
log_action dflags dflags SevInfo noSrcSpan defaultUserStyle
(text ("Warning: ignoring unrecognised input `" ++ f ++ "'"))
return Nothing
......
......@@ -86,7 +86,7 @@ readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath
readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
let printer :: SDoc -> IO ()
printer = case traceBinIFaceReading of
TraceBinIFaceReading -> \sd -> log_action dflags SevOutput noSrcSpan defaultDumpStyle sd
TraceBinIFaceReading -> \sd -> log_action dflags dflags SevOutput noSrcSpan defaultDumpStyle sd
QuietBinIFaceReading -> \_ -> return ()
wantedGot :: Outputable a => String -> a -> a -> IO ()
wantedGot what wanted got =
......
......@@ -645,7 +645,7 @@ showIface hsc_env filename = do
iface <- initTcRnIf 's' hsc_env () () $
readBinIface IgnoreHiWay TraceBinIFaceReading filename
let dflags = hsc_dflags hsc_env
log_action dflags SevDump noSrcSpan defaultDumpStyle (pprModIface iface)
log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (pprModIface iface)
\end{code}
\begin{code}
......
......@@ -57,7 +57,7 @@ codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC
{ showPass dflags "CmmLint"
; let lints = map (cmmLint (targetPlatform dflags)) flat_abstractC
; case firstJusts lints of
Just err -> do { log_action dflags SevDump noSrcSpan defaultDumpStyle err
Just err -> do { log_action dflags dflags SevDump noSrcSpan defaultDumpStyle err
; ghcExit dflags 1
}
Nothing -> return ()
......
......@@ -1493,7 +1493,7 @@ mkExtraObjToLinkIntoBinary dflags = do
_ -> True
when (dopt Opt_NoHsMain dflags && have_rts_opts_flags) $ do
log_action dflags SevInfo noSrcSpan defaultUserStyle
log_action dflags dflags SevInfo noSrcSpan defaultUserStyle
(text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$
text " Call hs_init_ghc() from your main() function to set these options.")
......
......@@ -17,7 +17,7 @@ module DynFlags (
WarningFlag(..),
ExtensionFlag(..),
Language(..),
LogAction, FlushOut(..), FlushErr(..),
FatalMessager, LogAction, FlushOut(..), FlushErr(..),
ProfAuto(..),
glasgowExtsFlags,
dopt,
......@@ -67,6 +67,7 @@ module DynFlags (
-- ** Manipulating DynFlags
defaultDynFlags, -- Settings -> DynFlags
initDynFlags, -- DynFlags -> IO DynFlags
defaultFatalMessager,
defaultLogAction,
defaultLogActionHPrintDoc,
defaultFlushOut,
......@@ -965,10 +966,14 @@ defaultDynFlags mySettings =
llvmVersion = panic "defaultDynFlags: No llvmVersion"
}
type LogAction = Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
type FatalMessager = String -> IO ()
type LogAction = DynFlags -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
defaultFatalMessager :: FatalMessager
defaultFatalMessager = hPutStrLn stderr
defaultLogAction :: LogAction
defaultLogAction severity srcSpan style msg
defaultLogAction _ severity srcSpan style msg
= case severity of
SevOutput -> printSDoc msg style
SevDump -> hPrintDump stdout msg
......@@ -1005,7 +1010,7 @@ printInfoForUser = printSevForUser SevInfo
printSevForUser :: Severity -> DynFlags -> PrintUnqualified -> SDoc -> IO ()
printSevForUser sev dflags unqual doc
= log_action dflags sev noSrcSpan (mkUserStyle unqual AllTheWay) doc
= log_action dflags dflags sev noSrcSpan (mkUserStyle unqual AllTheWay) doc
{-
Note [Verbosity levels]
......
......@@ -25,7 +25,7 @@ module ErrUtils (
-- * Messages during compilation
putMsg, putMsgWith,
errorMsg,
fatalErrorMsg, fatalErrorMsg',
fatalErrorMsg, fatalErrorMsg', fatalErrorMsg'',
compilationProgressMsg,
showPass,
debugTraceMsg,
......@@ -165,7 +165,7 @@ pprLocErrMsg (ErrMsg { errMsgSpans = spans
printMsgBag :: DynFlags -> Bag ErrMsg -> IO ()
printMsgBag dflags bag
= sequence_ [ let style = mkErrStyle unqual
in log_action dflags sev s style (d $$ e)
in log_action dflags dflags sev s style (d $$ e)
| ErrMsg { errMsgSpans = s:_,
errMsgShortDoc = d,
errMsgSeverity = sev,
......@@ -201,7 +201,7 @@ doIfSet_dyn dflags flag action | dopt flag dflags = action
dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO ()
dumpIfSet dflags flag hdr doc
| not flag = return ()
| otherwise = log_action dflags SevDump noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc)
| otherwise = log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc)
dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn dflags flag hdr doc
......@@ -252,7 +252,7 @@ dumpSDoc dflags dflag hdr doc
-- write the dump to stdout
Nothing
-> log_action dflags SevDump noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc)
-> log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc)
-- | Choose where to put a dump file based on DynFlags
......@@ -305,34 +305,37 @@ ifVerbose dflags val act
| otherwise = return ()
putMsg :: DynFlags -> MsgDoc -> IO ()
putMsg dflags msg = log_action dflags SevInfo noSrcSpan defaultUserStyle msg
putMsg dflags msg = log_action dflags dflags SevInfo noSrcSpan defaultUserStyle msg
putMsgWith :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
putMsgWith dflags print_unqual msg
= log_action dflags SevInfo noSrcSpan sty msg
= log_action dflags dflags SevInfo noSrcSpan sty msg
where
sty = mkUserStyle print_unqual AllTheWay
errorMsg :: DynFlags -> MsgDoc -> IO ()
errorMsg dflags msg = log_action dflags SevError noSrcSpan defaultErrStyle msg
errorMsg dflags msg = log_action dflags dflags SevError noSrcSpan defaultErrStyle msg
fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) msg
fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) dflags msg
fatalErrorMsg' :: LogAction -> MsgDoc -> IO ()
fatalErrorMsg' la msg = la SevFatal noSrcSpan defaultErrStyle msg
fatalErrorMsg' :: LogAction -> DynFlags -> MsgDoc -> IO ()
fatalErrorMsg' la dflags msg = la dflags SevFatal noSrcSpan defaultErrStyle msg
fatalErrorMsg'' :: FatalMessager -> String -> IO ()
fatalErrorMsg'' fm msg = fm msg
compilationProgressMsg :: DynFlags -> String -> IO ()
compilationProgressMsg dflags msg
= ifVerbose dflags 1 (log_action dflags SevOutput noSrcSpan defaultUserStyle (text msg))
= ifVerbose dflags 1 (log_action dflags dflags SevOutput noSrcSpan defaultUserStyle (text msg))
showPass :: DynFlags -> String -> IO ()
showPass dflags what
= ifVerbose dflags 2 (log_action dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon))
= ifVerbose dflags 2 (log_action dflags dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon))
debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
debugTraceMsg dflags val msg
= ifVerbose dflags val (log_action dflags SevInfo noSrcSpan defaultDumpStyle msg)
= ifVerbose dflags val (log_action dflags dflags SevInfo noSrcSpan defaultDumpStyle msg)
prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
prettyPrintGhcErrors _
......
......@@ -334,24 +334,24 @@ import Prelude hiding (init)
-- 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 -> FlushOut -> m a -> m a
defaultErrorHandler la (FlushOut flushOut) inner =
=> FatalMessager -> FlushOut -> m a -> m a
defaultErrorHandler fm (FlushOut flushOut) inner =
-- top-level exception handler: any unrecognised exception is a compiler bug.
ghandle (\exception -> liftIO $ do
flushOut
case fromException exception of
-- an IO exception probably isn't our fault, so don't panic
Just (ioe :: IOException) ->
fatalErrorMsg' la (text (show ioe))
fatalErrorMsg'' fm (show ioe)
_ -> case fromException exception of
Just UserInterrupt -> exitWith (ExitFailure 1)
Just StackOverflow ->
fatalErrorMsg' la (text "stack overflow: use +RTS -K<size> to increase it")
fatalErrorMsg'' fm "stack overflow: use +RTS -K<size> to increase it"
_ -> case fromException exception of
Just (ex :: ExitCode) -> throw ex
_ ->
fatalErrorMsg' la
(text (show (Panic (show exception))))
fatalErrorMsg'' fm
(show (Panic (show exception)))
exitWith (ExitFailure 1)
) $
......@@ -362,7 +362,7 @@ defaultErrorHandler la (FlushOut flushOut) inner =
case ge of
PhaseFailed _ code -> exitWith code
Signal _ -> exitWith (ExitFailure 1)
_ -> do fatalErrorMsg' la (text (show ge))
_ -> do fatalErrorMsg'' fm (show ge)
exitWith (ExitFailure 1)
) $
inner
......
......@@ -851,10 +851,10 @@ builderMainLoop dflags filter_fn pgm real_args mb_env = do
msg <- readChan chan
case msg of
BuildMsg msg -> do
log_action dflags SevInfo noSrcSpan defaultUserStyle msg
log_action dflags dflags SevInfo noSrcSpan defaultUserStyle msg
loop chan hProcess t p exitcode
BuildError loc msg -> do
log_action dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
log_action dflags dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
loop chan hProcess t p exitcode
EOF ->
loop chan hProcess (t-1) p exitcode
......
......@@ -380,7 +380,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
-- Print one-line size info
; let cs = coreBindsStats tidy_binds
; when (dopt Opt_D_dump_core_stats dflags)
(log_action dflags SevDump noSrcSpan defaultDumpStyle
(log_action dflags dflags SevDump noSrcSpan defaultDumpStyle
(ptext (sLit "Tidy size (terms,types,coercions)")
<+> ppr (moduleName mod) <> colon
<+> int (cs_tm cs)
......
......@@ -189,7 +189,7 @@ displayLintResults :: DynFlags -> CoreToDo
-> IO ()
displayLintResults dflags pass warns errs binds
| not (isEmptyBag errs)
= do { log_action dflags Err.SevDump noSrcSpan defaultDumpStyle
= do { log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle
(vcat [ banner "errors", Err.pprMessageBag errs
, ptext (sLit "*** Offending Program ***")
, pprCoreBindings binds
......@@ -204,7 +204,7 @@ displayLintResults dflags pass warns errs binds
-- group. Only afer a round of simplification are they unravelled.
, not opt_NoDebugOutput
, showLintWarnings pass
= log_action dflags Err.SevDump noSrcSpan defaultDumpStyle
= log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle
(banner "warnings" $$ Err.pprMessageBag warns)
| otherwise = return ()
......
......@@ -429,7 +429,7 @@ ruleCheckPass current_phase pat guts = do
rb <- getRuleBase
dflags <- getDynFlags
liftIO $ Err.showPass dflags "RuleCheck"
liftIO $ log_action dflags Err.SevDump noSrcSpan defaultDumpStyle
liftIO $ log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle
(ruleCheckProgram current_phase pat rb (mg_binds guts))
return guts
......
......@@ -46,7 +46,7 @@ stg2stg dflags module_name binds
; us <- mkSplitUniqSupply 'g'
; doIfSet_dyn dflags Opt_D_verbose_stg2stg
(log_action dflags SevDump noSrcSpan defaultDumpStyle (text "VERBOSE STG-TO-STG:"))
(log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (text "VERBOSE STG-TO-STG:"))
; (binds', us', ccs) <- end_pass us "Stg2Stg" ([],[],[]) binds
......
......@@ -1226,7 +1226,7 @@ failIfM msg
= do { env <- getLclEnv
; let full_msg = (if_loc env <> colon) $$ nest 2 msg
; dflags <- getDynFlags
; liftIO (log_action dflags SevFatal noSrcSpan defaultErrStyle full_msg)
; liftIO (log_action dflags dflags SevFatal noSrcSpan defaultErrStyle full_msg)
; failM }
--------------------
......@@ -1257,7 +1257,7 @@ forkM_maybe doc thing_inside
dflags <- getDynFlags
let msg = hang (text "forkM failed:" <+> doc)
2 (text (show exn))
liftIO $ log_action dflags SevFatal noSrcSpan defaultErrStyle msg
liftIO $ log_action dflags dflags SevFatal noSrcSpan defaultErrStyle msg
; traceIf (text "} ending fork (badly)" <+> doc)
; return Nothing }
......
......@@ -79,7 +79,7 @@ main :: IO ()
main = do
hSetBuffering stdout NoBuffering
hSetBuffering stderr NoBuffering
GHC.defaultErrorHandler defaultLogAction defaultFlushOut $ do
GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
-- 1. extract the -B flag from the args
argv0 <- getArgs
......
......@@ -11,7 +11,7 @@ import HscTypes ( msHsFilePath )
import Name ( getOccString )
--import ErrUtils ( printBagOfErrors )
import Panic ( panic )
import DynFlags ( defaultLogAction, defaultFlushOut )
import DynFlags ( defaultFatalMessager, defaultFlushOut )
import Bag
import Exception
import FastString
......@@ -105,7 +105,7 @@ main = do
then Just `liftM` openFile "TAGS" openFileMode
else return Nothing
GHC.defaultErrorHandler defaultLogAction defaultFlushOut $
GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $
runGhc (Just ghc_topdir) $ do
--liftIO $ print "starting up session"
dflags <- getSessionDynFlags
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment