diff options
| author | Sylvain Henry <sylvain@haskus.fr> | 2017-02-02 14:37:24 -0500 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2017-02-02 22:13:53 -0500 |
| commit | bbd3c399939311ec3e308721ab87ca6b9443f358 (patch) | |
| tree | 1a398f3857502ab42f350008f83b7c67f0d9ff1e /compiler/main/ErrUtils.hs | |
| parent | 6128b2ffbe36ed2779583e05ee9d817eaafc1c9c (diff) | |
| download | haskell-bbd3c399939311ec3e308721ab87ca6b9443f358.tar.gz | |
Ditch static flags
This patch converts the 4 lasting static flags (read from the command
line and unsafely stored in immutable global variables) into dynamic
flags. Most use cases have been converted into reading them from a DynFlags.
In cases for which we don't have easy access to a DynFlags, we read from
'unsafeGlobalDynFlags' that is set at the beginning of each 'runGhc'.
It's not perfect (not thread-safe) but it is still better as we can
set/unset these 4 flags before each run when using GHC API.
Updates haddock submodule.
Rebased and finished by: bgamari
Test Plan: validate
Reviewers: goldfire, erikd, hvr, austin, simonmar, bgamari
Reviewed By: simonmar
Subscribers: thomie
Differential Revision: https://phabricator.haskell.org/D2839
GHC Trac Issues: #8440
Diffstat (limited to 'compiler/main/ErrUtils.hs')
| -rw-r--r-- | compiler/main/ErrUtils.hs | 21 |
1 files changed, 10 insertions, 11 deletions
diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs index 2aeddc26a7..94ea96e59a 100644 --- a/compiler/main/ErrUtils.hs +++ b/compiler/main/ErrUtils.hs @@ -410,7 +410,7 @@ dumpIfSet dflags flag hdr doc NoReason SevDump noSrcSpan - defaultDumpStyle + (defaultDumpStyle dflags) (mkDumpDoc hdr doc) -- | a wrapper around 'dumpSDoc'. @@ -453,7 +453,7 @@ mkDumpDoc hdr doc dumpSDoc :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO () dumpSDoc dflags print_unqual flag hdr doc = do let mFile = chooseDumpFile dflags flag - dump_style = mkDumpStyle print_unqual + dump_style = mkDumpStyle dflags print_unqual case mFile of Just fileName -> do @@ -563,12 +563,12 @@ fatalErrorMsg'' fm msg = fm msg compilationProgressMsg :: DynFlags -> String -> IO () compilationProgressMsg dflags msg = ifVerbose dflags 1 $ - logOutput dflags defaultUserStyle (text msg) + logOutput dflags (defaultUserStyle dflags) (text msg) showPass :: DynFlags -> String -> IO () showPass dflags what = ifVerbose dflags 2 $ - logInfo dflags defaultUserStyle (text "***" <+> text what <> colon) + logInfo dflags (defaultUserStyle dflags) (text "***" <+> text what <> colon) -- | Time a compilation phase. -- @@ -602,7 +602,7 @@ withTiming :: MonadIO m withTiming getDFlags what force_result action = do dflags <- getDFlags if verbosity dflags >= 2 - then do liftIO $ logInfo dflags defaultUserStyle + then do liftIO $ logInfo dflags (defaultUserStyle dflags) $ text "***" <+> what <> colon alloc0 <- liftIO getAllocationCounter start <- liftIO getCPUTime @@ -612,7 +612,7 @@ withTiming getDFlags what force_result action alloc1 <- liftIO getAllocationCounter -- recall that allocation counter counts down let alloc = alloc0 - alloc1 - liftIO $ logInfo dflags defaultUserStyle + liftIO $ logInfo dflags (defaultUserStyle dflags) (text "!!!" <+> what <> colon <+> text "finished in" <+> doublePrec 2 (realToFrac (end - start) * 1e-9) <+> text "milliseconds" @@ -625,18 +625,17 @@ withTiming getDFlags what force_result action debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO () debugTraceMsg dflags val msg = ifVerbose dflags val $ - logInfo dflags defaultDumpStyle msg - + logInfo dflags (defaultDumpStyle dflags) msg putMsg :: DynFlags -> MsgDoc -> IO () -putMsg dflags msg = logInfo dflags defaultUserStyle msg +putMsg dflags msg = logInfo dflags (defaultUserStyle dflags) msg printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO () printInfoForUser dflags print_unqual msg - = logInfo dflags (mkUserStyle print_unqual AllTheWay) msg + = logInfo dflags (mkUserStyle dflags print_unqual AllTheWay) msg printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO () printOutputForUser dflags print_unqual msg - = logOutput dflags (mkUserStyle print_unqual AllTheWay) msg + = logOutput dflags (mkUserStyle dflags print_unqual AllTheWay) msg logInfo :: DynFlags -> PprStyle -> MsgDoc -> IO () logInfo dflags sty msg |