Permalink
Browse files

Merge remote branch 'upstream/master'

  • Loading branch information...
2 parents e292da6 + 80fcdd6 commit 9810529e3ae4bab7c138e800b558a2a173f55338 @jberthold committed Oct 10, 2012
@@ -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)
@@ -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 = []
@@ -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
@@ -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)
@@ -40,7 +40,6 @@ import CoreFVs
import MkCore
import DynFlags
-import StaticFlags
import CostCentre
import Id
import VarSet
@@ -688,8 +687,8 @@ dsExplicitList elt_ty xs
= do { dflags <- getDynFlags
; xs' <- mapM dsLExpr xs
; let (dynamic_prefix, static_suffix) = spanTail is_static xs'
- ; if opt_SimpleListLiterals -- -fsimple-list-literals
- || not (dopt Opt_EnableRewriteRules dflags) -- Rewrite rules off
+ ; if dopt Opt_SimpleListLiterals dflags -- -fsimple-list-literals
+ || not (dopt Opt_EnableRewriteRules dflags) -- Rewrite rules off
-- Don't generate a build if there are no rules to eliminate it!
-- See Note [Desugaring RULE left hand sides] in Desugar
|| null dynamic_prefix -- Avoid build (\c n. foldr c n xs)!
View
@@ -253,7 +253,18 @@ PRIMOP_BITS = compiler/primop-data-decl.hs-incl \
compiler_CPP_OPTS += $(addprefix -I,$(GHC_INCLUDE_DIRS))
compiler_CPP_OPTS += ${GhcCppOpts}
-$(PRIMOPS_TXT) compiler/parser/Parser.y: %: %.pp compiler/stage1/$(PLATFORM_H)
+define preprocessCompilerFiles
+# $0 = stage
+compiler/stage$1/build/Parser.y: compiler/parser/Parser.y.pp
+ $$(CPP) $$(RAWCPP_FLAGS) -P $$(compiler_CPP_OPTS) -x c $$< | grep -v '^#pragma GCC' > $$@
+endef
+
+$(eval $(call preprocessCompilerFiles,1))
+$(eval $(call preprocessCompilerFiles,2))
+$(eval $(call preprocessCompilerFiles,3))
+
+
+$(PRIMOPS_TXT): %: %.pp compiler/stage1/$(PLATFORM_H)
$(CPP) $(RAWCPP_FLAGS) -P $(compiler_CPP_OPTS) -x c $< | grep -v '^#pragma GCC' > $@
$(eval $(call clean-target,compiler,primop, $(PRIMOPS_TXT) compiler/parser/Parser.y $(PRIMOP_BITS)))
View
@@ -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
@@ -291,6 +291,7 @@ data DynFlag
| Opt_CmmSink
| Opt_CmmElimCommonBlocks
| Opt_OmitYields
+ | Opt_SimpleListLiterals
-- Interface files
| Opt_IgnoreInterfacePragmas
@@ -340,11 +341,32 @@ data DynFlag
| Opt_RelativeDynlibPaths
| Opt_Hpc
+ -- PreInlining is on by default. The option is there just to see how
+ -- bad things get if you turn it off!
+ | Opt_SimplPreInlining
+
-- output style opts
| Opt_ErrorSpans -- Include full span info in error messages,
-- 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
@@ -655,6 +677,8 @@ data DynFlags = DynFlags {
ufKeenessFactor :: Float,
ufDearOp :: Int,
+ maxWorkerArgs :: Int,
+
-- | MsgDoc output action: use "ErrUtils" instead of this if you can
log_action :: LogAction,
flushOut :: FlushOut,
@@ -1227,6 +1251,8 @@ defaultDynFlags mySettings =
ufKeenessFactor = 1.5,
ufDearOp = 40,
+ maxWorkerArgs = 10,
+
log_action = defaultLogAction,
flushOut = defaultFlushOut,
flushErr = defaultFlushErr,
@@ -1948,6 +1974,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))
@@ -2091,6 +2126,8 @@ dynamic_flags = [
, Flag "funfolding-dict-discount" (intSuffix (\n d -> d {ufDictDiscount = n}))
, Flag "funfolding-keeness-factor" (floatSuffix (\n d -> d {ufKeenessFactor = n}))
+ , Flag "fmax-worker-args" (intSuffix (\n d -> d {maxWorkerArgs = n}))
+
------ Profiling ----------------------------------------------------
-- OLD profiling flags
@@ -2263,7 +2300,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]
@@ -2311,6 +2355,7 @@ fFlags = [
( "cmm-sink", Opt_CmmSink, nop ),
( "cmm-elim-common-blocks", Opt_CmmElimCommonBlocks, nop ),
( "omit-yields", Opt_OmitYields, nop ),
+ ( "simple-list-literals", Opt_SimpleListLiterals, nop ),
( "gen-manifest", Opt_GenManifest, nop ),
( "embed-manifest", Opt_EmbedManifest, nop ),
( "ext-core", Opt_EmitExternalCore, nop ),
@@ -2324,6 +2369,7 @@ fFlags = [
( "prof-count-entries", Opt_ProfCountEntries, nop ),
( "prof-cafs", Opt_AutoSccsOnIndividualCafs, nop ),
( "hpc", Opt_Hpc, nop ),
+ ( "pre-inlining", Opt_SimplPreInlining, nop ),
( "use-rpaths", Opt_RPath, nop )
]
@@ -2505,6 +2551,7 @@ defaultFlags settings
Opt_GhciHistory,
Opt_HelpfulErrors,
Opt_ProfCountEntries,
+ Opt_SimplPreInlining,
Opt_RPath
]
Oops, something went wrong.

0 comments on commit 9810529

Please sign in to comment.