X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FStaticFlags.hs;h=f6d0af2665e2d36209eb657d3554a49b5c6d99d9;hp=f310fa058d610270d872b0165c02ba64649077ef;hb=8133a9f47b99f4e65ed30551de32ad72c6b61b27;hpb=29e9a63ff51ebca060f2da561709365ec87b6045 diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index f310fa0..f6d0af2 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -21,10 +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_PprStyle_Debug, - opt_NoDebugOutput, + opt_SuppressModulePrefixes, + opt_SuppressTypeApplications, + opt_SuppressIdInfo, + opt_SuppressTypeSignatures, -- profiling opts opt_SccProfilingOn, @@ -38,13 +47,12 @@ module StaticFlags ( opt_Parallel, -- optimisation opts - opt_DsMultiTyVar, opt_NoStateHack, opt_SimpleListLiterals, - opt_SpecInlineJoinPoints, opt_CprOff, opt_SimplNoPreInlining, opt_SimplExcessPrecision, + opt_NoOptCoercion, opt_MaxWorkerArgs, -- Unfolding control @@ -73,6 +81,7 @@ module StaticFlags ( v_Ld_inputs, tablesNextToCode, opt_StubDeadValues, + opt_Ticky, -- For the parser addOpt, removeOpt, addWay, getWayFlags, v_opt_C_ready @@ -83,7 +92,7 @@ module StaticFlags ( import Config import FastString import Util -import Maybes ( firstJust ) +import Maybes ( firstJusts ) import Panic import Data.Maybe ( listToMaybe ) @@ -137,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 @@ -158,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. @@ -181,21 +190,85 @@ 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-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") +opt_PprStyle_Debug = lookUp (fsLit "-dppr-debug") + +opt_TraceLevel :: Int +opt_TraceLevel = lookup_def_int "-dtrace-level" 1 -- Standard level is 1 + -- Less verbose is 0 + opt_PprUserLength :: Int opt_PprUserLength = lookup_def_int "-dppr-user-length" 5 --ToDo: give this a name + opt_Fuel :: Int 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") @@ -207,19 +280,13 @@ opt_Hpc = lookUp (fsLit "-fhpc") -- language opts opt_DictsStrict :: Bool opt_DictsStrict = lookUp (fsLit "-fdicts-strict") + opt_IrrefutableTuples :: Bool 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_SpecInlineJoinPoints :: Bool -opt_SpecInlineJoinPoints = lookUp (fsLit "-fspec-inline-join-points") - opt_SimpleListLiterals :: Bool opt_SimpleListLiterals = lookUp (fsLit "-fsimple-list-literals") @@ -234,12 +301,16 @@ opt_MaxWorkerArgs = lookup_def_int "-fmax-worker-args" (10::Int) opt_GranMacros :: Bool opt_GranMacros = lookUp (fsLit "-fgransim") + opt_HiVersion :: Integer opt_HiVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer + opt_HistorySize :: Int opt_HistorySize = lookup_def_int "-fhistory-size" 20 + opt_OmitBlackHoling :: Bool opt_OmitBlackHoling = lookUp (fsLit "-dno-black-holing") + opt_StubDeadValues :: Bool opt_StubDeadValues = lookUp (fsLit "-dstub-dead-values") @@ -251,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 @@ -258,18 +332,24 @@ 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 opt_PIC :: Bool #if darwin_TARGET_OS && x86_64_TARGET_ARCH opt_PIC = True +#elif darwin_TARGET_OS +opt_PIC = lookUp (fsLit "-fPIC") || not opt_Static #else opt_PIC = lookUp (fsLit "-fPIC") #endif @@ -290,6 +370,8 @@ tablesNextToCode = not opt_Unregisterised opt_ErrorSpans :: Bool opt_ErrorSpans = lookUp (fsLit "-ferror-spans") +opt_Ticky :: Bool +opt_Ticky = lookUp (fsLit "-ticky") -- object files and libraries to be linked in are collected here. -- ToDo: perhaps this could be done without a global, it wasn't obvious @@ -306,7 +388,7 @@ GLOBAL_VAR(v_Ld_inputs, [], [String]) -- non-profiling objects. -- After parsing the command-line options, we determine which "way" we --- are building - this might be a combination way, eg. profiling+ticky-ticky. +-- are building - this might be a combination way, eg. profiling+threaded. -- We then find the "build-tag" associated with this way, and this -- becomes the suffix used to find .hi files and libraries used in @@ -317,7 +399,6 @@ data WayName | WayDebug | WayProf | WayEventLog - | WayTicky | WayPar | WayGran | WayNDP @@ -338,11 +419,6 @@ allowed_combination way = and [ x `allowedWith` y _ `allowedWith` WayDyn = True WayDyn `allowedWith` _ = True - -- ticky is (now) allowed with everything - -- Indeed, ticky should no longer be a 'way' at all - _ `allowedWith` WayTicky = True - WayTicky `allowedWith` _ = True - -- debug is allowed with everything _ `allowedWith` WayDebug = True WayDebug `allowedWith` _ = True @@ -399,6 +475,9 @@ way_details = -- the problems are our fault or theirs, but it seems that using the -- alternative 1:1 threading library libthr works around it: "-optl-lthr" +#elif defined(openbsd_TARGET_OS) + "-optc-pthread" + , "-optl-pthread" #elif defined(solaris2_TARGET_OS) "-optl-lrt" #endif @@ -408,7 +487,18 @@ way_details = Way WayDyn "dyn" False "Dynamic" [ "-DDYNAMIC" - , "-optc-DDYNAMIC" ], + , "-optc-DDYNAMIC" +#if defined(mingw32_TARGET_OS) + -- On Windows, code that is to be linked into a dynamic library must be compiled + -- with -fPIC. Labels not in the current package are assumed to be in a DLL + -- different from the current one. + , "-fPIC" +#elif defined(openbsd_TARGET_OS) + -- Without this, linking the shared libHSffi fails because + -- it uses pthread mutexes. + , "-optl-pthread" +#endif + ], Way WayProf "p" False "Profiling" [ "-fscc-profiling" @@ -419,10 +509,6 @@ way_details = [ "-DTRACING" , "-optc-DTRACING" ], - Way WayTicky "t" True "Ticky-ticky Profiling" - [ "-DTICKY_TICKY" - , "-optc-DTICKY_TICKY" ], - Way WayPar "mp" False "Parallel" [ "-fparallel" , "-D__PARALLEL_HASKELL__"