X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FDynFlags.hs;h=3645e080cffc571a053677d05778eef0a67ef622;hb=8cf861ba91941412e93f70a916233223aebf686e;hp=fb873917a3a9de76373ac7c6b8c1c156cd86363e;hpb=d04e338c3b78fb76341e374bf776b14cbca78bd1;p=ghc-hetmet.git diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index fb87391..3645e08 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -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 = [], @@ -789,7 +793,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 @@ -828,12 +832,13 @@ getCoreToDo 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 +851,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] ] @@ -869,7 +874,7 @@ getCoreToDo dflags core_todo = if opt_level == 0 then - [simpl_phase 0 max_iter] + [simpl_phase 0 ["final"] max_iter] else {- opt_level >= 1 -} [ -- initial simplify: mk specialiser happy: minimum effort please @@ -899,7 +904,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 +914,7 @@ getCoreToDo dflags CoreDoStrictness, CoreDoWorkerWrapper, CoreDoGlomBinds, - simpl_phase 0 max_iter + simpl_phase 0 ["post-worker-wrapper"] max_iter ]), runWhen full_laziness @@ -935,7 +940,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 +950,7 @@ getCoreToDo dflags maybe_rule_check 0, -- Final clean-up simplification: - simpl_phase 0 max_iter + simpl_phase 0 ["final"] max_iter ] -- ----------------------------------------------------------------------------- @@ -1116,7 +1121,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 +1140,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) @@ -1182,6 +1187,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 ( @@ -1466,6 +1475,43 @@ setDumpFlag dump_flag -- Whenver we -ddump, switch off the recompilation checker, -- else you don't see the dump! +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 }) @@ -1617,32 +1663,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