X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FStaticFlags.hs;h=f6d0af2665e2d36209eb657d3554a49b5c6d99d9;hp=52a86948e48514c223a285cb048298aa551463f3;hb=8133a9f47b99f4e65ed30551de32ad72c6b61b27;hpb=190b2d90f92f61eb802275729106b5d9fb9a7a7c diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index 52a8694..f6d0af2 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -21,11 +21,19 @@ module StaticFlags ( -- Output style options opt_PprUserLength, + opt_PprCols, + opt_PprCaseAsLet, + opt_PprStyle_Debug, opt_TraceLevel, + opt_NoDebugOutput, + + -- Suppressing boring aspects of core dumps + opt_SuppressAll, opt_SuppressUniques, opt_SuppressCoercions, opt_SuppressModulePrefixes, - opt_PprStyle_Debug, opt_TraceLevel, - opt_NoDebugOutput, + opt_SuppressTypeApplications, + opt_SuppressIdInfo, + opt_SuppressTypeSignatures, -- profiling opts opt_SccProfilingOn, @@ -39,12 +47,12 @@ module StaticFlags ( opt_Parallel, -- optimisation opts - opt_DsMultiTyVar, opt_NoStateHack, opt_SimpleListLiterals, opt_CprOff, opt_SimplNoPreInlining, opt_SimplExcessPrecision, + opt_NoOptCoercion, opt_MaxWorkerArgs, -- Unfolding control @@ -84,7 +92,7 @@ module StaticFlags ( import Config import FastString import Util -import Maybes ( firstJust ) +import Maybes ( firstJusts ) import Panic import Data.Maybe ( listToMaybe ) @@ -138,7 +146,7 @@ lookUp sw = sw `elem` packed_static_opts -- (lookup_str "foo") looks for the flag -foo=X or -fooX, -- and returns the string X lookup_str sw - = case firstJust (map (stripPrefix sw) staticFlags) of + = case firstJusts (map (stripPrefix sw) staticFlags) of Just ('=' : str) -> Just str Just str -> Just str Nothing -> Nothing @@ -159,7 +167,7 @@ try_read sw str = case reads str of ((x,_):_) -> x -- Be forgiving: ignore trailing goop, and alternative parses [] -> ghcError (UsageError ("Malformed argument " ++ str ++ " for flag " ++ sw)) - -- ToDo: hack alert. We should really parse the arugments + -- ToDo: hack alert. We should really parse the arguments -- and announce errors in a more civilised way. @@ -182,15 +190,68 @@ unpacked_opts = opt_IgnoreDotGhci :: Bool opt_IgnoreDotGhci = lookUp (fsLit "-ignore-dot-ghci") --- debugging opts -opt_SuppressUniques :: Bool -opt_SuppressUniques = lookUp (fsLit "-dsuppress-uniques") +-- 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-coercions") +opt_SuppressCoercions + = lookUp (fsLit "-dsuppress-all") + || lookUp (fsLit "-dsuppress-coercions") +-- | Suppress module id prefixes on variables. opt_SuppressModulePrefixes :: Bool -opt_SuppressModulePrefixes = lookUp (fsLit "-dsuppress-module-prefixes") +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 seprate 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") + +-- | Display case expressions with a single alternative as strict let bindings +opt_PprCaseAsLet :: Bool +opt_PprCaseAsLet = lookUp (fsLit "-dppr-case-as-let") + +-- | Set the maximum width of the dumps +-- If GHC's command line options are bad then the options parser uses the +-- pretty printer display the error message. In this case the staticFlags +-- won't be initialized yet, so we must check for this case explicitly +-- and return the default value. +opt_PprCols :: Int +opt_PprCols + = unsafePerformIO + $ do ready <- readIORef v_opt_C_ready + if (not ready) + then return 100 + else return $ lookup_def_int "-dppr-cols" 100 + opt_PprStyle_Debug :: Bool opt_PprStyle_Debug = lookUp (fsLit "-dppr-debug") @@ -208,7 +269,6 @@ opt_Fuel = lookup_def_int "-dopt-fuel" maxBound opt_NoDebugOutput :: Bool opt_NoDebugOutput = lookUp (fsLit "-dno-debug-output") - -- profiling opts opt_SccProfilingOn :: Bool opt_SccProfilingOn = lookUp (fsLit "-fscc-profiling") @@ -227,11 +287,6 @@ opt_IrrefutableTuples = lookUp (fsLit "-firrefutable-tuples") opt_Parallel :: Bool opt_Parallel = lookUp (fsLit "-fparallel") --- optimisation opts -opt_DsMultiTyVar :: Bool -opt_DsMultiTyVar = not (lookUp (fsLit "-fno-ds-multi-tyvar")) - -- On by default - opt_SimpleListLiterals :: Bool opt_SimpleListLiterals = lookUp (fsLit "-fsimple-list-literals") @@ -267,6 +322,9 @@ opt_SimplNoPreInlining = lookUp (fsLit "-fno-pre-inlining") opt_SimplExcessPrecision :: Bool opt_SimplExcessPrecision = lookUp (fsLit "-fexcess-precision") +opt_NoOptCoercion :: Bool +opt_NoOptCoercion = lookUp (fsLit "-fno-opt-coercion") + -- Unfolding control -- See Note [Discounts and thresholds] in CoreUnfold @@ -274,12 +332,16 @@ opt_UF_CreationThreshold, opt_UF_UseThreshold :: Int opt_UF_DearOp, opt_UF_FunAppDiscount, opt_UF_DictDiscount :: Int opt_UF_KeenessFactor :: Float -opt_UF_CreationThreshold = lookup_def_int "-funfolding-creation-threshold" (45::Int) -opt_UF_UseThreshold = lookup_def_int "-funfolding-use-threshold" (6::Int) -opt_UF_FunAppDiscount = lookup_def_int "-funfolding-fun-discount" (6::Int) -opt_UF_DictDiscount = lookup_def_int "-funfolding-dict-discount" (1::Int) +opt_UF_CreationThreshold = lookup_def_int "-funfolding-creation-threshold" (450::Int) +opt_UF_UseThreshold = lookup_def_int "-funfolding-use-threshold" (60::Int) +opt_UF_FunAppDiscount = lookup_def_int "-funfolding-fun-discount" (60::Int) + +opt_UF_DictDiscount = lookup_def_int "-funfolding-dict-discount" (30::Int) + -- Be fairly keen to inline a fuction if that means + -- we'll be able to pick the right method from a dictionary + opt_UF_KeenessFactor = lookup_def_float "-funfolding-keeness-factor" (1.5::Float) -opt_UF_DearOp = ( 4 :: Int) +opt_UF_DearOp = ( 40 :: Int) -- Related to linking