Ditch static flags
authorSylvain Henry <sylvain@haskus.fr>
Thu, 2 Feb 2017 19:37:24 +0000 (14:37 -0500)
committerBen Gamari <ben@smart-cactus.org>
Fri, 3 Feb 2017 03:13:53 +0000 (22:13 -0500)
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

51 files changed:
compiler/backpack/DriverBkp.hs
compiler/basicTypes/BasicTypes.hs
compiler/basicTypes/Id.hs
compiler/basicTypes/RdrName.hs
compiler/basicTypes/VarEnv.hs
compiler/cmm/CmmParse.y
compiler/coreSyn/CoreLint.hs
compiler/deSugar/Coverage.hs
compiler/ghc.cabal.in
compiler/ghc.mk
compiler/ghci/Linker.hs
compiler/ghci/RtClosureInspect.hs
compiler/hsSyn/HsExpr.hs
compiler/hsSyn/HsTypes.hs
compiler/iface/BinIface.hs
compiler/iface/IfaceSyn.hs
compiler/iface/IfaceType.hs
compiler/iface/LoadIface.hs
compiler/llvmGen/LlvmCodeGen/Base.hs
compiler/main/CmdLineParser.hs
compiler/main/CodeOutput.hs
compiler/main/DriverPipeline.hs
compiler/main/DynFlags.hs
compiler/main/DynFlags.hs-boot
compiler/main/ErrUtils.hs
compiler/main/GHC.hs
compiler/main/StaticFlags.hs [deleted file]
compiler/main/StaticFlags.hs-boot [deleted file]
compiler/main/SysTools.hs
compiler/main/TidyPgm.hs
compiler/simplCore/CoreMonad.hs
compiler/simplCore/SimplCore.hs
compiler/simplStg/SimplStg.hs
compiler/specialise/Rules.hs
compiler/specialise/SpecConstr.hs
compiler/typecheck/TcBackpack.hs
compiler/typecheck/TcDeriv.hs
compiler/typecheck/TcDerivUtils.hs
compiler/typecheck/TcErrors.hs
compiler/typecheck/TcGenDeriv.hs
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcRnDriver.hs-boot
compiler/typecheck/TcRnMonad.hs
compiler/typecheck/TcSMonad.hs
compiler/types/OptCoercion.hs
compiler/utils/Outputable.hs
ghc/Main.hs
rts/RtsSymbols.c
testsuite/tests/ghc-api/T10052/T10052.hs
testsuite/tests/plugins/LinkerTicklingPlugin.hs
utils/haddock

index 595cb25..25ef624 100644 (file)
@@ -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
index ff4d2c7..a23255b 100644 (file)
@@ -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
 
 {-
 ************************************************************************
index acb22e8..64b87ff 100644 (file)
@@ -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
index 321b13a..022cfe7 100644 (file)
@@ -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)]
index 64357d7..3177abb 100644 (file)
@@ -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)
 
 {-
index c836e2c..e742593 100644 (file)
@@ -239,7 +239,6 @@ import Unique
 import UniqFM
 import SrcLoc
 import DynFlags
-import StaticFlags
 import ErrUtils
 import StringBuffer
 import FastString
index a776038..f87989d 100644 (file)
@@ -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
index 7faf8fb..ddab00c 100644 (file)
@@ -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)
 
index 1da783d..0d1a45b 100644 (file)
@@ -353,7 +353,6 @@ Library
         Plugins
         TcPluginM
         PprTyThing
-        StaticFlags
         StaticPtrTable
         SysTools
         SysTools.Terminal
index d8e3a52..df16483 100644 (file)
@@ -531,7 +531,6 @@ compiler_stage2_dll0_MODULES = \
        RdrName \
        Rules \
        SrcLoc \
-       StaticFlags \
        StringBuffer \
        SysTools.Terminal \
        TcEvidence \
index 76c1cda..e89f1bb 100644 (file)
@@ -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 ()
index 03b2f95..b63c1c9 100644 (file)
@@ -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
index e4d8431..617972d 100644 (file)
@@ -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
index c974d1f..998f8bd 100644 (file)
@@ -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
index ad1e845..60f0447 100644 (file)
@@ -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 ()
index 7740977..9a69b39 100644 (file)
@@ -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 #-}" <>
index 0dded21..75a2afc 100644 (file)
@@ -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
index 75f2b6a..0890e20 100644 (file)
@@ -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 "
index eb4a863..1464531 100644 (file)
@@ -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)
 
index 0a24be5..6d6edca 100644 (file)
@@ -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
 --
index f4681dc..df9b7f3 100644 (file)
@@ -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
                                        }
index 463b715..adebdf4 100644 (file)
@@ -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.")
 
index 682480b..d7a5f1f 100644 (file)
@@ -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
index 9e6a0d4..14c039a 100644 (file)
@@ -16,3 +16,5 @@ useUnicodeSyntax     :: DynFlags -> Bool
 useColor             :: DynFlags -> OverridingBool
 canUseColor          :: DynFlags -> Bool
 overrideWith         :: Bool -> OverridingBool -> Bool
+hasPprDebug          :: DynFlags -> Bool
+hasNoDebugOutput     :: DynFlags -> Bool
index 2aeddc2..94ea96e 100644 (file)
@@ -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
index bc406d5..f8f3ba9 100644 (file)
@@ -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 (file)
index b5be9ba..0000000
+++ /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 (file)
index 53ee13b..0000000
+++ /dev/null
@@ -1,4 +0,0 @@
-module StaticFlags where
-
-opt_PprStyle_Debug :: Bool
-opt_NoDebugOutput  :: Bool
index 6777194..17ce634 100644 (file)
@@ -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
index 0fc153a..0c8f491 100644 (file)
@@ -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)
index 7b80776..087410c 100644 (file)
@@ -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 }
 
index f032aad..23faac8 100644 (file)
@@ -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 }
index 08f9d79..ed04327 100644 (file)
@@ -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
 
index ba44794..1681041 100644 (file)
@@ -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
index 5ee2dec..f6e10ad 100644 (file)
@@ -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 {
 
index 9a428a8..ce8ab7a 100644 (file)
@@ -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)
index 4fcd690..a6ddb81 100644 (file)
@@ -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
index b9931ff..b142b33 100644 (file)
@@ -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)
index 9294b78..eaccc2d 100644 (file)
@@ -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;" <+>
index 81bda8e..533664e 100644 (file)
@@ -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
index 28ca41b..573422a 100644 (file)
@@ -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
index 8302926..e73855e 100644 (file)
@@ -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
index 3c6a6c4..a0600b1 100644 (file)
@@ -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
index 8b6a816..7e19ea9 100644 (file)
@@ -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)"
           ])
index a7dadf3..5e1f454 100644 (file)
@@ -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
index 3f94a68..43979ff 100644 (file)
@@ -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
index a650d35..0984bf7 100644 (file)
@@ -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
index b5e4f8e..3f7610c 100644 (file)
       SymI_HasProto(getOrSetLibHSghcPersistentLinkerState)              \
       SymI_HasProto(getOrSetLibHSghcInitLinkerDone)                     \
       SymI_HasProto(getOrSetLibHSghcGlobalDynFlags)                     \
-      SymI_HasProto(getOrSetLibHSghcStaticOptions)                      \
-      SymI_HasProto(getOrSetLibHSghcStaticOptionsReady)                 \
       SymI_HasProto(genericRaise)                                       \
       SymI_HasProto(getProgArgv)                                        \
       SymI_HasProto(getFullProgArgv)                                    \
index c2df4ae..a2e50a6 100644 (file)
@@ -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
index 52d5e17..260d4c1 100644 (file)
@@ -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
index 7f1987b..dbbdabf 160000 (submodule)
@@ -1 +1 @@
-Subproject commit 7f1987b35eb7bb15ca2fd93321440af519dd8cd5
+Subproject commit dbbdabfd3842f70c78d4c64e10f75f47fe5c0f5d