diff options
51 files changed, 412 insertions, 610 deletions
diff --git a/compiler/backpack/DriverBkp.hs b/compiler/backpack/DriverBkp.hs index 595cb25174..25ef62409e 100644 --- a/compiler/backpack/DriverBkp.hs +++ b/compiler/backpack/DriverBkp.hs @@ -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 diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs index ff4d2c7cce..a23255b7b2 100644 --- a/compiler/basicTypes/BasicTypes.hs +++ b/compiler/basicTypes/BasicTypes.hs @@ -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 {- ************************************************************************ diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs index acb22e8c9b..64b87ff15d 100644 --- a/compiler/basicTypes/Id.hs +++ b/compiler/basicTypes/Id.hs @@ -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 diff --git a/compiler/basicTypes/RdrName.hs b/compiler/basicTypes/RdrName.hs index 321b13ab19..022cfe7929 100644 --- a/compiler/basicTypes/RdrName.hs +++ b/compiler/basicTypes/RdrName.hs @@ -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)] diff --git a/compiler/basicTypes/VarEnv.hs b/compiler/basicTypes/VarEnv.hs index 64357d77fa..3177abb814 100644 --- a/compiler/basicTypes/VarEnv.hs +++ b/compiler/basicTypes/VarEnv.hs @@ -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) {- diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index c836e2cf44..e7425930a6 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -239,7 +239,6 @@ import Unique import UniqFM import SrcLoc import DynFlags -import StaticFlags import ErrUtils import StringBuffer import FastString diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index a776038f6b..f87989d482 100644 --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -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 diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index 7faf8fb8ec..ddab00c888 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -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) diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 1da783dff3..0d1a45b56b 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -353,7 +353,6 @@ Library Plugins TcPluginM PprTyThing - StaticFlags StaticPtrTable SysTools SysTools.Terminal diff --git a/compiler/ghc.mk b/compiler/ghc.mk index d8e3a52008..df16483466 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -531,7 +531,6 @@ compiler_stage2_dll0_MODULES = \ RdrName \ Rules \ SrcLoc \ - StaticFlags \ StringBuffer \ SysTools.Terminal \ TcEvidence \ diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs index 76c1cdafa2..e89f1bb680 100644 --- a/compiler/ghci/Linker.hs +++ b/compiler/ghci/Linker.hs @@ -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 () diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index 03b2f95475..b63c1c94b2 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -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 diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index e4d843191f..617972decd 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -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 diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index c974d1f3bc..998f8bdedd 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -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 diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index ad1e8456e8..60f0447dd0 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -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 () diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs index 7740977263..9a69b39b65 100644 --- a/compiler/iface/IfaceSyn.hs +++ b/compiler/iface/IfaceSyn.hs @@ -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 #-}" <> diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs index 0dded2139f..75a2afcc7d 100644 --- a/compiler/iface/IfaceType.hs +++ b/compiler/iface/IfaceType.hs @@ -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 diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs index 75f2b6a24d..0890e20cff 100644 --- a/compiler/iface/LoadIface.hs +++ b/compiler/iface/LoadIface.hs @@ -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 " diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index eb4a863e5a..1464531e72 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -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) diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs index 0a24be5579..6d6edcadf9 100644 --- a/compiler/main/CmdLineParser.hs +++ b/compiler/main/CmdLineParser.hs @@ -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 -- diff --git a/compiler/main/CodeOutput.hs b/compiler/main/CodeOutput.hs index f4681dcd27..df9b7f31f3 100644 --- a/compiler/main/CodeOutput.hs +++ b/compiler/main/CodeOutput.hs @@ -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 } diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 463b715807..adebdf4537 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -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.") diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 682480b44f..d7a5f1f92c 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -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 diff --git a/compiler/main/DynFlags.hs-boot b/compiler/main/DynFlags.hs-boot index 9e6a0d477d..14c039aca3 100644 --- a/compiler/main/DynFlags.hs-boot +++ b/compiler/main/DynFlags.hs-boot @@ -16,3 +16,5 @@ useUnicodeSyntax :: DynFlags -> Bool useColor :: DynFlags -> OverridingBool canUseColor :: DynFlags -> Bool overrideWith :: Bool -> OverridingBool -> Bool +hasPprDebug :: DynFlags -> Bool +hasNoDebugOutput :: DynFlags -> Bool 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 diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index bc406d5c59..f8f3ba9678 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -31,7 +31,6 @@ module GHC ( getSessionDynFlags, setSessionDynFlags, getProgramDynFlags, setProgramDynFlags, getInteractiveDynFlags, setInteractiveDynFlags, - parseStaticFlags, -- * Targets Target(..), TargetId(..), Phase, @@ -276,7 +275,6 @@ module GHC ( ToDo: * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt. - * what StaticFlags should we expose, if any? -} #include "HsVersions.h" @@ -317,7 +315,6 @@ import DriverPhases ( Phase(..), isHaskellSrcFilename ) import Finder import HscTypes import DynFlags -import StaticFlags import SysTools import Annotations import Module @@ -479,8 +476,7 @@ withCleanupSession ghc = ghc `gfinally` cleanup initGhcMonad :: GhcMonad m => Maybe FilePath -> m () initGhcMonad mb_top_dir = do { env <- liftIO $ - do { initStaticOpts - ; mySettings <- initSysTools mb_top_dir + do { mySettings <- initSysTools mb_top_dir ; dflags <- initDynFlags (defaultDynFlags mySettings) ; checkBrokenTablesNextToCode dflags ; setUnsafeGlobalDynFlags dflags diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs deleted file mode 100644 index b5be9ba1ac..0000000000 --- a/compiler/main/StaticFlags.hs +++ /dev/null @@ -1,248 +0,0 @@ -{-# LANGUAGE CPP, TupleSections #-} -{-# OPTIONS_GHC -fno-cse #-} --- -fno-cse is needed for GLOBAL_VAR's to behave properly - ------------------------------------------------------------------------------ --- --- Static flags --- --- Static flags can only be set once, on the command-line. Inside GHC, --- each static flag corresponds to a top-level value, usually of type Bool. --- --- (c) The University of Glasgow 2005 --- ------------------------------------------------------------------------------ - -module StaticFlags ( - -- entry point - parseStaticFlags, - - staticFlags, - initStaticOpts, - discardStaticFlags, - - -- Output style options - opt_PprStyle_Debug, - opt_NoDebugOutput, - - -- optimisation opts - opt_NoStateHack, - opt_NoOptCoercion, - - -- For the parser - addOpt, removeOpt, v_opt_C_ready, - - -- For options autocompletion - flagsStatic, flagsStaticNames - ) where - -#include "HsVersions.h" - -import CmdLineParser -import FastString -import SrcLoc -import Util -import Panic - -import Control.Monad -import Data.IORef -import System.IO.Unsafe ( unsafePerformIO ) - -import Foreign (Ptr) -- needed for 2nd stage - ------------------------------------------------------------------------------ --- Static flags - --- | Parses GHC's static flags from a list of command line arguments. --- --- These flags are static in the sense that they can be set only once and they --- are global, meaning that they affect every instance of GHC running; --- multiple GHC threads will use the same flags. --- --- This function must be called before any session is started, i.e., before --- the first call to 'GHC.withGhc'. --- --- Static flags are more of a hack and are static for more or less historical --- reasons. In the long run, most static flags should eventually become --- dynamic flags. --- --- XXX: can we add an auto-generated list of static flags here? --- -parseStaticFlags :: [Located String] -> IO ([Located String], [Located String]) -parseStaticFlags = parseStaticFlagsFull flagsStatic - --- | Parse GHC's static flags as @parseStaticFlags@ does. However it also --- takes a list of available static flags, such that certain flags can be --- enabled or disabled through this argument. -parseStaticFlagsFull :: [Flag IO] -> [Located String] - -> IO ([Located String], [Located String]) -parseStaticFlagsFull flagsAvailable args = do - ready <- readIORef v_opt_C_ready - when ready $ throwGhcExceptionIO (ProgramError "Too late for parseStaticFlags: call it before runGhc or runGhcT") - - (leftover, errs, warns) <- processArgs flagsAvailable args - - -- See Note [Handling errors when parsing commandline flags] - unless (null errs) $ throwGhcExceptionIO $ - errorsToGhcException . map (("on the commandline", ) . unLoc) $ errs - - -- see sanity code in staticOpts - writeIORef v_opt_C_ready True - return (leftover, warns) - --- holds the static opts while they're being collected, before --- being unsafely read by unpacked_static_opts below. -#if STAGE < 2 -GLOBAL_VAR(v_opt_C, [], [String]) -GLOBAL_VAR(v_opt_C_ready, False, Bool) -#else -SHARED_GLOBAL_VAR( v_opt_C - , getOrSetLibHSghcStaticOptions - , "getOrSetLibHSghcStaticOptions" - , [] - , [String]) -SHARED_GLOBAL_VAR( v_opt_C_ready - , getOrSetLibHSghcStaticOptionsReady - , "getOrSetLibHSghcStaticOptionsReady" - , False - , Bool) -#endif - -staticFlags :: [String] -staticFlags = unsafePerformIO $ do - ready <- readIORef v_opt_C_ready - if (not ready) - then panic "Static flags have not been initialised!\n Please call GHC.parseStaticFlags early enough." - else readIORef v_opt_C - --- All the static flags should appear in this list. It describes how each --- static flag should be processed. Two main purposes: --- (a) if a command-line flag doesn't appear in the list, GHC can complain --- (b) a command-line flag may remove, or add, other flags; e.g. the "-fno-X" --- things --- --- The common (PassFlag addOpt) action puts the static flag into the bunch of --- things that are searched up by the top-level definitions like --- opt_foo = lookUp (fsLit "-dfoo") - --- Note that ordering is important in the following list: any flag which --- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override --- flags further down the list with the same prefix. - --- see Note [Updating flag description in the User's Guide] in DynFlags -flagsStatic :: [Flag IO] -flagsStatic = [ - ------ Debugging ---------------------------------------------------- - defFlag "dppr-debug" (PassFlag addOptEwM) - , defFlag "dno-debug-output" (PassFlag addOptEwM) - -- rest of the debugging flags are dynamic - - ------ Compiler flags ----------------------------------------------- - -- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline - , defFlag "fno-" - (PrefixPred (\s -> isStaticFlag ("f"++s)) (\s -> removeOptEwM ("-f"++s))) - - -- Pass all remaining "-f<blah>" options to hsc - , defFlag "f" (AnySuffixPred isStaticFlag addOptEwM) - ] - - - -isStaticFlag :: String -> Bool -isStaticFlag f = f `elem` flagsStaticNames - - --- see Note [Updating flag description in the User's Guide] in DynFlags -flagsStaticNames :: [String] -flagsStaticNames = [ - "fno-state-hack", - "fno-opt-coercion" - ] - --- We specifically need to discard static flags for clients of the --- GHC API, since they can't be safely reparsed or reinitialized. In general, --- the existing flags do nothing other than control debugging and some low-level --- optimizer phases, so for the most part this is OK. --- --- See GHC issue #8276: http://ghc.haskell.org/trac/ghc/ticket/8276#comment:37 -discardStaticFlags :: [String] -> [String] -discardStaticFlags = filter (\x -> x `notElem` flags) - where flags = [ "-fno-state-hack" - , "-fno-opt-coercion" - , "-dppr-debug" - , "-dno-debug-output" - ] - - -initStaticOpts :: IO () -initStaticOpts = writeIORef v_opt_C_ready True - -addOpt :: String -> IO () -addOpt = consIORef v_opt_C - -removeOpt :: String -> IO () -removeOpt f = do - fs <- readIORef v_opt_C - writeIORef v_opt_C $! filter (/= f) fs - -type StaticP = EwM IO - -addOptEwM :: String -> StaticP () -addOptEwM = liftEwM . addOpt - -removeOptEwM :: String -> StaticP () -removeOptEwM = liftEwM . removeOpt - -packed_static_opts :: [FastString] -packed_static_opts = map mkFastString staticFlags - -lookUp :: FastString -> Bool -lookUp sw = sw `elem` packed_static_opts - --- debugging options - --- see Note [Updating flag description in the User's Guide] in DynFlags - -opt_PprStyle_Debug :: Bool -opt_PprStyle_Debug = lookUp (fsLit "-dppr-debug") - -opt_NoDebugOutput :: Bool -opt_NoDebugOutput = lookUp (fsLit "-dno-debug-output") - -opt_NoStateHack :: Bool -opt_NoStateHack = lookUp (fsLit "-fno-state-hack") - -opt_NoOptCoercion :: Bool -opt_NoOptCoercion = lookUp (fsLit "-fno-opt-coercion") - -{- --- (lookup_str "foo") looks for the flag -foo=X or -fooX, --- and returns the string X -lookup_str :: String -> Maybe String -lookup_str sw - = case firstJusts (map (stripPrefix sw) staticFlags) of - Just ('=' : str) -> Just str - Just str -> Just str - Nothing -> Nothing - -lookup_def_int :: String -> Int -> Int -lookup_def_int sw def = case (lookup_str sw) of - Nothing -> def -- Use default - Just xx -> try_read sw xx - -lookup_def_float :: String -> Float -> Float -lookup_def_float sw def = case (lookup_str sw) of - Nothing -> def -- Use default - Just xx -> try_read sw xx - -try_read :: Read a => String -> String -> a --- (try_read sw str) tries to read s; if it fails, it --- bleats about flag sw -try_read sw str - = case reads str of - ((x,_):_) -> x -- Be forgiving: ignore trailing goop, and alternative parses - [] -> throwGhcException (UsageError ("Malformed argument " ++ str ++ " for flag " ++ sw)) - -- ToDo: hack alert. We should really parse the arguments - -- and announce errors in a more civilised way. --} - diff --git a/compiler/main/StaticFlags.hs-boot b/compiler/main/StaticFlags.hs-boot deleted file mode 100644 index 53ee13bf15..0000000000 --- a/compiler/main/StaticFlags.hs-boot +++ /dev/null @@ -1,4 +0,0 @@ -module StaticFlags where - -opt_PprStyle_Debug :: Bool -opt_NoDebugOutput :: Bool diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs index 67771947ad..17ce634e90 100644 --- a/compiler/main/SysTools.hs +++ b/compiler/main/SysTools.hs @@ -1353,10 +1353,12 @@ builderMainLoop dflags filter_fn pgm real_args mb_env = do msg <- readChan chan case msg of BuildMsg msg -> do - log_action dflags dflags NoReason SevInfo noSrcSpan defaultUserStyle msg + log_action dflags dflags NoReason SevInfo noSrcSpan + (defaultUserStyle dflags) msg loop chan hProcess t p exitcode BuildError loc msg -> do - log_action dflags dflags NoReason SevError (mkSrcSpan loc loc) defaultUserStyle msg + log_action dflags dflags NoReason SevError (mkSrcSpan loc loc) + (defaultUserStyle dflags) msg loop chan hProcess t p exitcode EOF -> loop chan hProcess (t-1) p exitcode diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs index 0fc153ad4c..0c8f4910cb 100644 --- a/compiler/main/TidyPgm.hs +++ b/compiler/main/TidyPgm.hs @@ -410,12 +410,13 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ; unless (dopt Opt_D_dump_simpl dflags) $ Err.dumpIfSet_dyn dflags Opt_D_dump_rules (showSDoc dflags (ppr CoreTidy <+> text "rules")) - (pprRulesForUser tidy_rules) + (pprRulesForUser dflags tidy_rules) -- Print one-line size info ; let cs = coreBindsStats tidy_binds ; when (dopt Opt_D_dump_core_stats dflags) - (log_action dflags dflags NoReason SevDump noSrcSpan defaultDumpStyle + (log_action dflags dflags NoReason SevDump noSrcSpan + (defaultDumpStyle dflags) (text "Tidy size (terms,types,coercions)" <+> ppr (moduleName mod) <> colon <+> int (cs_tm cs) diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs index 7b807765a8..087410c3bf 100644 --- a/compiler/simplCore/CoreMonad.hs +++ b/compiler/simplCore/CoreMonad.hs @@ -59,7 +59,6 @@ import CoreSyn import HscTypes import Module import DynFlags -import StaticFlags import BasicTypes ( CompilerPhase(..) ) import Annotations @@ -251,8 +250,8 @@ bindsOnlyPass pass guts ************************************************************************ -} -verboseSimplStats :: Bool -verboseSimplStats = opt_PprStyle_Debug -- For now, anyway +getVerboseSimplStats :: (Bool -> SDoc) -> SDoc +getVerboseSimplStats = sdocWithPprDebug -- For now, anyway zeroSimplCount :: DynFlags -> SimplCount isZeroSimplCount :: SimplCount -> Bool @@ -340,7 +339,8 @@ pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 }) = vcat [text "Total ticks: " <+> int tks, blankLine, pprTickCounts dts, - if verboseSimplStats then + getVerboseSimplStats $ \dbg -> if dbg + then vcat [blankLine, text "Log (most recent first)", nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))] @@ -740,8 +740,8 @@ msg sev doc SevDump -> dump_sty _ -> user_sty err_sty = mkErrStyle dflags unqual - user_sty = mkUserStyle unqual AllTheWay - dump_sty = mkDumpStyle unqual + user_sty = mkUserStyle dflags unqual AllTheWay + dump_sty = mkDumpStyle dflags unqual ; liftIO $ (log_action dflags) dflags NoReason sev loc sty doc } diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs index f032aad95c..23faac861a 100644 --- a/compiler/simplCore/SimplCore.hs +++ b/compiler/simplCore/SimplCore.hs @@ -490,7 +490,7 @@ ruleCheckPass current_phase pat guts = ; dflags <- getDynFlags ; vis_orphs <- getVisibleOrphanMods ; liftIO $ log_action dflags dflags NoReason Err.SevDump noSrcSpan - defaultDumpStyle + (defaultDumpStyle dflags) (ruleCheckProgram current_phase pat (RuleEnv rb vis_orphs) (mg_binds guts)) ; return guts } diff --git a/compiler/simplStg/SimplStg.hs b/compiler/simplStg/SimplStg.hs index 08f9d79782..ed04327a56 100644 --- a/compiler/simplStg/SimplStg.hs +++ b/compiler/simplStg/SimplStg.hs @@ -38,7 +38,8 @@ stg2stg dflags module_name binds ; us <- mkSplitUniqSupply 'g' ; when (dopt Opt_D_verbose_stg2stg dflags) - (log_action dflags dflags NoReason SevDump noSrcSpan defaultDumpStyle (text "VERBOSE STG-TO-STG:")) + (log_action dflags dflags NoReason SevDump noSrcSpan + (defaultDumpStyle dflags) (text "VERBOSE STG-TO-STG:")) ; (binds', us', ccs) <- end_pass us "Stg2Stg" ([],[],[]) binds diff --git a/compiler/specialise/Rules.hs b/compiler/specialise/Rules.hs index ba44794db4..168104156f 100644 --- a/compiler/specialise/Rules.hs +++ b/compiler/specialise/Rules.hs @@ -54,7 +54,6 @@ import NameEnv import UniqFM import Unify ( ruleMatchTyKiX ) import BasicTypes ( Activation, CompilerPhase, isActive, pprRuleName ) -import StaticFlags ( opt_PprStyle_Debug ) import DynFlags ( DynFlags ) import Outputable import FastString @@ -255,14 +254,14 @@ functions (lambdas) except by name, so in this case it seems like a good idea to treat 'M.k' as a roughTopName of the call. -} -pprRulesForUser :: [CoreRule] -> SDoc +pprRulesForUser :: DynFlags -> [CoreRule] -> SDoc -- (a) tidy the rules -- (b) sort them into order based on the rule name -- (c) suppress uniques (unless -dppr-debug is on) -- This combination makes the output stable so we can use in testing -- It's here rather than in PprCore because it calls tidyRules -pprRulesForUser rules - = withPprStyle defaultUserStyle $ +pprRulesForUser dflags rules + = withPprStyle (defaultUserStyle dflags) $ pprRules $ sortBy (comparing ru_name) $ tidyRules emptyTidyEnv rules @@ -419,15 +418,16 @@ findBest _ (rule,ans) [] = (rule,ans) findBest target (rule1,ans1) ((rule2,ans2):prs) | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs - | debugIsOn = let pp_rule rule - | opt_PprStyle_Debug = ppr rule - | otherwise = doubleQuotes (ftext (ru_name rule)) + | debugIsOn = let pp_rule rule = sdocWithPprDebug $ \dbg -> if dbg + then ppr rule + else doubleQuotes (ftext (ru_name rule)) in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)" - (vcat [if opt_PprStyle_Debug then - text "Expression to match:" <+> ppr fn <+> sep (map ppr args) - else empty, - text "Rule 1:" <+> pp_rule rule1, - text "Rule 2:" <+> pp_rule rule2]) $ + (vcat [ sdocWithPprDebug $ \dbg -> if dbg + then text "Expression to match:" <+> ppr fn + <+> sep (map ppr args) + else empty + , text "Rule 1:" <+> pp_rule rule1 + , text "Rule 2:" <+> pp_rule rule2]) $ findBest target (rule1,ans1) prs | otherwise = findBest target (rule1,ans1) prs where diff --git a/compiler/specialise/SpecConstr.hs b/compiler/specialise/SpecConstr.hs index 5ee2dec594..f6e10adad4 100644 --- a/compiler/specialise/SpecConstr.hs +++ b/compiler/specialise/SpecConstr.hs @@ -41,8 +41,7 @@ import VarEnv import VarSet import Name import BasicTypes -import DynFlags ( DynFlags(..) ) -import StaticFlags ( opt_PprStyle_Debug ) +import DynFlags ( DynFlags(..), hasPprDebug ) import Maybes ( orElse, catMaybes, isJust, isNothing ) import Demand import GHC.Serialized ( deserializeWithData ) @@ -1522,8 +1521,10 @@ specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs spec_count' = n_pats + spec_count ; case sc_count env of Just max | not (sc_force env) && spec_count' > max - -> if (debugIsOn || opt_PprStyle_Debug) -- Suppress this scary message for - then pprTrace "SpecConstr" msg $ -- ordinary users! Trac #5125 + -- Suppress this scary message for + -- ordinary users! Trac #5125 + -> if (debugIsOn || hasPprDebug (sc_dflags env)) + then pprTrace "SpecConstr" msg $ return (nullUsage, spec_info) else return (nullUsage, spec_info) where @@ -1533,8 +1534,10 @@ specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs text "but the limit is" <+> int max) ] , text "Use -fspec-constr-count=n to set the bound" , extra ] - extra | not opt_PprStyle_Debug = text "Use -dppr-debug to see specialisations" - | otherwise = text "Specialisations:" <+> ppr (pats ++ [p | OS p _ _ _ <- specs]) + extra = sdocWithPprDebug $ \dbg -> if dbg + then text "Specialisations:" + <+> ppr (pats ++ [p | OS p _ _ _ <- specs]) + else text "Use -dppr-debug to see specialisations" _normal_case -> do { diff --git a/compiler/typecheck/TcBackpack.hs b/compiler/typecheck/TcBackpack.hs index 9a428a837c..ce8ab7a970 100644 --- a/compiler/typecheck/TcBackpack.hs +++ b/compiler/typecheck/TcBackpack.hs @@ -163,8 +163,9 @@ checkHsigIface tcg_env gr sig_iface -- info for the *specific* name we matched. -> getLoc e _ -> nameSrcSpan name + dflags <- getDynFlags addErrAt loc - (badReexportedBootThing False name name') + (badReexportedBootThing dflags False name name') -- This should actually never happen, but whatever... | otherwise = addErrAt (nameSrcSpan name) diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index 4fcd690809..a6ddb81d80 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -232,11 +232,12 @@ tcDeriving deriv_infos deriv_decls ; insts1 <- mapM genInst given_specs ; insts2 <- mapM genInst infer_specs + ; dflags <- getDynFlags + ; let (_, deriv_stuff, maybe_fvs) = unzip3 (insts1 ++ insts2) ; loc <- getSrcSpanM - ; let (binds, famInsts) = genAuxBinds loc (unionManyBags deriv_stuff) - - ; dflags <- getDynFlags + ; let (binds, famInsts) = genAuxBinds dflags loc + (unionManyBags deriv_stuff) ; let mk_inst_infos1 = map fstOf3 insts1 ; inst_infos1 <- apply_inst_infos mk_inst_infos1 given_specs diff --git a/compiler/typecheck/TcDerivUtils.hs b/compiler/typecheck/TcDerivUtils.hs index b9931ff088..b142b33f06 100644 --- a/compiler/typecheck/TcDerivUtils.hs +++ b/compiler/typecheck/TcDerivUtils.hs @@ -199,11 +199,11 @@ hasStockDeriving clas -> TyCon -> [Type] -> TcM (LHsBinds RdrName, BagDerivStuff))] - gen_list = [ (eqClassKey, simple gen_Eq_binds) - , (ordClassKey, simple gen_Ord_binds) - , (enumClassKey, simple gen_Enum_binds) + gen_list = [ (eqClassKey, simpleM gen_Eq_binds) + , (ordClassKey, simpleM gen_Ord_binds) + , (enumClassKey, simpleM gen_Enum_binds) , (boundedClassKey, simple gen_Bounded_binds) - , (ixClassKey, simple gen_Ix_binds) + , (ixClassKey, simpleM gen_Ix_binds) , (showClassKey, with_fix_env gen_Show_binds) , (readClassKey, with_fix_env gen_Read_binds) , (dataClassKey, simpleM gen_Data_binds) diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index 9294b78ca2..eaccc2d795 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -48,7 +48,6 @@ import FastString import Outputable import SrcLoc import DynFlags -import StaticFlags ( opt_PprStyle_Debug ) import ListSetOps ( equivClasses ) import Maybes import qualified GHC.LanguageExtensions as LangExt @@ -2666,7 +2665,7 @@ relevantBindings want_filtering ctxt ct [ ppr id | TcIdBndr_ExpType id _ _ <- tcl_bndrs lcl_env ] ] ; (tidy_env', docs, discards) - <- go env1 ct_tvs (maxRelevantBinds dflags) + <- go dflags env1 ct_tvs (maxRelevantBinds dflags) emptyVarSet [] False (remove_shadowing $ tcl_bndrs lcl_env) -- tcl_bndrs has the innermost bindings first, @@ -2704,14 +2703,14 @@ relevantBindings want_filtering ctxt ct else (binding:bindingAcc, extendOccSet seenNames (occName binding))) ([], emptyOccSet) bindings - go :: TidyEnv -> TcTyVarSet -> Maybe Int -> TcTyVarSet -> [SDoc] + go :: DynFlags -> TidyEnv -> TcTyVarSet -> Maybe Int -> TcTyVarSet -> [SDoc] -> Bool -- True <=> some filtered out due to lack of fuel -> [TcIdBinder] -> TcM (TidyEnv, [SDoc], Bool) -- The bool says if we filtered any out -- because of lack of fuel - go tidy_env _ _ _ docs discards [] + go _ tidy_env _ _ _ docs discards [] = return (tidy_env, reverse docs, discards) - go tidy_env ct_tvs n_left tvs_seen docs discards (tc_bndr : tc_bndrs) + go dflags tidy_env ct_tvs n_left tvs_seen docs discards (tc_bndr : tc_bndrs) = case tc_bndr of TcIdBndr id top_lvl -> go2 (idName id) (idType id) top_lvl TcIdBndr_ExpType name et top_lvl -> @@ -2726,7 +2725,8 @@ relevantBindings want_filtering ctxt ct Nothing -> discard_it -- No info; discard } where - discard_it = go tidy_env ct_tvs n_left tvs_seen docs discards tc_bndrs + discard_it = go dflags tidy_env ct_tvs n_left tvs_seen docs + discards tc_bndrs go2 id_name id_type top_lvl = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env id_type ; traceTc "relevantBindings 1" (ppr id_name <+> dcolon <+> ppr tidy_ty) @@ -2736,7 +2736,7 @@ relevantBindings want_filtering ctxt ct <+> ppr (getSrcLoc id_name)))] new_seen = tvs_seen `unionVarSet` id_tvs - ; if (want_filtering && not opt_PprStyle_Debug + ; if (want_filtering && not (hasPprDebug dflags) && id_tvs `disjointVarSet` ct_tvs) -- We want to filter out this binding anyway -- so discard it silently @@ -2750,12 +2750,13 @@ relevantBindings want_filtering ctxt ct else if run_out n_left && id_tvs `subVarSet` tvs_seen -- We've run out of n_left fuel and this binding only -- mentions already-seen type variables, so discard it - then go tidy_env ct_tvs n_left tvs_seen docs + then go dflags tidy_env ct_tvs n_left tvs_seen docs True -- Record that we have now discarded something tc_bndrs -- Keep this binding, decrement fuel - else go tidy_env' ct_tvs (dec_max n_left) new_seen (doc:docs) discards tc_bndrs } + else go dflags tidy_env' ct_tvs (dec_max n_left) new_seen + (doc:docs) discards tc_bndrs } discardMsg :: SDoc discardMsg = text "(Some bindings suppressed;" <+> diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index 81bda8ec68..533664ec57 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -73,7 +73,6 @@ import Lexeme import FastString import Pair import Bag -import StaticFlags( opt_PprStyle_Debug ) import Data.List ( partition, intersperse ) @@ -156,9 +155,10 @@ for the instance decl, which it probably wasn't, so the decls produced don't get through the typechecker. -} -gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) -gen_Eq_binds loc tycon - = (method_binds, aux_binds) +gen_Eq_binds :: SrcSpan -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff) +gen_Eq_binds loc tycon = do + dflags <- getDynFlags + return (method_binds dflags, aux_binds) where all_cons = tyConDataCons tycon (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons @@ -172,7 +172,7 @@ gen_Eq_binds loc tycon no_tag_match_cons = null tag_match_cons - fall_through_eqn + fall_through_eqn dflags | no_tag_match_cons -- All constructors have arguments = case pat_match_cons of [] -> [] -- No constructors; no fall-though case @@ -184,14 +184,18 @@ gen_Eq_binds loc tycon | otherwise -- One or more tag_match cons; add fall-through of -- extract tags compare for equality = [([a_Pat, b_Pat], - untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)] + untag_Expr dflags tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)] (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))] aux_binds | no_tag_match_cons = emptyBag | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon - method_binds = listToBag [eq_bind, ne_bind] - eq_bind = mk_FunBind loc eq_RDR (map pats_etc pat_match_cons ++ fall_through_eqn) + method_binds dflags = listToBag + [ eq_bind dflags + , ne_bind + ] + eq_bind dflags = mk_FunBind loc eq_RDR (map pats_etc pat_match_cons + ++ fall_through_eqn dflags) ne_bind = mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] ( nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR]))) @@ -333,22 +337,25 @@ gtResult OrdGE = true_Expr gtResult OrdGT = true_Expr ------------ -gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) -gen_Ord_binds loc tycon - | null tycon_data_cons -- No data-cons => invoke bale-out case - = (unitBag $ mk_FunBind loc compare_RDR [], emptyBag) - | otherwise - = (unitBag (mkOrdOp OrdCompare) `unionBags` other_ops, aux_binds) +gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff) +gen_Ord_binds loc tycon = do + dflags <- getDynFlags + return $ if null tycon_data_cons -- No data-cons => invoke bale-out case + then ( unitBag $ mk_FunBind loc compare_RDR [] + , emptyBag) + else ( unitBag (mkOrdOp dflags OrdCompare) `unionBags` other_ops dflags + , aux_binds) where aux_binds | single_con_type = emptyBag | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon -- Note [Game plan for deriving Ord] - other_ops | (last_tag - first_tag) <= 2 -- 1-3 constructors - || null non_nullary_cons -- Or it's an enumeration - = listToBag [mkOrdOp OrdLT, lE, gT, gE] - | otherwise - = emptyBag + other_ops dflags + | (last_tag - first_tag) <= 2 -- 1-3 constructors + || null non_nullary_cons -- Or it's an enumeration + = listToBag [mkOrdOp dflags OrdLT, lE, gT, gE] + | otherwise + = emptyBag negate_expr = nlHsApp (nlHsVar not_RDR) lE = mk_easy_FunBind loc le_RDR [a_Pat, b_Pat] $ @@ -372,37 +379,39 @@ gen_Ord_binds loc tycon (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons - mkOrdOp :: OrdOp -> LHsBind RdrName + mkOrdOp :: DynFlags -> OrdOp -> LHsBind RdrName -- Returns a binding op a b = ... compares a and b according to op .... - mkOrdOp op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat] (mkOrdOpRhs op) + mkOrdOp dflags op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat] + (mkOrdOpRhs dflags op) - mkOrdOpRhs :: OrdOp -> LHsExpr RdrName - mkOrdOpRhs op -- RHS for comparing 'a' and 'b' according to op + mkOrdOpRhs :: DynFlags -> OrdOp -> LHsExpr RdrName + mkOrdOpRhs dflags op -- RHS for comparing 'a' and 'b' according to op | length nullary_cons <= 2 -- Two nullary or fewer, so use cases = nlHsCase (nlHsVar a_RDR) $ - map (mkOrdOpAlt op) tycon_data_cons + map (mkOrdOpAlt dflags op) tycon_data_cons -- i.e. case a of { C1 x y -> case b of C1 x y -> ....compare x,y... -- C2 x -> case b of C2 x -> ....comopare x.... } | null non_nullary_cons -- All nullary, so go straight to comparing tags - = mkTagCmp op + = mkTagCmp dflags op | otherwise -- Mixed nullary and non-nullary = nlHsCase (nlHsVar a_RDR) $ - (map (mkOrdOpAlt op) non_nullary_cons - ++ [mkHsCaseAlt nlWildPat (mkTagCmp op)]) + (map (mkOrdOpAlt dflags op) non_nullary_cons + ++ [mkHsCaseAlt nlWildPat (mkTagCmp dflags op)]) - mkOrdOpAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName) + mkOrdOpAlt :: DynFlags -> OrdOp -> DataCon + -> LMatch RdrName (LHsExpr RdrName) -- Make the alternative (Ki a1 a2 .. av -> - mkOrdOpAlt op data_con + mkOrdOpAlt dflags op data_con = mkHsCaseAlt (nlConVarPat data_con_RDR as_needed) - (mkInnerRhs op data_con) + (mkInnerRhs dflags op data_con) where as_needed = take (dataConSourceArity data_con) as_RDRs data_con_RDR = getRdrName data_con - mkInnerRhs op data_con + mkInnerRhs dflags op data_con | single_con_type = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con ] @@ -425,14 +434,14 @@ gen_Ord_binds loc tycon , mkHsCaseAlt nlWildPat (gtResult op) ] | tag > last_tag `div` 2 -- lower range is larger - = untag_Expr tycon [(b_RDR, bh_RDR)] $ + = untag_Expr dflags tycon [(b_RDR, bh_RDR)] $ nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit) (gtResult op) $ -- Definitely GT nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con , mkHsCaseAlt nlWildPat (ltResult op) ] | otherwise -- upper range is larger - = untag_Expr tycon [(b_RDR, bh_RDR)] $ + = untag_Expr dflags tycon [(b_RDR, bh_RDR)] $ nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit) (ltResult op) $ -- Definitely LT nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con @@ -451,11 +460,12 @@ gen_Ord_binds loc tycon data_con_RDR = getRdrName data_con bs_needed = take (dataConSourceArity data_con) bs_RDRs - mkTagCmp :: OrdOp -> LHsExpr RdrName + mkTagCmp :: DynFlags -> OrdOp -> LHsExpr RdrName -- Both constructors known to be nullary -- genreates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b# - mkTagCmp op = untag_Expr tycon [(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $ - unliftedOrdOp tycon intPrimTy op ah_RDR bh_RDR + mkTagCmp dflags op = + untag_Expr dflags tycon[(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $ + unliftedOrdOp tycon intPrimTy op ah_RDR bh_RDR mkCompareFields :: TyCon -> OrdOp -> [Type] -> LHsExpr RdrName -- Generates nested comparisons for (a1,a2...) against (b1,b2,...) @@ -567,76 +577,78 @@ instance ... Enum (Foo ...) where For @enumFromTo@ and @enumFromThenTo@, we use the default methods. -} -gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) -gen_Enum_binds loc tycon - = (method_binds, aux_binds) +gen_Enum_binds :: SrcSpan -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff) +gen_Enum_binds loc tycon = do + dflags <- getDynFlags + return (method_binds dflags, aux_binds) where - method_binds = listToBag [ - succ_enum, - pred_enum, - to_enum, - enum_from, - enum_from_then, - from_enum - ] + method_binds dflags = listToBag + [ succ_enum dflags + , pred_enum dflags + , to_enum dflags + , enum_from dflags + , enum_from_then dflags + , from_enum dflags + ] aux_binds = listToBag $ map DerivAuxBind [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon] occ_nm = getOccString tycon - succ_enum + succ_enum dflags = mk_easy_FunBind loc succ_RDR [a_Pat] $ - untag_Expr tycon [(a_RDR, ah_RDR)] $ - nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon), + untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ + nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR dflags tycon), nlHsVarApps intDataCon_RDR [ah_RDR]]) (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration") - (nlHsApp (nlHsVar (tag2con_RDR tycon)) + (nlHsApp (nlHsVar (tag2con_RDR dflags tycon)) (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR], nlHsIntLit 1])) - pred_enum + pred_enum dflags = mk_easy_FunBind loc pred_RDR [a_Pat] $ - untag_Expr tycon [(a_RDR, ah_RDR)] $ + untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0, nlHsVarApps intDataCon_RDR [ah_RDR]]) (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration") - (nlHsApp (nlHsVar (tag2con_RDR tycon)) + (nlHsApp (nlHsVar (tag2con_RDR dflags tycon)) (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR], nlHsLit (HsInt NoSourceText (-1))])) - to_enum + to_enum dflags = mk_easy_FunBind loc toEnum_RDR [a_Pat] $ nlHsIf (nlHsApps and_RDR [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0], - nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]]) - (nlHsVarApps (tag2con_RDR tycon) [a_RDR]) - (illegal_toEnum_tag occ_nm (maxtag_RDR tycon)) + nlHsApps le_RDR [ nlHsVar a_RDR + , nlHsVar (maxtag_RDR dflags tycon)]]) + (nlHsVarApps (tag2con_RDR dflags tycon) [a_RDR]) + (illegal_toEnum_tag occ_nm (maxtag_RDR dflags tycon)) - enum_from + enum_from dflags = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $ - untag_Expr tycon [(a_RDR, ah_RDR)] $ + untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ nlHsApps map_RDR - [nlHsVar (tag2con_RDR tycon), + [nlHsVar (tag2con_RDR dflags tycon), nlHsPar (enum_from_to_Expr (nlHsVarApps intDataCon_RDR [ah_RDR]) - (nlHsVar (maxtag_RDR tycon)))] + (nlHsVar (maxtag_RDR dflags tycon)))] - enum_from_then + enum_from_then dflags = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $ - untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $ - nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $ + untag_Expr dflags tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $ + nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $ nlHsPar (enum_from_then_to_Expr (nlHsVarApps intDataCon_RDR [ah_RDR]) (nlHsVarApps intDataCon_RDR [bh_RDR]) (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR], nlHsVarApps intDataCon_RDR [bh_RDR]]) (nlHsIntLit 0) - (nlHsVar (maxtag_RDR tycon)) + (nlHsVar (maxtag_RDR dflags tycon)) )) - from_enum + from_enum dflags = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $ - untag_Expr tycon [(a_RDR, ah_RDR)] $ + untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ (nlHsVarApps intDataCon_RDR [ah_RDR]) {- @@ -734,35 +746,38 @@ we follow the scheme given in Figure~19 of the Haskell~1.2 report (p.~147). -} -gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) +gen_Ix_binds :: SrcSpan -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff) -gen_Ix_binds loc tycon - | isEnumerationTyCon tycon - = ( enum_ixes - , listToBag $ map DerivAuxBind +gen_Ix_binds loc tycon = do + dflags <- getDynFlags + return $ if isEnumerationTyCon tycon + then (enum_ixes dflags, listToBag $ map DerivAuxBind [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]) - | otherwise - = (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon))) + else (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon))) where -------------------------------------------------------------- - enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ] + enum_ixes dflags = listToBag + [ enum_range dflags + , enum_index dflags + , enum_inRange dflags + ] - enum_range + enum_range dflags = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $ - untag_Expr tycon [(a_RDR, ah_RDR)] $ - untag_Expr tycon [(b_RDR, bh_RDR)] $ - nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $ + untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ + untag_Expr dflags tycon [(b_RDR, bh_RDR)] $ + nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $ nlHsPar (enum_from_to_Expr (nlHsVarApps intDataCon_RDR [ah_RDR]) (nlHsVarApps intDataCon_RDR [bh_RDR])) - enum_index + enum_index dflags = mk_easy_FunBind loc unsafeIndex_RDR [noLoc (AsPat (noLoc c_RDR) (nlTuplePat [a_Pat, nlWildPat] Boxed)), d_Pat] ( - untag_Expr tycon [(a_RDR, ah_RDR)] ( - untag_Expr tycon [(d_RDR, dh_RDR)] ( + untag_Expr dflags tycon [(a_RDR, ah_RDR)] ( + untag_Expr dflags tycon [(d_RDR, dh_RDR)] ( let rhs = nlHsVarApps intDataCon_RDR [c_RDR] in @@ -773,11 +788,11 @@ gen_Ix_binds loc tycon ) -- This produces something like `(ch >= ah) && (ch <= bh)` - enum_inRange + enum_inRange dflags = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $ - untag_Expr tycon [(a_RDR, ah_RDR)] ( - untag_Expr tycon [(b_RDR, bh_RDR)] ( - untag_Expr tycon [(c_RDR, ch_RDR)] ( + untag_Expr dflags tycon [(a_RDR, ah_RDR)] ( + untag_Expr dflags tycon [(b_RDR, bh_RDR)] ( + untag_Expr dflags tycon [(c_RDR, ch_RDR)] ( -- This used to use `if`, which interacts badly with RebindableSyntax. -- See #11396. nlHsApps and_RDR @@ -1734,12 +1749,13 @@ The `tags' here start at zero, hence the @fIRST_TAG@ (currently one) fiddling around. -} -genAuxBindSpec :: SrcSpan -> AuxBindSpec -> (LHsBind RdrName, LSig RdrName) -genAuxBindSpec loc (DerivCon2Tag tycon) +genAuxBindSpec :: DynFlags -> SrcSpan -> AuxBindSpec + -> (LHsBind RdrName, LSig RdrName) +genAuxBindSpec dflags loc (DerivCon2Tag tycon) = (mk_FunBind loc rdr_name eqns, L loc (TypeSig [L loc rdr_name] sig_ty)) where - rdr_name = con2tag_RDR tycon + rdr_name = con2tag_RDR dflags tycon sig_ty = mkLHsSigWcType $ L loc $ HsCoreTy $ mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $ @@ -1759,7 +1775,7 @@ genAuxBindSpec loc (DerivCon2Tag tycon) nlHsLit (HsIntPrim NoSourceText (toInteger ((dataConTag con) - fIRST_TAG)))) -genAuxBindSpec loc (DerivTag2Con tycon) +genAuxBindSpec dflags loc (DerivTag2Con tycon) = (mk_FunBind loc rdr_name [([nlConVarPat intDataCon_RDR [a_RDR]], nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)], @@ -1769,13 +1785,13 @@ genAuxBindSpec loc (DerivTag2Con tycon) HsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $ intTy `mkFunTy` mkParentType tycon - rdr_name = tag2con_RDR tycon + rdr_name = tag2con_RDR dflags tycon -genAuxBindSpec loc (DerivMaxTag tycon) +genAuxBindSpec dflags loc (DerivMaxTag tycon) = (mkHsVarBind loc rdr_name rhs, L loc (TypeSig [L loc rdr_name] sig_ty)) where - rdr_name = maxtag_RDR tycon + rdr_name = maxtag_RDR dflags tycon sig_ty = mkLHsSigWcType (L loc (HsCoreTy intTy)) rhs = nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim NoSourceText max_tag)) @@ -1788,8 +1804,8 @@ type SeparateBagsDerivStuff = -- Extra family instances (used by Generic and DeriveAnyClass) , Bag (FamInst) ) -genAuxBinds :: SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff -genAuxBinds loc b = genAuxBinds' b2 where +genAuxBinds :: DynFlags -> SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff +genAuxBinds dflags loc b = genAuxBinds' b2 where (b1,b2) = partitionBagWith splitDerivAuxBind b splitDerivAuxBind (DerivAuxBind x) = Left x splitDerivAuxBind x = Right x @@ -1798,7 +1814,7 @@ genAuxBinds loc b = genAuxBinds' b2 where dup_check a b = if anyBag (== a) b then b else consBag a b genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff - genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec loc) (rm_dups b1) + genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec dflags loc) (rm_dups b1) , emptyBag ) f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before @@ -1969,11 +1985,13 @@ eq_Expr tycon ty a b where (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty -untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName -untag_Expr _ [] expr = expr -untag_Expr tycon ((untag_this, put_tag_here) : more) expr - = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-} - [mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)] +untag_Expr :: DynFlags -> TyCon -> [( RdrName, RdrName)] + -> LHsExpr RdrName -> LHsExpr RdrName +untag_Expr _ _ [] expr = expr +untag_Expr dflags tycon ((untag_this, put_tag_here) : more) expr + = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR dflags tycon) + [untag_this])) {-of-} + [mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr dflags tycon more expr)] enum_from_to_Expr :: LHsExpr RdrName -> LHsExpr RdrName @@ -2083,25 +2101,26 @@ minusInt_RDR, tagToEnum_RDR :: RdrName minusInt_RDR = getRdrName (primOpId IntSubOp ) tagToEnum_RDR = getRdrName (primOpId TagToEnumOp) -con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName +con2tag_RDR, tag2con_RDR, maxtag_RDR :: DynFlags -> TyCon -> RdrName -- Generates Orig s RdrName, for the binding positions -con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc -tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc -maxtag_RDR tycon = mk_tc_deriv_name tycon mkMaxTagOcc +con2tag_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkCon2TagOcc +tag2con_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkTag2ConOcc +maxtag_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkMaxTagOcc -mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName -mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun +mk_tc_deriv_name :: DynFlags -> TyCon -> (OccName -> OccName) -> RdrName +mk_tc_deriv_name dflags tycon occ_fun = + mkAuxBinderName dflags (tyConName tycon) occ_fun -mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName +mkAuxBinderName :: DynFlags -> Name -> (OccName -> OccName) -> RdrName -- ^ Make a top-level binder name for an auxiliary binding for a parent name -- See Note [Auxiliary binders] -mkAuxBinderName parent occ_fun +mkAuxBinderName dflags parent occ_fun = mkRdrUnqual (occ_fun stable_parent_occ) where stable_parent_occ = mkOccName (occNameSpace parent_occ) stable_string stable_string - | opt_PprStyle_Debug = parent_stable - | otherwise = parent_stable_hash + | hasPprDebug dflags = parent_stable + | otherwise = parent_stable_hash parent_stable = nameStableString parent parent_stable_hash = let Fingerprint high low = fingerprintString parent_stable diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 28ca41b078..573422a8af 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -57,7 +57,6 @@ import Plugins ( tcPlugin ) #endif import DynFlags -import StaticFlags import HsSyn import IfaceSyn ( ShowSub(..), showToHeader ) import IfaceType( ShowForAllFlag(..) ) @@ -1169,9 +1168,9 @@ missingBootThing is_boot name what <+> text "file, but not" <+> text what <+> text "the module" -badReexportedBootThing :: Bool -> Name -> Name -> SDoc -badReexportedBootThing is_boot name name' - = withPprStyle (mkUserStyle alwaysQualify AllTheWay) $ vcat +badReexportedBootThing :: DynFlags -> Bool -> Name -> Name -> SDoc +badReexportedBootThing dflags is_boot name name' + = withPprStyle (mkUserStyle dflags alwaysQualify AllTheWay) $ vcat [ text "The" <+> (if is_boot then text "hs-boot" else text "hsig") <+> text "file (re)exports" <+> quotes (ppr name) , text "but the implementing module exports a different identifier" <+> quotes (ppr name') @@ -2461,31 +2460,33 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, -- wobbling in testsuite output ppr_types :: TypeEnv -> SDoc -ppr_types type_env - = text "TYPE SIGNATURES" $$ nest 2 (ppr_sigs ids) - where +ppr_types type_env = sdocWithPprDebug $ \dbg -> + let ids = [id | id <- typeEnvIds type_env, want_sig id] - want_sig id | opt_PprStyle_Debug + want_sig id | dbg = True | otherwise = isExternalName (idName id) && (not (isDerivedOccName (getOccName id))) -- Top-level user-defined things have External names. -- Suppress internally-generated things unless -dppr-debug + in + text "TYPE SIGNATURES" $$ nest 2 (ppr_sigs ids) ppr_tycons :: [FamInst] -> TypeEnv -> SDoc -ppr_tycons fam_insts type_env - = vcat [ text "TYPE CONSTRUCTORS" - , nest 2 (ppr_tydecls tycons) - , text "COERCION AXIOMS" - , nest 2 (vcat (map pprCoAxiom (typeEnvCoAxioms type_env))) ] - where +ppr_tycons fam_insts type_env = sdocWithPprDebug $ \dbg -> + let fi_tycons = famInstsRepTyCons fam_insts tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon] - want_tycon tycon | opt_PprStyle_Debug = True - | otherwise = not (isImplicitTyCon tycon) && - isExternalName (tyConName tycon) && - not (tycon `elem` fi_tycons) + want_tycon tycon | dbg = True + | otherwise = not (isImplicitTyCon tycon) && + isExternalName (tyConName tycon) && + not (tycon `elem` fi_tycons) + in + vcat [ text "TYPE CONSTRUCTORS" + , nest 2 (ppr_tydecls tycons) + , text "COERCION AXIOMS" + , nest 2 (vcat (map pprCoAxiom (typeEnvCoAxioms type_env))) ] ppr_insts :: [ClsInst] -> SDoc ppr_insts [] = empty diff --git a/compiler/typecheck/TcRnDriver.hs-boot b/compiler/typecheck/TcRnDriver.hs-boot index 8302926337..e73855e033 100644 --- a/compiler/typecheck/TcRnDriver.hs-boot +++ b/compiler/typecheck/TcRnDriver.hs-boot @@ -1,5 +1,6 @@ module TcRnDriver where +import DynFlags (DynFlags) import Type (TyThing) import TcRnTypes (TcM) import Outputable (SDoc) @@ -8,4 +9,4 @@ import Name (Name) checkBootDeclM :: Bool -- ^ True <=> an hs-boot file (could also be a sig) -> TyThing -> TyThing -> TcM () missingBootThing :: Bool -> Name -> String -> SDoc -badReexportedBootThing :: Bool -> Name -> Name -> SDoc +badReexportedBootThing :: DynFlags -> Bool -> Name -> Name -> SDoc diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index 3c6a6c432d..a0600b14ce 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -162,7 +162,6 @@ import Bag import Outputable import UniqSupply import DynFlags -import StaticFlags import FastString import Panic import Util @@ -697,14 +696,14 @@ traceTcRn :: DumpFlag -> SDoc -> TcRn () -- for --dump-to-file, not to decide whether or not to output -- That part is done by the caller traceTcRn flag doc - = do { real_doc <- prettyDoc doc - ; dflags <- getDynFlags + = do { dflags <- getDynFlags + ; real_doc <- prettyDoc dflags doc ; printer <- getPrintUnqualified dflags ; liftIO $ dumpSDoc dflags printer flag "" real_doc } where - -- Add current location if opt_PprStyle_Debug - prettyDoc :: SDoc -> TcRn SDoc - prettyDoc doc = if opt_PprStyle_Debug + -- Add current location if -dppr-debug + prettyDoc :: DynFlags -> SDoc -> TcRn SDoc + prettyDoc dflags doc = if hasPprDebug dflags then do { loc <- getSrcSpanM; return $ mkLocMessage SevOutput loc doc } else return doc -- The full location is usually way too much @@ -1300,21 +1299,23 @@ add_err_tcm tidy_env err_msg loc ctxt mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc -- Tidy the error info, trimming excessive contexts mkErrInfo env ctxts --- | opt_PprStyle_Debug -- In -dppr-debug style the output --- = return empty -- just becomes too voluminous - | otherwise - = go 0 env ctxts +-- = do +-- dbg <- hasPprDebug <$> getDynFlags +-- if dbg -- In -dppr-debug style the output +-- then return empty -- just becomes too voluminous +-- else go dbg 0 env ctxts + = go False 0 env ctxts where - go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc - go _ _ [] = return empty - go n env ((is_landmark, ctxt) : ctxts) - | is_landmark || n < mAX_CONTEXTS -- Too verbose || opt_PprStyle_Debug + go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc + go _ _ _ [] = return empty + go dbg n env ((is_landmark, ctxt) : ctxts) + | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg = do { (env', msg) <- ctxt env ; let n' = if is_landmark then n else n+1 - ; rest <- go n' env' ctxts + ; rest <- go dbg n' env' ctxts ; return (msg $$ rest) } | otherwise - = go n env ctxts + = go dbg n env ctxts mAX_CONTEXTS :: Int -- No more than this number of non-landmark contexts mAX_CONTEXTS = 3 diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs index 8b6a816dea..7e19ea9b67 100644 --- a/compiler/typecheck/TcSMonad.hs +++ b/compiler/typecheck/TcSMonad.hs @@ -156,7 +156,6 @@ import UniqFM import UniqDFM import Maybes -import StaticFlags( opt_PprStyle_Debug ) import TrieMap import Control.Monad #if __GLASGOW_HASKELL__ > 710 @@ -362,7 +361,8 @@ instance Outputable WorkList where , ppUnless (null ders) $ text "Derived =" <+> vcat (map ppr ders) , ppUnless (isEmptyBag implics) $ - if opt_PprStyle_Debug -- Typically we only want the work list for this level + sdocWithPprDebug $ \dbg -> + if dbg -- Typically we only want the work list for this level then text "Implics =" <+> vcat (map ppr (bagToList implics)) else text "(Implics omitted)" ]) diff --git a/compiler/types/OptCoercion.hs b/compiler/types/OptCoercion.hs index a7dadf39e0..5e1f4547d9 100644 --- a/compiler/types/OptCoercion.hs +++ b/compiler/types/OptCoercion.hs @@ -12,6 +12,7 @@ module OptCoercion ( optCoercion, checkAxInstCo ) where #include "HsVersions.h" +import DynFlags import TyCoRep import Coercion import Type hiding( substTyVarBndr, substTy ) @@ -20,7 +21,6 @@ import TyCon import CoAxiom import VarSet import VarEnv -import StaticFlags ( opt_NoOptCoercion ) import Outputable import FamInstEnv ( flattenTys ) import Pair @@ -87,7 +87,7 @@ optCoercion :: TCvSubst -> Coercion -> NormalCo -- ^ optCoercion applies a substitution to a coercion, -- *and* optimises it to reduce its size optCoercion env co - | opt_NoOptCoercion = substCo env co + | hasNoOptCoercion unsafeGlobalDynFlags = substCo env co | debugIsOn = let out_co = opt_co1 lc False co (Pair in_ty1 in_ty2, in_role) = coercionKindRole co diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs index 3f94a68413..43979ffdfc 100644 --- a/compiler/utils/Outputable.hs +++ b/compiler/utils/Outputable.hs @@ -16,7 +16,7 @@ module Outputable ( -- * Pretty printing combinators SDoc, runSDoc, initSDocContext, - docToSDoc, + docToSDoc, sdocWithPprDebug, interppSP, interpp'SP, pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor, pprWithBars, @@ -81,19 +81,18 @@ module Outputable ( -- * Error handling and debugging utilities pprPanic, pprSorry, assertPprPanic, pprPgmError, - pprTrace, pprTraceIt, warnPprTrace, pprSTrace, + pprTrace, pprTraceDebug, pprTraceIt, warnPprTrace, pprSTrace, trace, pgmError, panic, sorry, assertPanic, pprDebugAndThen, callStackDoc ) where -import {-# SOURCE #-} DynFlags( DynFlags, +import {-# SOURCE #-} DynFlags( DynFlags, hasPprDebug, hasNoDebugOutput, targetPlatform, pprUserLength, pprCols, useUnicode, useUnicodeSyntax, useColor, canUseColor, overrideWith, unsafeGlobalDynFlags ) import {-# SOURCE #-} Module( UnitId, Module, ModuleName, moduleName ) import {-# SOURCE #-} OccName( OccName ) -import {-# SOURCE #-} StaticFlags( opt_PprStyle_Debug, opt_NoDebugOutput ) import BufWrite (BufHandle) import FastString @@ -245,17 +244,19 @@ neverQualify = QueryQualify neverQualifyNames neverQualifyModules neverQualifyPackages -defaultUserStyle, defaultDumpStyle :: PprStyle +defaultUserStyle :: DynFlags -> PprStyle +defaultUserStyle dflags = mkUserStyle dflags neverQualify AllTheWay -defaultUserStyle = mkUserStyle neverQualify AllTheWay +defaultDumpStyle :: DynFlags -> PprStyle -- Print without qualifiers to reduce verbosity, unless -dppr-debug +defaultDumpStyle dflags + | hasPprDebug dflags = PprDebug + | otherwise = PprDump neverQualify -defaultDumpStyle | opt_PprStyle_Debug = PprDebug - | otherwise = PprDump neverQualify - -mkDumpStyle :: PrintUnqualified -> PprStyle -mkDumpStyle print_unqual | opt_PprStyle_Debug = PprDebug - | otherwise = PprDump print_unqual +mkDumpStyle :: DynFlags -> PrintUnqualified -> PprStyle +mkDumpStyle dflags print_unqual + | hasPprDebug dflags = PprDebug + | otherwise = PprDump print_unqual defaultErrStyle :: DynFlags -> PprStyle -- Default style for error messages, when we don't know PrintUnqualified @@ -266,14 +267,15 @@ defaultErrStyle dflags = mkErrStyle dflags neverQualify -- | Style for printing error messages mkErrStyle :: DynFlags -> PrintUnqualified -> PprStyle -mkErrStyle dflags qual = mkUserStyle qual (PartWay (pprUserLength dflags)) +mkErrStyle dflags qual = + mkUserStyle dflags qual (PartWay (pprUserLength dflags)) -cmdlineParserStyle :: PprStyle -cmdlineParserStyle = mkUserStyle alwaysQualify AllTheWay +cmdlineParserStyle :: DynFlags -> PprStyle +cmdlineParserStyle dflags = mkUserStyle dflags alwaysQualify AllTheWay -mkUserStyle :: PrintUnqualified -> Depth -> PprStyle -mkUserStyle unqual depth - | opt_PprStyle_Debug = PprDebug +mkUserStyle :: DynFlags -> PrintUnqualified -> Depth -> PprStyle +mkUserStyle dflags unqual depth + | hasPprDebug dflags = PprDebug | otherwise = PprUser unqual depth Uncoloured setStyleColoured :: Bool -> PprStyle -> PprStyle @@ -340,6 +342,9 @@ withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty} withPprStyleDoc :: DynFlags -> PprStyle -> SDoc -> Doc withPprStyleDoc dflags sty d = runSDoc d (initSDocContext dflags sty) +sdocWithPprDebug :: (Bool -> SDoc) -> SDoc +sdocWithPprDebug f = sdocWithDynFlags $ \dflags -> f (hasPprDebug dflags) + pprDeeper :: SDoc -> SDoc pprDeeper d = SDoc $ \ctx -> case ctx of SDC{sdocStyle=PprUser _ (PartWay 0) _} -> Pretty.text "..." @@ -445,12 +450,14 @@ printSDocLn mode dflags handle sty doc = printForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO () printForUser dflags handle unqual doc - = printSDocLn PageMode dflags handle (mkUserStyle unqual AllTheWay) doc + = printSDocLn PageMode dflags handle + (mkUserStyle dflags unqual AllTheWay) doc printForUserPartWay :: DynFlags -> Handle -> Int -> PrintUnqualified -> SDoc -> IO () printForUserPartWay dflags handle d unqual doc - = printSDocLn PageMode dflags handle (mkUserStyle unqual (PartWay d)) doc + = printSDocLn PageMode dflags handle + (mkUserStyle dflags unqual (PartWay d)) doc -- | Like 'printSDocLn' but specialized with 'LeftMode' and -- @'PprCode' 'CStyle'@. This is typically used to output C-- code. @@ -474,7 +481,7 @@ mkCodeStyle = PprCode -- However, Doc *is* an instance of Show -- showSDoc just blasts it out as a string showSDoc :: DynFlags -> SDoc -> String -showSDoc dflags sdoc = renderWithStyle dflags sdoc defaultUserStyle +showSDoc dflags sdoc = renderWithStyle dflags sdoc (defaultUserStyle dflags) -- showSDocUnsafe is unsafe, because `unsafeGlobalDynFlags` might not be -- initialised yet. @@ -491,10 +498,10 @@ showSDocUnqual dflags sdoc = showSDoc dflags sdoc showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String -- Allows caller to specify the PrintUnqualified to use showSDocForUser dflags unqual doc - = renderWithStyle dflags doc (mkUserStyle unqual AllTheWay) + = renderWithStyle dflags doc (mkUserStyle dflags unqual AllTheWay) showSDocDump :: DynFlags -> SDoc -> String -showSDocDump dflags d = renderWithStyle dflags d defaultDumpStyle +showSDocDump dflags d = renderWithStyle dflags d (defaultDumpStyle dflags) showSDocDebug :: DynFlags -> SDoc -> String showSDocDebug dflags d = renderWithStyle dflags d PprDebug @@ -512,13 +519,15 @@ showSDocOneLine :: DynFlags -> SDoc -> String showSDocOneLine dflags d = let s = Pretty.style{ Pretty.mode = OneLineMode, Pretty.lineLength = pprCols dflags } in - Pretty.renderStyle s $ runSDoc d (initSDocContext dflags defaultUserStyle) + Pretty.renderStyle s $ + runSDoc d (initSDocContext dflags (defaultUserStyle dflags)) showSDocDumpOneLine :: DynFlags -> SDoc -> String showSDocDumpOneLine dflags d = let s = Pretty.style{ Pretty.mode = OneLineMode, Pretty.lineLength = irrelevantNCols } in - Pretty.renderStyle s $ runSDoc d (initSDocContext dflags defaultDumpStyle) + Pretty.renderStyle s $ + runSDoc d (initSDocContext dflags (defaultDumpStyle dflags)) irrelevantNCols :: Int -- Used for OneLineMode and LeftMode when number of cols isn't used @@ -1191,12 +1200,17 @@ pprPgmError :: String -> SDoc -> a -- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors) pprPgmError = pgmErrorDoc +pprTraceDebug :: String -> SDoc -> a -> a +pprTraceDebug str doc x + | debugIsOn && hasPprDebug unsafeGlobalDynFlags = pprTrace str doc x + | otherwise = x pprTrace :: String -> SDoc -> a -> a -- ^ If debug output is on, show some 'SDoc' on the screen pprTrace str doc x - | opt_NoDebugOutput = x - | otherwise = pprDebugAndThen unsafeGlobalDynFlags trace (text str) doc x + | hasNoDebugOutput unsafeGlobalDynFlags = x + | otherwise = + pprDebugAndThen unsafeGlobalDynFlags trace (text str) doc x -- | @pprTraceIt desc x@ is equivalent to @pprTrace desc (ppr x) x@ pprTraceIt :: Outputable a => String -> a -> a @@ -1212,7 +1226,8 @@ warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a -- ^ Just warn about an assertion failure, recording the given file and line number. -- Should typically be accessed with the WARN macros warnPprTrace _ _ _ _ x | not debugIsOn = x -warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x +warnPprTrace _ _file _line _msg x + | hasNoDebugOutput unsafeGlobalDynFlags = x warnPprTrace False _file _line _msg x = x warnPprTrace True file line msg x = pprDebugAndThen unsafeGlobalDynFlags trace heading msg x diff --git a/ghc/Main.hs b/ghc/Main.hs index a650d35a62..0984bf7935 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -46,7 +46,6 @@ import HscTypes import Packages ( pprPackages, pprPackagesSimple ) import DriverPhases import BasicTypes ( failed ) -import StaticFlags import DynFlags import ErrUtils import FastString @@ -113,13 +112,10 @@ main = do mbMinusB | null minusB_args = Nothing | otherwise = Just (drop 2 (last minusB_args)) - let argv1' = map (mkGeneralLocated "on the commandline") argv1 - (argv2, staticFlagWarnings) <- parseStaticFlags argv1' + let argv2 = map (mkGeneralLocated "on the commandline") argv1 -- 2. Parse the "mode" flags (--make, --interactive etc.) - (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2 - - let flagWarnings = staticFlagWarnings ++ modeFlagWarnings + (mode, argv3, flagWarnings) <- parseModeFlags argv2 -- If all we want to do is something like showing the version number -- then do it now, before we start a GHC session etc. This makes @@ -239,10 +235,6 @@ main' postLoadMode dflags0 args flagWarnings = do | v >= 5 -> liftIO $ dumpPackages dflags6 | otherwise -> return () - when (verbosity dflags6 >= 3) $ do - liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags) - - liftIO $ initUniqSupply (initialUnique dflags6) (uniqueIncrement dflags6) ---------------- Final sanity checking ----------- liftIO $ checkOptions postLoadMode dflags6 srcs objs @@ -775,17 +767,9 @@ showOptions isInteractive = putStr (unlines availableOptions) where availableOptions = concat [ flagsForCompletion isInteractive, - map ('-':) (concat [ - getFlagNames mode_flags - , (filterUnwantedStatic . getFlagNames $ flagsStatic) - , flagsStaticNames - ]) + map ('-':) (getFlagNames mode_flags) ] getFlagNames opts = map flagName opts - -- this is a hack to get rid of two unwanted entries that get listed - -- as static flags. Hopefully this hack will disappear one day together - -- with static flags - filterUnwantedStatic = filter (`notElem`["f", "fno-"]) showGhcUsage :: DynFlags -> IO () showGhcUsage = showUsage False diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c index b5e4f8e8bf..3f7610c1b5 100644 --- a/rts/RtsSymbols.c +++ b/rts/RtsSymbols.c @@ -599,8 +599,6 @@ SymI_HasProto(getOrSetLibHSghcPersistentLinkerState) \ SymI_HasProto(getOrSetLibHSghcInitLinkerDone) \ SymI_HasProto(getOrSetLibHSghcGlobalDynFlags) \ - SymI_HasProto(getOrSetLibHSghcStaticOptions) \ - SymI_HasProto(getOrSetLibHSghcStaticOptionsReady) \ SymI_HasProto(genericRaise) \ SymI_HasProto(getProgArgv) \ SymI_HasProto(getFullProgArgv) \ diff --git a/testsuite/tests/ghc-api/T10052/T10052.hs b/testsuite/tests/ghc-api/T10052/T10052.hs index c2df4ae983..a2e50a6bc6 100644 --- a/testsuite/tests/ghc-api/T10052/T10052.hs +++ b/testsuite/tests/ghc-api/T10052/T10052.hs @@ -16,11 +16,10 @@ main = do runGhc' :: [String] -> Ghc a -> IO a runGhc' args act = do let libdir = head args - flags = tail args - (dynFlags, _warns) <- parseStaticFlags (map noLoc flags) + flags = map noLoc (tail args) runGhc (Just libdir) $ do dflags0 <- getSessionDynFlags - (dflags1, _leftover, _warns) <- parseDynamicFlags dflags0 dynFlags + (dflags1, _leftover, _warns) <- parseDynamicFlags dflags0 flags let dflags2 = dflags1 { hscTarget = HscInterpreted , ghcLink = LinkInMemory diff --git a/testsuite/tests/plugins/LinkerTicklingPlugin.hs b/testsuite/tests/plugins/LinkerTicklingPlugin.hs index 52d5e177bb..260d4c1228 100644 --- a/testsuite/tests/plugins/LinkerTicklingPlugin.hs +++ b/testsuite/tests/plugins/LinkerTicklingPlugin.hs @@ -1,15 +1,15 @@ module LinkerTicklingPlugin where import GhcPlugins -import StaticFlags +import DynFlags plugin :: Plugin plugin = defaultPlugin { installCoreToDos = install } --- This tests whether plugins are linking against the *running* GHC --- or a new instance of it. If it is a new instance the staticFlags --- won't have been initialised, so we'll get a GHC panic here: +-- This tests whether plugins are linking against the *running* GHC or a new +-- instance of it. If it is a new instance (settings unsafeGlobalDynFlags) won't +-- have been initialised, so we'll get a GHC panic here: install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] -install _options todos = length staticFlags `seq` return todos +install _options todos = settings unsafeGlobalDynFlags `seq` return todos diff --git a/utils/haddock b/utils/haddock -Subproject 7f1987b35eb7bb15ca2fd93321440af519dd8cd +Subproject dbbdabfd3842f70c78d4c64e10f75f47fe5c0f5 |