Commit bbd3c399 authored by Sylvain Henry's avatar Sylvain Henry Committed by Ben Gamari

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
parent 6128b2ff
......@@ -508,9 +508,9 @@ mkBackpackMsg = do
-- | 'PprStyle' for Backpack messages; here we usually want the module to
-- be qualified (so we can tell how it was instantiated.) But we try not
-- to qualify packages so we can use simple names for them.
backpackStyle :: PprStyle
backpackStyle =
mkUserStyle
backpackStyle :: DynFlags -> PprStyle
backpackStyle dflags =
mkUserStyle dflags
(QueryQualify neverQualifyNames
alwaysQualifyModules
neverQualifyPackages) AllTheWay
......@@ -529,7 +529,8 @@ msgUnitId pk = do
dflags <- getDynFlags
level <- getBkpLevel
liftIO . backpackProgressMsg level dflags
$ "Instantiating " ++ renderWithStyle dflags (ppr pk) backpackStyle
$ "Instantiating " ++ renderWithStyle dflags (ppr pk)
(backpackStyle dflags)
-- | Message when we include a Backpack unit.
msgInclude :: (Int,Int) -> UnitId -> BkpM ()
......@@ -538,7 +539,7 @@ msgInclude (i,n) uid = do
level <- getBkpLevel
liftIO . backpackProgressMsg level dflags
$ showModuleIndex (i, n) ++ "Including " ++
renderWithStyle dflags (ppr uid) backpackStyle
renderWithStyle dflags (ppr uid) (backpackStyle dflags)
-- ----------------------------------------------------------------------------
-- Conversion from PackageName to HsComponentId
......
......@@ -109,7 +109,6 @@ module BasicTypes(
import FastString
import Outputable
import SrcLoc ( Located,unLoc )
import StaticFlags( opt_PprStyle_Debug )
import Data.Data hiding (Fixity, Prefix, Infix)
import Data.Function (on)
......@@ -739,8 +738,9 @@ tupleParens :: TupleSort -> SDoc -> SDoc
tupleParens BoxedTuple p = parens p
tupleParens UnboxedTuple p = text "(#" <+> p <+> ptext (sLit "#)")
tupleParens ConstraintTuple p -- In debug-style write (% Eq a, Ord b %)
| opt_PprStyle_Debug = text "(%" <+> p <+> ptext (sLit "%)")
| otherwise = parens p
= sdocWithPprDebug $ \dbg -> if dbg
then text "(%" <+> p <+> ptext (sLit "%)")
else parens p
{-
************************************************************************
......
......@@ -116,6 +116,7 @@ module Id (
#include "HsVersions.h"
import DynFlags
import CoreSyn ( CoreRule, evaldUnfolding, Unfolding( NoUnfolding ) )
import IdInfo
......@@ -147,7 +148,6 @@ import Unique
import UniqSupply
import FastString
import Util
import StaticFlags
-- infixl so you can say (id `set` a `set` b)
infixl 1 `setIdUnfolding`,
......@@ -771,7 +771,7 @@ typeOneShot ty
isStateHackType :: Type -> Bool
isStateHackType ty
| opt_NoStateHack
| hasNoStateHack unsafeGlobalDynFlags
= False
| otherwise
= case tyConAppTyCon_maybe ty of
......
......@@ -77,7 +77,6 @@ import Outputable
import Unique
import UniqFM
import Util
import StaticFlags( opt_PprStyle_Debug )
import NameEnv
import Data.Data
......@@ -1191,8 +1190,9 @@ pprNameProvenance :: GlobalRdrElt -> SDoc
-- ^ Print out one place where the name was define/imported
-- (With -dppr-debug, print them all)
pprNameProvenance (GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss })
| opt_PprStyle_Debug = vcat pp_provs
| otherwise = head pp_provs
= sdocWithPprDebug $ \dbg -> if dbg
then vcat pp_provs
else head pp_provs
where
pp_provs = pp_lcl ++ map pp_is iss
pp_lcl = if lcl then [text "defined at" <+> ppr (nameSrcLoc name)]
......
......@@ -82,7 +82,6 @@ import Unique
import Util
import Maybes
import Outputable
import StaticFlags
{-
************************************************************************
......@@ -180,13 +179,14 @@ uniqAway' (InScope set n) var
orig_unique = getUnique var
try k
| debugIsOn && (k > 1000)
= pprPanic "uniqAway loop:" (ppr k <+> text "tries" <+> ppr var <+> int n)
= pprPanic "uniqAway loop:" msg
| uniq `elemVarSetByKey` set = try (k + 1)
| debugIsOn && opt_PprStyle_Debug && (k > 3)
= pprTrace "uniqAway:" (ppr k <+> text "tries" <+> ppr var <+> int n)
| k > 3
= pprTraceDebug "uniqAway:" msg
setVarUnique var uniq
| otherwise = setVarUnique var uniq
where
msg = ppr k <+> text "tries" <+> ppr var <+> int n
uniq = deriveUnique orig_unique (n * k)
{-
......
......@@ -239,7 +239,6 @@ import Unique
import UniqFM
import SrcLoc
import DynFlags
import StaticFlags
import ErrUtils
import StringBuffer
import FastString
......
......@@ -50,7 +50,6 @@ import TyCon
import CoAxiom
import BasicTypes
import ErrUtils as Err
import StaticFlags
import ListSetOps
import PrelNames
import Outputable
......@@ -305,7 +304,8 @@ displayLintResults :: DynFlags -> CoreToDo
-> IO ()
displayLintResults dflags pass warns errs binds
| not (isEmptyBag errs)
= do { log_action dflags dflags NoReason Err.SevDump noSrcSpan defaultDumpStyle
= do { log_action dflags dflags NoReason Err.SevDump noSrcSpan
(defaultDumpStyle dflags)
(vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs
, text "*** Offending Program ***"
, pprCoreBindings binds
......@@ -313,9 +313,10 @@ displayLintResults dflags pass warns errs binds
; Err.ghcExit dflags 1 }
| not (isEmptyBag warns)
, not opt_NoDebugOutput
, not (hasNoDebugOutput dflags)
, showLintWarnings pass
= log_action dflags dflags NoReason Err.SevDump noSrcSpan defaultDumpStyle
= log_action dflags dflags NoReason Err.SevDump noSrcSpan
(defaultDumpStyle dflags)
(lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag warns)
| otherwise = return ()
......@@ -346,7 +347,7 @@ lintInteractiveExpr what hsc_env expr
display_lint_err err
= do { log_action dflags dflags NoReason Err.SevDump
noSrcSpan defaultDumpStyle
noSrcSpan (defaultDumpStyle dflags)
(vcat [ lint_banner "errors" (text what)
, err
, text "*** Offending Program ***"
......@@ -1933,9 +1934,10 @@ addMsg env msgs msg
locs = le_loc env
(loc, cxt1) = dumpLoc (head locs)
cxts = [snd (dumpLoc loc) | loc <- locs]
context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 $$
text "Substitution:" <+> ppr (le_subst env)
| otherwise = cxt1
context = sdocWithPprDebug $ \dbg -> if dbg
then vcat (reverse cxts) $$ cxt1 $$
text "Substitution:" <+> ppr (le_subst env)
else cxt1
mk_msg msg = mkLocMessage SevWarning (mkSrcSpan loc loc) (context $$ msg)
......@@ -2383,7 +2385,7 @@ lintAnnots pname pass guts = do
when (not (null diffs)) $ CoreMonad.putMsg $ vcat
[ lint_banner "warning" pname
, text "Core changes with annotations:"
, withPprStyle defaultDumpStyle $ nest 2 $ vcat diffs
, withPprStyle (defaultDumpStyle dflags) $ nest 2 $ vcat diffs
]
-- Return actual new guts
return nguts
......
......@@ -111,8 +111,8 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds
modBreaks <- mkModBreaks hsc_env mod tickCount entries
when (dopt Opt_D_dump_ticked dflags) $
log_action dflags dflags NoReason SevDump noSrcSpan defaultDumpStyle
(pprLHsBinds binds1)
log_action dflags dflags NoReason SevDump noSrcSpan
(defaultDumpStyle dflags) (pprLHsBinds binds1)
return (binds1, HpcInfo tickCount hashNo, Just modBreaks)
......
......@@ -353,7 +353,6 @@ Library
Plugins
TcPluginM
PprTyThing
StaticFlags
StaticPtrTable
SysTools
SysTools.Terminal
......
......@@ -531,7 +531,6 @@ compiler_stage2_dll0_MODULES = \
RdrName \
Rules \
SrcLoc \
StaticFlags \
StringBuffer \
SysTools.Terminal \
TcEvidence \
......
......@@ -243,7 +243,8 @@ withExtendedLinkEnv new_env action
showLinkerState :: DynFlags -> IO ()
showLinkerState dflags
= do pls <- readIORef v_PersistentLinkerState >>= readMVar
log_action dflags dflags NoReason SevDump noSrcSpan defaultDumpStyle
log_action dflags dflags NoReason SevDump noSrcSpan
(defaultDumpStyle dflags)
(vcat [text "----- Linker state -----",
text "Pkgs:" <+> ppr (pkgs_loaded pls),
text "Objs:" <+> ppr (objs_loaded pls),
......@@ -382,7 +383,8 @@ classifyLdInput dflags f
| isObjectFilename platform f = return (Just (Object f))
| isDynLibFilename platform f = return (Just (DLLPath f))
| otherwise = do
log_action dflags dflags NoReason SevInfo noSrcSpan defaultUserStyle
log_action dflags dflags NoReason SevInfo noSrcSpan
(defaultUserStyle dflags)
(text ("Warning: ignoring unrecognised input `" ++ f ++ "'"))
return Nothing
where platform = targetPlatform dflags
......@@ -1450,7 +1452,7 @@ maybePutStr dflags s
NoReason
SevInteractive
noSrcSpan
defaultUserStyle
(defaultUserStyle dflags)
(text s)
maybePutStrLn :: DynFlags -> String -> IO ()
......
......@@ -59,7 +59,6 @@ import GHC.Arr ( Array(..) )
import GHC.Exts
import GHC.IO ( IO(..) )
import StaticFlags( opt_PprStyle_Debug )
import Control.Monad
import Data.Maybe
import Data.Array.Base
......@@ -340,22 +339,22 @@ ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do
return $ cparen (not (null tt) && p >= app_prec)
(text dc_tag <+> pprDeeperList fsep tt_docs)
ppr_termM y p Term{dc=Right dc, subTerms=tt}
ppr_termM y p Term{dc=Right dc, subTerms=tt} = do
{- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity
= parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
<+> hsep (map (ppr_term1 True) tt)
-} -- TODO Printing infix constructors properly
| null sub_terms_to_show
= return (ppr dc)
| otherwise
= do { tt_docs <- mapM (y app_prec) sub_terms_to_show
; return $ cparen (p >= app_prec) $
sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)] }
where
sub_terms_to_show -- Don't show the dictionary arguments to
-- constructors unless -dppr-debug is on
| opt_PprStyle_Debug = tt
| otherwise = dropList (dataConTheta dc) tt
tt_docs' <- mapM (y app_prec) tt
return $ sdocWithPprDebug $ \dbg ->
-- Don't show the dictionary arguments to
-- constructors unless -dppr-debug is on
let tt_docs = if dbg
then tt_docs'
else dropList (dataConTheta dc) tt_docs'
in if null tt_docs
then ppr dc
else cparen (p >= app_prec) $
sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)]
ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
ppr_termM y p RefWrap{wrapped_term=t} = do
......
......@@ -38,7 +38,6 @@ import BasicTypes
import ConLike
import SrcLoc
import Util
import StaticFlags( opt_PprStyle_Debug )
import Outputable
import FastString
import Type
......@@ -2465,12 +2464,14 @@ pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctx
-- in a transformed branch of
-- transformed branch of
-- transformed branch of monad comprehension
pprStmtContext (ParStmtCtxt c)
| opt_PprStyle_Debug = sep [text "parallel branch of", pprAStmtContext c]
| otherwise = pprStmtContext c
pprStmtContext (TransStmtCtxt c)
| opt_PprStyle_Debug = sep [text "transformed branch of", pprAStmtContext c]
| otherwise = pprStmtContext c
pprStmtContext (ParStmtCtxt c) =
sdocWithPprDebug $ \dbg -> if dbg
then sep [text "parallel branch of", pprAStmtContext c]
else pprStmtContext c
pprStmtContext (TransStmtCtxt c) =
sdocWithPprDebug $ \dbg -> if dbg
then sep [text "transformed branch of", pprAStmtContext c]
else pprStmtContext c
instance (Outputable id, Outputable (NameOrRdrName id))
=> Outputable (HsStmtContext id) where
......
......@@ -84,7 +84,6 @@ import Type
import HsDoc
import BasicTypes
import SrcLoc
import StaticFlags
import Outputable
import FastString
import Maybes( isJust )
......@@ -1192,11 +1191,8 @@ pprHsForAllExtra extra qtvs cxt
show_extra = isJust extra
pprHsForAllTvs :: (OutputableBndrId name) => [LHsTyVarBndr name] -> SDoc
pprHsForAllTvs qtvs
| show_forall = forAllLit <+> interppSP qtvs <> dot
| otherwise = empty
where
show_forall = opt_PprStyle_Debug || not (null qtvs)
pprHsForAllTvs qtvs = sdocWithPprDebug $ \debug ->
ppWhen (debug || not (null qtvs)) $ forAllLit <+> interppSP qtvs <> dot
pprHsContext :: (OutputableBndrId name) => HsContext name -> SDoc
pprHsContext = maybe empty (<+> darrow) . pprHsContextMaybe
......
......@@ -81,7 +81,7 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
NoReason
SevOutput
noSrcSpan
defaultDumpStyle
(defaultDumpStyle dflags)
sd
QuietBinIFaceReading -> \_ -> return ()
wantedGot :: Outputable a => String -> a -> a -> IO ()
......
......@@ -64,7 +64,6 @@ import Binary
import BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue )
import Var( TyVarBndr(..) )
import TyCon ( Role (..), Injectivity(..), HowAbstract(..) )
import StaticFlags (opt_PprStyle_Debug)
import Util( filterOut, filterByList )
import DataCon (SrcStrictness(..), SrcUnpackedness(..))
import Lexeme (isLexSym)
......@@ -980,7 +979,7 @@ pprIfaceConDecl ss gadt_style fls tycon tc_binders parent
| otherwise
= sep [pp_field_args, arrow <+> pp_res_ty]
ppr_bang IfNoBang = ppWhen opt_PprStyle_Debug $ char '_'
ppr_bang IfNoBang = sdocWithPprDebug $ \dbg -> ppWhen dbg $ char '_'
ppr_bang IfStrict = char '!'
ppr_bang IfUnpack = text "{-# UNPACK #-}"
ppr_bang (IfUnpackCo co) = text "! {-# UNPACK #-}" <>
......
......@@ -7,6 +7,7 @@ This module defines interface types and binders
-}
{-# LANGUAGE CPP, FlexibleInstances, BangPatterns #-}
{-# LANGUAGE MultiWayIf #-}
-- FlexibleInstances for Binary (DefMethSpec IfaceType)
module IfaceType (
......@@ -52,7 +53,6 @@ module IfaceType (
import {-# SOURCE #-} TysWiredIn ( liftedRepDataConTyCon )
import DynFlags
import StaticFlags ( opt_PprStyle_Debug )
import TyCon hiding ( pprPromotionQuote )
import CoAxiom
import Var
......@@ -972,15 +972,17 @@ pprTyTcApp' ctxt_prec tc tys dflags style
, rep `ifaceTyConHasKey` liftedRepDataConKey
= kindStar
| not opt_PprStyle_Debug
, tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey
= text "(TypeError ...)" -- Suppress detail unles you _really_ want to see
| otherwise
= sdocWithPprDebug $ \dbg ->
if | not dbg && tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey
-- Suppress detail unles you _really_ want to see
-> text "(TypeError ...)"
| Just doc <- ppr_equality tc (tcArgsIfaceTypes tys)
= doc
| Just doc <- ppr_equality tc (tcArgsIfaceTypes tys)
-> doc
| otherwise
= ppr_iface_tc_app ppr_ty ctxt_prec tc tys_wo_kinds
| otherwise
-> ppr_iface_tc_app ppr_ty ctxt_prec tc tys_wo_kinds
where
info = ifaceTyConInfo tc
tys_wo_kinds = tcArgsIfaceTypes $ stripInvisArgs dflags tys
......
......@@ -870,6 +870,7 @@ readIface :: InstalledModule -> FilePath
readIface wanted_mod file_path
= do { res <- tryMostM $
readBinIface CheckHiWay QuietBinIFaceReading file_path
; dflags <- getDynFlags
; case res of
Right iface
-- Same deal
......@@ -878,7 +879,7 @@ readIface wanted_mod file_path
| otherwise -> return (Failed err)
where
actual_mod = mi_module iface
err = hiModuleNameMismatchWarn wanted_mod actual_mod
err = hiModuleNameMismatchWarn dflags wanted_mod actual_mod
Left exn -> return (Failed (text (showException exn)))
}
......@@ -973,7 +974,8 @@ showIface hsc_env filename = do
iface <- initTcRnIf 's' hsc_env () () $
readBinIface IgnoreHiWay TraceBinIFaceReading filename
let dflags = hsc_dflags hsc_env
log_action dflags dflags NoReason SevDump noSrcSpan defaultDumpStyle (pprModIface iface)
log_action dflags dflags NoReason SevDump noSrcSpan
(defaultDumpStyle dflags) (pprModIface iface)
-- Show a ModIface but don't display details; suitable for ModIfaces stored in
-- the EPT.
......@@ -1128,11 +1130,11 @@ badIfaceFile file err
= vcat [text "Bad interface file:" <+> text file,
nest 4 err]
hiModuleNameMismatchWarn :: InstalledModule -> Module -> MsgDoc
hiModuleNameMismatchWarn requested_mod read_mod =
hiModuleNameMismatchWarn :: DynFlags -> InstalledModule -> Module -> MsgDoc
hiModuleNameMismatchWarn dflags requested_mod read_mod =
-- ToDo: This will fail to have enough qualification when the package IDs
-- are the same
withPprStyle (mkUserStyle alwaysQualify AllTheWay) $
withPprStyle (mkUserStyle dflags alwaysQualify AllTheWay) $
-- we want the Modules below to be qualified with package names,
-- so reset the PrintUnqualified setting.
hsep [ text "Something is amiss; requested module "
......
......@@ -400,7 +400,7 @@ strDisplayName_llvm lbl = do
dflags <- getDynFlags
let sdoc = pprCLabel platform lbl
depth = Outp.PartWay 1
style = Outp.mkUserStyle Outp.reallyAlwaysQualify depth
style = Outp.mkUserStyle dflags Outp.reallyAlwaysQualify depth
str = Outp.renderWithStyle dflags sdoc style
return (fsLit (dropInfoSuffix str))
......@@ -418,7 +418,7 @@ strProcedureName_llvm lbl = do
dflags <- getDynFlags
let sdoc = pprCLabel platform lbl
depth = Outp.PartWay 1
style = Outp.mkUserStyle Outp.neverQualify depth
style = Outp.mkUserStyle dflags Outp.neverQualify depth
str = Outp.renderWithStyle dflags sdoc style
return (fsLit str)
......
......@@ -4,8 +4,7 @@
--
-- | Command-line parser
--
-- This is an abstract command-line parser used by both StaticFlags and
-- DynFlags.
-- This is an abstract command-line parser used by DynFlags.
--
-- (c) The University of Glasgow 2005
--
......
......@@ -73,7 +73,7 @@ codeOutput dflags this_mod filenm location foreign_stubs pkg_deps cmm_stream
NoReason
SevDump
noSrcSpan
defaultDumpStyle
(defaultDumpStyle dflags)
err
; ghcExit dflags 1
}
......
......@@ -1623,7 +1623,8 @@ mkExtraObj dflags extn xs
mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath
mkExtraObjToLinkIntoBinary dflags = do
when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ do
log_action dflags dflags NoReason SevInfo noSrcSpan defaultUserStyle
log_action dflags dflags NoReason SevInfo noSrcSpan
(defaultUserStyle dflags)
(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.")
......@@ -2021,7 +2022,8 @@ linkDynLibCheck :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()
linkDynLibCheck dflags o_files dep_packages
= do
when (haveRtsOptsFlags dflags) $ do
log_action dflags dflags NoReason SevInfo noSrcSpan defaultUserStyle
log_action dflags dflags NoReason SevInfo noSrcSpan
(defaultUserStyle dflags)
(text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$
text " Call hs_init_ghc() from your main() function to set these options.")
......
......@@ -28,6 +28,7 @@ module DynFlags (
ProfAuto(..),
glasgowExtsFlags,
warningGroups, warningHierarchies,
hasPprDebug, hasNoDebugOutput, hasNoStateHack, hasNoOptCoercion,
dopt, dopt_set, dopt_unset,
gopt, gopt_set, gopt_unset, setGeneralFlag', unSetGeneralFlag',
wopt, wopt_set, wopt_unset,
......@@ -381,7 +382,8 @@ data DumpFlag
| Opt_D_verbose_core2core
| Opt_D_dump_debug
| Opt_D_dump_json
| Opt_D_ppr_debug
| Opt_D_no_debug_output
deriving (Eq, Show, Enum)
-- | Enumerates the simple on-or-off dynamic flags
......@@ -561,6 +563,9 @@ data GeneralFlag
-- safe haskell flags
| Opt_DistrustAllPackages
| Opt_PackageTrust
| Opt_G_NoStateHack
| Opt_G_NoOptCoercion
deriving (Eq, Show, Enum)
-- | Used when outputting warnings: if a reason is given, it is
......@@ -1889,6 +1894,19 @@ languageExtensions (Just Haskell2010)
LangExt.DoAndIfThenElse,
LangExt.RelaxedPolyRec]
hasPprDebug :: DynFlags -> Bool
hasPprDebug = dopt Opt_D_ppr_debug
hasNoDebugOutput :: DynFlags -> Bool
hasNoDebugOutput = dopt Opt_D_no_debug_output
hasNoStateHack :: DynFlags -> Bool
hasNoStateHack = gopt Opt_G_NoStateHack
hasNoOptCoercion :: DynFlags -> Bool
hasNoOptCoercion = gopt Opt_G_NoOptCoercion
-- | Test whether a 'DumpFlag' is set
dopt :: DumpFlag -> DynFlags -> Bool
dopt f dflags = (fromEnum f `IntSet.member` dumpFlags dflags)
......@@ -2736,6 +2754,10 @@ dynamic_flags_deps = [
(NoArg (unSetGeneralFlag Opt_AutoLinkPackages))
, make_ord_flag defGhcFlag "no-hs-main"
(NoArg (setGeneralFlag Opt_NoHsMain))
, make_ord_flag defGhcFlag "fno-state-hack"
(NoArg (setGeneralFlag Opt_G_NoStateHack))
, make_ord_flag defGhcFlag "fno-opt-coercion"
(NoArg (setGeneralFlag Opt_G_NoOptCoercion))
, make_ord_flag defGhcFlag "with-rtsopts"
(HasArg setRtsOpts)
, make_ord_flag defGhcFlag "rtsopts"
......@@ -2979,10 +3001,14 @@ dynamic_flags_deps = [
(NoArg (setGeneralFlag Opt_D_faststring_stats))
, make_ord_flag defGhcFlag "dno-llvm-mangler"
(NoArg (setGeneralFlag Opt_NoLlvmMangler)) -- hidden flag
, make_ord_flag defGhcFlag "ddump-debug" (setDumpFlag Opt_D_dump_debug)
, make_ord_flag defGhcFlag "ddump-debug"
(setDumpFlag Opt_D_dump_debug)
, make_ord_flag defGhcFlag "ddump-json"
(noArg (flip dopt_set Opt_D_dump_json . setJsonLogAction ) )
, make_ord_flag defGhcFlag "dppr-debug"
(setDumpFlag Opt_D_ppr_debug)
, make_ord_flag defGhcFlag "dno-debug-output"
(setDumpFlag Opt_D_no_debug_output)
------ Machine dependent (-m<blah>) stuff ---------------------------
......@@ -4435,7 +4461,8 @@ setDumpFlag' dump_flag
-- on during recompilation checking, so in those cases we
-- don't want to turn it off.
want_recomp = dump_flag `notElem` [Opt_D_dump_if_trace,
Opt_D_dump_hi_diffs]
Opt_D_dump_hi_diffs,
Opt_D_no_debug_output]
forceRecompile :: DynP ()
-- Whenver we -ddump, force recompilation (by switching off the
......
......@@ -16,3 +16,5 @@ useUnicodeSyntax :: DynFlags -> Bool
useColor :: DynFlags -> OverridingBool
canUseColor :: DynFlags -> Bool
overrideWith :: Bool -> OverridingBool -> Bool
hasPprDebug :: DynFlags -> Bool
hasNoDebugOutput :: DynFlags -> Bool
......@@ -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 ()