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
-- optimisation opts
| Opt_Strictness
| Opt_FullLaziness
+ | Opt_StaticArgumentTransformation
| Opt_CSE
| Opt_LiberateCase
| Opt_SpecConstr
| Opt_DoEtaReduction
| Opt_CaseMerge
| Opt_UnboxStrictFields
+ | Opt_MethodSharing
| Opt_DictsCheap
| Opt_RewriteRules
| Opt_Vectorise
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,
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 = [],
Opt_ImplicitPrelude,
Opt_MonomorphismRestriction,
+ Opt_MethodSharing,
+
Opt_DoAsmMangling,
Opt_GenManifest,
, ([2], Opt_LiberateCase)
, ([2], Opt_SpecConstr)
+ , ([2], Opt_StaticArgumentTransformation)
, ([0,1,2], Opt_DoLambdaEtaExpansion)
-- This one is important for a tiresome reason:
data SimplifierMode -- See comments in SimplMonad
= SimplGently
- | SimplPhase Int
+ | SimplPhase Int [String]
data SimplifierSwitch
= MaxSimplifierIterations Int
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.
-- 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] ]
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,
-- ==> 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
CoreDoStrictness,
CoreDoWorkerWrapper,
CoreDoGlomBinds,
- simpl_phase 0 max_iter
+ simpl_phase 0 ["post-worker-wrapper"] max_iter
]),
runWhen full_laziness
-- 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
maybe_rule_check 0,
-- Final clean-up simplification:
- simpl_phase 0 max_iter
+ simpl_phase 0 ["final"] max_iter
]
-- -----------------------------------------------------------------------------
, ( "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)
, ( "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)
, ( "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))
------ 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
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 (
( "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 ),
( "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 ),
--------------------------
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 })
= 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)
-- 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
projects / ghc-hetmet.git / blobdiff