diff options
| -rw-r--r-- | compiler/basicTypes/Name.lhs | 24 | ||||
| -rw-r--r-- | compiler/basicTypes/OccName.lhs | 8 | ||||
| -rw-r--r-- | compiler/basicTypes/Var.lhs | 4 | ||||
| -rw-r--r-- | compiler/coreSyn/PprCore.lhs | 57 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 37 | ||||
| -rw-r--r-- | compiler/main/StaticFlagParser.hs | 8 | ||||
| -rw-r--r-- | compiler/main/StaticFlags.hs | 59 | ||||
| -rw-r--r-- | compiler/prelude/PrelNames.lhs-boot | 9 | ||||
| -rw-r--r-- | docs/users_guide/flags.xml | 16 |
9 files changed, 108 insertions, 114 deletions
diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index de8bd7dae7..76018614bf 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -88,7 +88,7 @@ import Unique import Util import Maybes import Binary -import StaticFlags +import DynFlags import FastTypes import FastString import Outputable @@ -465,8 +465,10 @@ pprExternal sty uniq mod occ name is_wired is_builtin | BuiltInSyntax <- is_builtin = ppr_occ_name occ -- Never qualify builtin syntax | otherwise = pprModulePrefix sty mod name <> ppr_occ_name occ where - pp_mod | opt_SuppressModulePrefixes = empty - | otherwise = ppr mod <> dot + pp_mod = sdocWithDynFlags $ \dflags -> + if dopt Opt_SuppressModulePrefixes dflags + then empty + else ppr mod <> dot pprInternal :: PprStyle -> Unique -> OccName -> SDoc pprInternal sty uniq occ @@ -493,11 +495,11 @@ pprSystem sty uniq occ pprModulePrefix :: PprStyle -> Module -> Name -> SDoc -- Print the "M." part of a name, based on whether it's in scope or not -- See Note [Printing original names] in HscTypes -pprModulePrefix sty mod name - | opt_SuppressModulePrefixes = empty - - | otherwise - = case qualName sty name of -- See Outputable.QualifyName: +pprModulePrefix sty mod name = sdocWithDynFlags $ \dflags -> + if dopt Opt_SuppressModulePrefixes dflags + then empty + else + case qualName sty name of -- See Outputable.QualifyName: NameQual modname -> ppr modname <> dot -- Name is in scope NameNotInScope1 -> ppr mod <> dot -- Not in scope NameNotInScope2 -> ppr (modulePackageId mod) <> colon -- Module not in @@ -508,8 +510,10 @@ ppr_underscore_unique :: Unique -> SDoc -- Print an underscore separating the name from its unique -- But suppress it if we aren't printing the uniques anyway ppr_underscore_unique uniq - | opt_SuppressUniques = empty - | otherwise = char '_' <> pprUnique uniq + = sdocWithDynFlags $ \dflags -> + if dopt Opt_SuppressUniques dflags + then empty + else char '_' <> pprUnique uniq ppr_occ_name :: OccName -> SDoc ppr_occ_name occ = ftext (occNameFS occ) diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs index a162040d13..74fbeb7fff 100644 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@ -109,12 +109,12 @@ module OccName ( import Util import Unique import BasicTypes +import DynFlags import UniqFM import UniqSet import FastString import Outputable import Binary -import StaticFlags( opt_SuppressUniques ) import Data.Char import Data.Data \end{code} @@ -271,8 +271,10 @@ pprOccName (OccName sp occ) pp_debug sty | debugStyle sty = braces (pprNameSpaceBrief sp) | otherwise = empty - pp_occ | opt_SuppressUniques = text (strip_th_unique (unpackFS occ)) - | otherwise = ftext occ + pp_occ = sdocWithDynFlags $ \dflags -> + if dopt Opt_SuppressUniques dflags + then text (strip_th_unique (unpackFS occ)) + else ftext occ -- See Note [Suppressing uniques in OccNames] strip_th_unique ('[' : c : _) | isAlphaNum c = [] diff --git a/compiler/basicTypes/Var.lhs b/compiler/basicTypes/Var.lhs index c6e743fbb3..42c0e7f026 100644 --- a/compiler/basicTypes/Var.lhs +++ b/compiler/basicTypes/Var.lhs @@ -86,8 +86,6 @@ import FastTypes import FastString import Outputable --- import StaticFlags ( opt_SuppressVarKinds ) - import Data.Data \end{code} @@ -217,7 +215,7 @@ After CoreTidy, top-level LocalIds are turned into GlobalIds instance Outputable Var where ppr var = ppr (varName var) <+> ifPprDebug (brackets (ppr_debug var)) -- Printing the type on every occurrence is too much! --- <+> if (not opt_SuppressVarKinds) +-- <+> if (not (dopt Opt_SuppressVarKinds dflags)) -- then ifPprDebug (text "::" <+> ppr (tyVarKind var) <+> text ")") -- else empty diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index 3ca8c48855..bc3dc7a7f3 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -25,7 +25,6 @@ import TyCon import Type import Coercion import DynFlags -import StaticFlags import BasicTypes import Util import Outputable @@ -119,9 +118,11 @@ ppr_expr add_par (Cast expr co) sep [pprParendExpr expr, ptext (sLit "`cast`") <+> pprCo co] where - pprCo co | opt_SuppressCoercions = ptext (sLit "...") - | otherwise = parens - $ sep [ppr co, dcolon <+> pprEqPred (coercionKind co)] + pprCo co = sdocWithDynFlags $ \dflags -> + if dopt Opt_SuppressCoercions dflags + then ptext (sLit "...") + else parens $ + sep [ppr co, dcolon <+> pprEqPred (coercionKind co)] ppr_expr add_par expr@(Lam _ _) @@ -250,8 +251,10 @@ ppr_case_pat con args -- | Pretty print the argument in a function application. pprArg :: OutputableBndr a => Expr a -> SDoc pprArg (Type ty) - | opt_SuppressTypeApplications = empty - | otherwise = ptext (sLit "@") <+> pprParendType ty + = sdocWithDynFlags $ \dflags -> + if dopt Opt_SuppressTypeApplications dflags + then empty + else ptext (sLit "@") <+> pprParendType ty pprArg (Coercion co) = ptext (sLit "@~") <+> pprParendCo co pprArg expr = pprParendExpr expr \end{code} @@ -284,12 +287,18 @@ pprUntypedBinder binder pprTypedLamBinder :: BindingSite -> Bool -> Var -> SDoc -- For lambda and case binders, show the unfolding info (usually none) pprTypedLamBinder bind_site debug_on var - | not debug_on && isDeadBinder var = char '_' - | not debug_on, CaseBind <- bind_site = pprUntypedBinder var -- No parens, no kind info - | opt_SuppressAll = pprUntypedBinder var -- Suppress the signature - | isTyVar var = parens (pprKindedTyVarBndr var) - | otherwise = parens (hang (pprIdBndr var) - 2 (vcat [ dcolon <+> pprType (idType var), pp_unf])) + = sdocWithDynFlags $ \dflags -> + case () of + _ + | not debug_on && isDeadBinder var -> char '_' + | not debug_on, CaseBind <- bind_site -> -- No parens, no kind info + pprUntypedBinder var + | dopt Opt_SuppressTypeSignatures dflags -> -- Suppress the signature + pprUntypedBinder var + | isTyVar var -> parens (pprKindedTyVarBndr var) + | otherwise -> + parens (hang (pprIdBndr var) + 2 (vcat [ dcolon <+> pprType (idType var), pp_unf])) where unf_info = unfoldingInfo (idInfo var) pp_unf | hasSomeUnfolding unf_info = ptext (sLit "Unf=") <> ppr unf_info @@ -298,9 +307,12 @@ pprTypedLamBinder bind_site debug_on var pprTypedLetBinder :: Var -> SDoc -- Print binder with a type or kind signature (not paren'd) pprTypedLetBinder binder - | isTyVar binder = pprKindedTyVarBndr binder - | opt_SuppressTypeSignatures = pprIdBndr binder - | otherwise = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder)) + = sdocWithDynFlags $ \dflags -> + case () of + _ + | isTyVar binder -> pprKindedTyVarBndr binder + | dopt Opt_SuppressTypeSignatures dflags -> pprIdBndr binder + | otherwise -> hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder)) pprKindedTyVarBndr :: TyVar -> SDoc -- Print a type variable binder with its kind (but not if *) @@ -314,9 +326,10 @@ pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id) pprIdBndrInfo :: IdInfo -> SDoc pprIdBndrInfo info - | opt_SuppressIdInfo = empty - | otherwise - = megaSeqIdInfo info `seq` doc -- The seq is useful for poking on black holes + = sdocWithDynFlags $ \dflags -> + if dopt Opt_SuppressIdInfo dflags + then empty + else megaSeqIdInfo info `seq` doc -- The seq is useful for poking on black holes where prag_info = inlinePragInfo info occ_info = occInfo info @@ -344,9 +357,11 @@ pprIdBndrInfo info \begin{code} ppIdInfo :: Id -> IdInfo -> SDoc ppIdInfo id info - | opt_SuppressIdInfo = empty - | otherwise - = showAttributes + = sdocWithDynFlags $ \dflags -> + if dopt Opt_SuppressIdInfo dflags + then empty + else + showAttributes [ (True, pp_scope <> ppr (idDetails id)) , (has_arity, ptext (sLit "Arity=") <> int arity) , (has_caf_info, ptext (sLit "Caf=") <> ppr caf_info) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index feaa3b54ce..dfbc9da287 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -125,7 +125,7 @@ module DynFlags ( import Platform import Module import PackageConfig -import PrelNames ( mAIN ) +import {-# SOURCE #-} PrelNames ( mAIN ) import {-# SOURCE #-} Packages (PackageState) import DriverPhases ( Phase(..), phaseInputExt ) import Config @@ -345,6 +345,23 @@ data DynFlag -- instead of just the start position. | Opt_PprCaseAsLet + -- Suppress all coercions, them replacing with '...' + | Opt_SuppressCoercions + | Opt_SuppressVarKinds + -- Suppress module id prefixes on variables. + | Opt_SuppressModulePrefixes + -- Suppress type applications. + | Opt_SuppressTypeApplications + -- Suppress info such as arity and unfoldings on identifiers. + | Opt_SuppressIdInfo + -- Suppress separate type signatures in core, but leave types on + -- lambda bound vars + | Opt_SuppressTypeSignatures + -- Suppress unique ids on variables. + -- Except for uniques, as some simplifier phases introduce new + -- variables that have otherwise identical names. + | Opt_SuppressUniques + -- temporary flags | Opt_RunCPS | Opt_RunCPSZ @@ -1914,6 +1931,15 @@ dynamic_flags = [ , Flag "dppr-user-length" (intSuffix (\n d -> d{ pprUserLength = n })) , Flag "dppr-cols" (intSuffix (\n d -> d{ pprCols = n })) , Flag "dtrace-level" (intSuffix (\n d -> d{ traceLevel = n })) + -- Suppress all that is suppressable in core dumps. + -- Except for uniques, as some simplifier phases introduce new varibles that + -- have otherwise identical names. + , Flag "dsuppress-all" (NoArg $ do setDynFlag Opt_SuppressCoercions + setDynFlag Opt_SuppressVarKinds + setDynFlag Opt_SuppressModulePrefixes + setDynFlag Opt_SuppressTypeApplications + setDynFlag Opt_SuppressIdInfo + setDynFlag Opt_SuppressTypeSignatures) ------ Debugging ---------------------------------------------------- , Flag "dstg-stats" (NoArg (setDynFlag Opt_StgStats)) @@ -2229,7 +2255,14 @@ negatableFlags = [ -- | These @-d\<blah\>@ flags can all be reversed with @-dno-\<blah\>@ dFlags :: [FlagSpec DynFlag] dFlags = [ - ( "ppr-case-as-let", Opt_PprCaseAsLet, nop ) ] + ( "suppress-coercions", Opt_SuppressCoercions, nop), + ( "suppress-var-kinds", Opt_SuppressVarKinds, nop), + ( "suppress-module-prefixes", Opt_SuppressModulePrefixes, nop), + ( "suppress-type-applications", Opt_SuppressTypeApplications, nop), + ( "suppress-idinfo", Opt_SuppressIdInfo, nop), + ( "suppress-type-signatures", Opt_SuppressTypeSignatures, nop), + ( "suppress-uniques", Opt_SuppressUniques, nop), + ( "ppr-case-as-let", Opt_PprCaseAsLet, nop)] -- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@ fFlags :: [FlagSpec DynFlag] diff --git a/compiler/main/StaticFlagParser.hs b/compiler/main/StaticFlagParser.hs index e0c9143901..cbdeb60d90 100644 --- a/compiler/main/StaticFlagParser.hs +++ b/compiler/main/StaticFlagParser.hs @@ -92,14 +92,6 @@ flagsStatic :: [Flag IO] flagsStatic = [ ------ Debugging ---------------------------------------------------- Flag "dppr-debug" (PassFlag addOpt) - , Flag "dsuppress-all" (PassFlag addOpt) - , Flag "dsuppress-uniques" (PassFlag addOpt) - , Flag "dsuppress-coercions" (PassFlag addOpt) - , Flag "dsuppress-module-prefixes" (PassFlag addOpt) - , Flag "dsuppress-type-applications" (PassFlag addOpt) - , Flag "dsuppress-idinfo" (PassFlag addOpt) - , Flag "dsuppress-var-kinds" (PassFlag addOpt) - , Flag "dsuppress-type-signatures" (PassFlag addOpt) , Flag "dno-debug-output" (PassFlag addOpt) -- rest of the debugging flags are dynamic diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index 4414f6b509..e7dbdb02c2 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -29,16 +29,6 @@ module StaticFlags ( opt_PprStyle_Debug, opt_NoDebugOutput, - -- Suppressing boring aspects of core dumps - opt_SuppressAll, - opt_SuppressUniques, - opt_SuppressCoercions, - opt_SuppressModulePrefixes, - opt_SuppressTypeApplications, - opt_SuppressIdInfo, - opt_SuppressTypeSignatures, - opt_SuppressVarKinds, - -- language opts opt_DictsStrict, @@ -172,55 +162,6 @@ unpacked_opts = -} -- debugging options --- | Suppress all that is suppressable in core dumps. --- Except for uniques, as some simplifier phases introduce new varibles that --- have otherwise identical names. -opt_SuppressAll :: Bool -opt_SuppressAll - = lookUp (fsLit "-dsuppress-all") - --- | Suppress all coercions, them replacing with '...' -opt_SuppressCoercions :: Bool -opt_SuppressCoercions - = lookUp (fsLit "-dsuppress-all") - || lookUp (fsLit "-dsuppress-coercions") - -opt_SuppressVarKinds :: Bool -opt_SuppressVarKinds - = lookUp (fsLit "-dsuppress-all") - || lookUp (fsLit "-dsuppress-var-kinds") - --- | Suppress module id prefixes on variables. -opt_SuppressModulePrefixes :: Bool -opt_SuppressModulePrefixes - = lookUp (fsLit "-dsuppress-all") - || lookUp (fsLit "-dsuppress-module-prefixes") - --- | Suppress type applications. -opt_SuppressTypeApplications :: Bool -opt_SuppressTypeApplications - = lookUp (fsLit "-dsuppress-all") - || lookUp (fsLit "-dsuppress-type-applications") - --- | Suppress info such as arity and unfoldings on identifiers. -opt_SuppressIdInfo :: Bool -opt_SuppressIdInfo - = lookUp (fsLit "-dsuppress-all") - || lookUp (fsLit "-dsuppress-idinfo") - --- | Suppress separate type signatures in core, but leave types on lambda bound vars -opt_SuppressTypeSignatures :: Bool -opt_SuppressTypeSignatures - = lookUp (fsLit "-dsuppress-all") - || lookUp (fsLit "-dsuppress-type-signatures") - --- | Suppress unique ids on variables. --- Except for uniques, as some simplifier phases introduce new variables that --- have otherwise identical names. -opt_SuppressUniques :: Bool -opt_SuppressUniques - = lookUp (fsLit "-dsuppress-uniques") - opt_PprStyle_Debug :: Bool opt_PprStyle_Debug = lookUp (fsLit "-dppr-debug") diff --git a/compiler/prelude/PrelNames.lhs-boot b/compiler/prelude/PrelNames.lhs-boot new file mode 100644 index 0000000000..c14695b060 --- /dev/null +++ b/compiler/prelude/PrelNames.lhs-boot @@ -0,0 +1,9 @@ + +\begin{code} +module PrelNames where + +import Module + +mAIN :: Module +\end{code} + diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index 26c4464642..0714fa6c3d 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -2742,44 +2742,44 @@ </row> <row> <entry><option>-dsuppress-all</option></entry> - <entry>In core dumps, suppress everything that is suppressable.</entry> - <entry>static</entry> + <entry>In core dumps, suppress everything (except for uniques) that is suppressable.</entry> + <entry>dynamic</entry> <entry>-</entry> </row> <row> <entry><option>-dsuppress-uniques</option></entry> <entry>Suppress the printing of uniques in debug output (easier to use <command>diff</command>)</entry> - <entry>static</entry> + <entry>dynamic</entry> <entry>-</entry> </row> <row> <entry><option>-dsuppress-idinfo</option></entry> <entry>Suppress extended information about identifiers where they are bound</entry> - <entry>static</entry> + <entry>dynamic</entry> <entry>-</entry> </row> <row> <entry><option>-dsuppress-module-prefixes</option></entry> <entry>Suppress the printing of module qualification prefixes</entry> - <entry>static</entry> + <entry>dynamic</entry> <entry>-</entry> </row> <row> <entry><option>-dsuppress-type-signatures</option></entry> <entry>Suppress type signatures</entry> - <entry>static</entry> + <entry>dynamic</entry> <entry>-</entry> </row> <row> <entry><option>-dsuppress-type-applications</option></entry> <entry>Suppress type applications</entry> - <entry>static</entry> + <entry>dynamic</entry> <entry>-</entry> </row> <row> <entry><option>-dsuppress-coercions</option></entry> <entry>Suppress the printing of coercions in Core dumps to make them shorter</entry> - <entry>static</entry> + <entry>dynamic</entry> <entry>-</entry> </row> <row> |