X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FDynFlags.hs;h=be0212e744d2685b29e88b4f51ea18cd7d82b8c9;hp=fb873917a3a9de76373ac7c6b8c1c156cd86363e;hb=842e9d6628a27cf1f420d53f6a5901935dc50c54;hpb=d04e338c3b78fb76341e374bf776b14cbca78bd1 diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index fb87391..be0212e 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -60,8 +60,6 @@ module DynFlags ( compilerInfo, ) where --- XXX This define is a bit of a hack, and should be done more nicely -#define FAST_STRING_NOT_NEEDED 1 #include "HsVersions.h" import Module @@ -239,6 +237,7 @@ data DynFlag -- optimisation opts | Opt_Strictness | Opt_FullLaziness + | Opt_StaticArgumentTransformation | Opt_CSE | Opt_LiberateCase | Opt_SpecConstr @@ -249,6 +248,7 @@ data DynFlag | Opt_DoEtaReduction | Opt_CaseMerge | Opt_UnboxStrictFields + | Opt_MethodSharing | Opt_DictsCheap | Opt_RewriteRules | Opt_Vectorise @@ -301,9 +301,11 @@ data DynFlags = DynFlags { optLevel :: Int, -- optimisation level simplPhases :: Int, -- number of simplifier phases maxSimplIterations :: Int, -- max simplifier iterations + shouldDumpSimplPhase :: SimplifierMode -> Bool, ruleCheck :: Maybe String, specConstrThreshold :: Maybe Int, -- Threshold for SpecConstr + specConstrCount :: Maybe Int, -- Max number of specialisations for any one function liberateCaseThreshold :: Maybe Int, -- Threshold for LiberateCase stolen_x86_regs :: Int, @@ -492,8 +494,10 @@ defaultDynFlags = optLevel = 0, simplPhases = 2, maxSimplIterations = 4, + shouldDumpSimplPhase = const False, ruleCheck = Nothing, specConstrThreshold = Just 200, + specConstrCount = Just 3, liberateCaseThreshold = Just 200, stolen_x86_regs = 4, cmdlineHcIncludes = [], @@ -552,6 +556,8 @@ defaultDynFlags = Opt_ImplicitPrelude, Opt_MonomorphismRestriction, + Opt_MethodSharing, + Opt_DoAsmMangling, Opt_GenManifest, @@ -706,6 +712,7 @@ optLevelFlags , ([2], Opt_LiberateCase) , ([2], Opt_SpecConstr) + , ([2], Opt_StaticArgumentTransformation) , ([0,1,2], Opt_DoLambdaEtaExpansion) -- This one is important for a tiresome reason: @@ -789,7 +796,7 @@ data CoreToDo -- These are diff core-to-core passes, data SimplifierMode -- See comments in SimplMonad = SimplGently - | SimplPhase Int + | SimplPhase Int [String] data SimplifierSwitch = MaxSimplifierIterations Int @@ -825,15 +832,17 @@ getCoreToDo dflags liberate_case = dopt Opt_LiberateCase dflags rule_check = ruleCheck dflags vectorisation = dopt Opt_Vectorise dflags + static_args = dopt Opt_StaticArgumentTransformation dflags maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase) - simpl_phase phase iter = CoreDoPasses - [ CoreDoSimplify (SimplPhase phase) [ - MaxSimplifierIterations iter - ], - maybe_rule_check phase - ] + simpl_phase phase names iter + = CoreDoPasses + [ CoreDoSimplify (SimplPhase phase names) [ + MaxSimplifierIterations iter + ], + maybe_rule_check phase + ] -- By default, we have 2 phases before phase 0. @@ -846,7 +855,7 @@ getCoreToDo dflags -- inlined. I found that spectral/hartel/genfft lost some useful -- strictness in the function sumcode' if augment is not inlined -- before strictness analysis runs - simpl_phases = CoreDoPasses [ simpl_phase phase max_iter + simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter | phase <- [phases, phases-1 .. 1] ] @@ -867,11 +876,18 @@ getCoreToDo dflags MaxSimplifierIterations max_iter ] - core_todo = + core_todo = if opt_level == 0 then - [simpl_phase 0 max_iter] + [runWhen vectorisation (CoreDoPasses [ simpl_gently, CoreDoVectorisation ]), + simpl_phase 0 ["final"] max_iter] else {- opt_level >= 1 -} [ + -- We want to do the static argument transform before full laziness as it + -- may expose extra opportunities to float things outwards. However, to fix + -- up the output of the transformation we need at do at least one simplify + -- after this before anything else + runWhen static_args CoreDoStaticArgs, + -- initial simplify: mk specialiser happy: minimum effort please simpl_gently, @@ -899,7 +915,7 @@ getCoreToDo dflags -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs -- Don't stop now! - simpl_phase 0 (max max_iter 3), + simpl_phase 0 ["main"] (max max_iter 3), #ifdef OLD_STRICTNESS @@ -909,7 +925,7 @@ getCoreToDo dflags CoreDoStrictness, CoreDoWorkerWrapper, CoreDoGlomBinds, - simpl_phase 0 max_iter + simpl_phase 0 ["post-worker-wrapper"] max_iter ]), runWhen full_laziness @@ -935,7 +951,7 @@ getCoreToDo dflags -- strictness analysis and the simplification which follows it. runWhen liberate_case (CoreDoPasses [ CoreLiberateCase, - simpl_phase 0 max_iter + simpl_phase 0 ["post-liberate-case"] max_iter ]), -- Run the simplifier after LiberateCase to vastly -- reduce the possiblility of shadowing -- Reason: see Note [Shadowing] in SpecConstr.lhs @@ -945,7 +961,7 @@ getCoreToDo dflags maybe_rule_check 0, -- Final clean-up simplification: - simpl_phase 0 max_iter + simpl_phase 0 ["final"] max_iter ] -- ----------------------------------------------------------------------------- @@ -1116,7 +1132,7 @@ dynamic_flags = [ , ( "ddump-rn", setDumpFlag Opt_D_dump_rn) , ( "ddump-simpl", setDumpFlag Opt_D_dump_simpl) , ( "ddump-simpl-iterations", setDumpFlag Opt_D_dump_simpl_iterations) - , ( "ddump-simpl-phases", setDumpFlag Opt_D_dump_simpl_phases) + , ( "ddump-simpl-phases", OptPrefix setDumpSimplPhases) , ( "ddump-spec", setDumpFlag Opt_D_dump_spec) , ( "ddump-prep", setDumpFlag Opt_D_dump_prep) , ( "ddump-stg", setDumpFlag Opt_D_dump_stg) @@ -1135,7 +1151,7 @@ dynamic_flags = [ , ( "ddump-simpl-stats", setDumpFlag Opt_D_dump_simpl_stats) , ( "ddump-bcos", setDumpFlag Opt_D_dump_BCOs) , ( "dsource-stats", setDumpFlag Opt_D_source_stats) - , ( "dverbose-core2core", setDumpFlag Opt_D_verbose_core2core) + , ( "dverbose-core2core", NoArg setVerboseCore2Core) , ( "dverbose-stg2stg", setDumpFlag Opt_D_verbose_stg2stg) , ( "ddump-hi", setDumpFlag Opt_D_dump_hi) , ( "ddump-minimal-imports", setDumpFlag Opt_D_dump_minimal_imports) @@ -1144,7 +1160,8 @@ dynamic_flags = [ , ( "ddump-mod-cycles", setDumpFlag Opt_D_dump_mod_cycles) , ( "ddump-view-pattern-commoning", setDumpFlag Opt_D_dump_view_pattern_commoning) , ( "ddump-to-file", setDumpFlag Opt_DumpToFile) - , ( "ddump-hi-diffs", NoArg (setDynFlag Opt_D_dump_hi_diffs)) + , ( "ddump-hi-diffs", setDumpFlag Opt_D_dump_hi_diffs) + , ( "dcore-lint", NoArg (setDynFlag Opt_DoCoreLinting)) , ( "dstg-lint", NoArg (setDynFlag Opt_DoStgLinting)) , ( "dcmm-lint", NoArg (setDynFlag Opt_DoCmmLinting)) @@ -1170,6 +1187,7 @@ dynamic_flags = [ ------ Optimisation flags ------------------------------------------ , ( "O" , NoArg (upd (setOptLevel 1))) , ( "Onot" , NoArg (upd (setOptLevel 0))) -- deprecated + , ( "Odph" , NoArg (upd setDPHOpt)) , ( "O" , OptIntSuffix (\mb_n -> upd (setOptLevel (mb_n `orElse` 1)))) -- If the number is missing, use 1 @@ -1182,6 +1200,10 @@ dynamic_flags = [ upd (\dfs -> dfs{ specConstrThreshold = Just n }))) , ( "fno-spec-constr-threshold", NoArg ( upd (\dfs -> dfs{ specConstrThreshold = Nothing }))) + , ( "fspec-constr-count", IntSuffix (\n -> + upd (\dfs -> dfs{ specConstrCount = Just n }))) + , ( "fno-spec-constr-count", NoArg ( + upd (\dfs -> dfs{ specConstrCount = Nothing }))) , ( "fliberate-case-threshold", IntSuffix (\n -> upd (\dfs -> dfs{ liberateCaseThreshold = Just n }))) , ( "fno-liberate-case-threshold", NoArg ( @@ -1242,6 +1264,7 @@ fFlags = [ ( "warn-tabs", Opt_WarnTabs ), ( "print-explicit-foralls", Opt_PrintExplicitForalls ), ( "strictness", Opt_Strictness ), + ( "static-argument-transformation", Opt_StaticArgumentTransformation ), ( "full-laziness", Opt_FullLaziness ), ( "liberate-case", Opt_LiberateCase ), ( "spec-constr", Opt_SpecConstr ), @@ -1253,6 +1276,7 @@ fFlags = [ ( "do-eta-reduction", Opt_DoEtaReduction ), ( "case-merge", Opt_CaseMerge ), ( "unbox-strict-fields", Opt_UnboxStrictFields ), + ( "method-sharing", Opt_MethodSharing ), ( "dicts-cheap", Opt_DictsCheap ), ( "excess-precision", Opt_ExcessPrecision ), ( "asm-mangling", Opt_DoAsmMangling ), @@ -1462,9 +1486,53 @@ unSetDynFlag f = upd (\dfs -> dopt_unset dfs f) -------------------------- setDumpFlag :: DynFlag -> OptKind DynP setDumpFlag dump_flag - = NoArg (setDynFlag Opt_ForceRecomp >> setDynFlag dump_flag) + | force_recomp = NoArg (setDynFlag Opt_ForceRecomp >> setDynFlag dump_flag) + | otherwise = NoArg (setDynFlag dump_flag) + where -- Whenver we -ddump, switch off the recompilation checker, -- else you don't see the dump! + -- However, certain dumpy-things are really interested in what's going + -- on during recompilation checking, so in those cases we + -- don't want to turn it off. + force_recomp = dump_flag `notElem` [Opt_D_dump_if_trace, + Opt_D_dump_hi_diffs] + +setVerboseCore2Core :: DynP () +setVerboseCore2Core = do setDynFlag Opt_ForceRecomp + setDynFlag Opt_D_verbose_core2core + upd (\s -> s { shouldDumpSimplPhase = const True }) + +setDumpSimplPhases :: String -> DynP () +setDumpSimplPhases s = do setDynFlag Opt_ForceRecomp + upd (\s -> s { shouldDumpSimplPhase = spec }) + where + spec :: SimplifierMode -> Bool + spec = join (||) + . map (join (&&) . map match . split ':') + . split ',' + $ case s of + '=' : s' -> s' + _ -> s + + join :: (Bool -> Bool -> Bool) + -> [SimplifierMode -> Bool] + -> SimplifierMode -> Bool + join _ [] = const True + join op ss = foldr1 (\f g x -> f x `op` g x) ss + + match :: String -> SimplifierMode -> Bool + match "" = const True + match s = case reads s of + [(n,"")] -> phase_num n + _ -> phase_name s + + phase_num :: Int -> SimplifierMode -> Bool + phase_num n (SimplPhase k _) = n == k + phase_num _ _ = False + + phase_name :: String -> SimplifierMode -> Bool + phase_name s SimplGently = s == "gentle" + phase_name s (SimplPhase _ ss) = s `elem` ss setVerbosity :: Maybe Int -> DynP () setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 }) @@ -1522,6 +1590,24 @@ setOptLevel n dflags = updOptLevel n dflags +-- -Odph is equivalent to +-- +-- -O2 optimise as much as possible +-- -fno-method-sharing sharing specialisation defeats fusion +-- sometimes +-- -fdicts-cheap always inline dictionaries +-- -fmax-simplifier-iterations20 this is necessary sometimes +-- -fno-spec-constr-threshold run SpecConstr even for big loops +-- +setDPHOpt :: DynFlags -> DynFlags +setDPHOpt dflags = setOptLevel 2 (dflags { maxSimplIterations = 20 + , specConstrThreshold = Nothing + }) + `dopt_set` Opt_DictsCheap + `dopt_unset` Opt_MethodSharing + + + setMainIs :: String -> DynP () setMainIs arg | not (null main_fn) && isLower (head main_fn) @@ -1617,32 +1703,9 @@ splitPathList s = filter notNull (splitUp s) -- tmpDir, where we store temporary files. setTmpDir :: FilePath -> DynFlags -> DynFlags -setTmpDir dir dflags = dflags{ tmpDir = canonicalise dir } - where -#if !defined(mingw32_HOST_OS) - canonicalise p = normalise p -#else - -- Canonicalisation of temp path under win32 is a bit more - -- involved: (a) strip trailing slash, - -- (b) normalise slashes - -- (c) just in case, if there is a prefix /cygdrive/x/, change to x: - canonicalise path = removeTrailingSlash $ normalise $ xltCygdrive path - - -- if we're operating under cygwin, and TMP/TEMP is of - -- the form "/cygdrive/drive/path", translate this to - -- "drive:/path" (as GHC isn't a cygwin app and doesn't - -- understand /cygdrive paths.) - cygdrivePrefix = [pathSeparator] ++ "/cygdrive/" ++ [pathSeparator] - xltCygdrive path = case maybePrefixMatch cygdrivePrefix path of - Just (drive:sep:xs) - | isPathSeparator sep -> drive:':':pathSeparator:xs - _ -> path - - -- strip the trailing backslash (awful, but we only do this once). - removeTrailingSlash path - | isPathSeparator (last path) = init path - | otherwise = path -#endif +setTmpDir dir dflags = dflags{ tmpDir = normalise dir } + -- we used to fix /cygdrive/c/.. on Windows, but this doesn't + -- seem necessary now --SDM 7/2/2008 ----------------------------------------------------------------------------- -- Hpc stuff