X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FDynFlags.hs;h=2c5d497db5a29e9dbbc070e7feb0619e69ff15a0;hb=e4417dcd4679da9c6b18c02ff667199c572bed89;hp=589ab030b781c2930ec113b3a4aa4457490506bf;hpb=3fedafc1adcaad9d98e96057922c437630f15206;p=ghc-hetmet.git diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 589ab03..2c5d497 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 @@ -88,9 +86,6 @@ import {-# SOURCE #-} ErrUtils ( Severity(..), Message, mkLocMessage ) import Data.IORef ( readIORef ) import Control.Exception ( throwDyn ) import Control.Monad ( when ) -#ifndef mingw32_TARGET_OS -import Util ( split ) -#endif import Data.Char import System.FilePath @@ -242,6 +237,7 @@ data DynFlag -- optimisation opts | Opt_Strictness | Opt_FullLaziness + | Opt_StaticArgumentTransformation | Opt_CSE | Opt_LiberateCase | Opt_SpecConstr @@ -304,9 +300,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, @@ -495,8 +493,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 = [], @@ -709,6 +709,7 @@ optLevelFlags , ([2], Opt_LiberateCase) , ([2], Opt_SpecConstr) + , ([2], Opt_StaticArgumentTransformation) , ([0,1,2], Opt_DoLambdaEtaExpansion) -- This one is important for a tiresome reason: @@ -792,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,15 +829,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. @@ -849,7 +852,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] ] @@ -872,9 +875,15 @@ getCoreToDo dflags core_todo = if opt_level == 0 then - [simpl_phase 0 max_iter] + [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, @@ -902,7 +911,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 @@ -912,7 +921,7 @@ getCoreToDo dflags CoreDoStrictness, CoreDoWorkerWrapper, CoreDoGlomBinds, - simpl_phase 0 max_iter + simpl_phase 0 ["post-worker-wrapper"] max_iter ]), runWhen full_laziness @@ -938,7 +947,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 @@ -948,7 +957,7 @@ getCoreToDo dflags maybe_rule_check 0, -- Final clean-up simplification: - simpl_phase 0 max_iter + simpl_phase 0 ["final"] max_iter ] -- ----------------------------------------------------------------------------- @@ -1119,7 +1128,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) @@ -1138,7 +1147,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) @@ -1185,6 +1194,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 ( @@ -1245,6 +1258,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 ), @@ -1469,6 +1483,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 }) @@ -1620,32 +1671,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 @@ -1670,7 +1698,7 @@ setOptHpcDir arg = upd $ \ d -> d{hpcDir = arg} machdepCCOpts :: DynFlags -> ([String], -- flags for all C compilations [String]) -- for registerised HC compilations -machdepCCOpts dflags +machdepCCOpts _dflags #if alpha_TARGET_ARCH = ( ["-w", "-mieee" #ifdef HAVE_THREADED_RTS_SUPPORT @@ -1703,7 +1731,7 @@ machdepCCOpts dflags -- -- -fomit-frame-pointer : *must* in .hc files; because we're stealing -- the fp (%ebp) for our register maps. - = let n_regs = stolen_x86_regs dflags + = let n_regs = stolen_x86_regs _dflags sta = opt_Static in ( [ if sta then "-DDONT_WANT_WIN32_DLL_SUPPORT" else ""