#endif
import Data.Char
+import System.FilePath
import System.IO ( hPutStrLn, stderr )
-- -----------------------------------------------------------------------------
| Opt_D_dump_rn
| Opt_D_dump_simpl
| Opt_D_dump_simpl_iterations
+ | Opt_D_dump_simpl_phases
| Opt_D_dump_spec
| Opt_D_dump_prep
| Opt_D_dump_stg
| Opt_KindSignatures
| Opt_PatternSignatures
| Opt_ParallelListComp
+ | Opt_TransformListComp
| Opt_GeneralizedNewtypeDeriving
| Opt_RecursiveDo
| Opt_PatternGuards
| Opt_LiberalTypeSynonyms
| Opt_Rank2Types
| Opt_RankNTypes
+ | Opt_ImpredicativeTypes
| Opt_TypeOperators
| Opt_PrintExplicitForalls
extCoreName :: String, -- name of the .core output file
verbosity :: Int, -- verbosity level
optLevel :: Int, -- optimisation level
+ simplPhases :: Int, -- number of simplifier phases
maxSimplIterations :: Int, -- max simplifier iterations
ruleCheck :: Maybe String,
- specThreshold :: Int, -- Threshold for function specialisation
+ specConstrThreshold :: Maybe Int, -- Threshold for SpecConstr
+ liberateCaseThreshold :: Maybe Int, -- Threshold for LiberateCase
stolen_x86_regs :: Int,
cmdlineHcIncludes :: [String], -- -#includes
| LinkBinary -- Link object code into a binary
| LinkInMemory -- Use the in-memory dynamic linker
| LinkDynLib -- Link objects into a dynamic lib (DLL on Windows, DSO on ELF platforms)
- deriving Eq
+ deriving (Eq, Show)
isNoLink :: GhcLink -> Bool
isNoLink NoLink = True
extCoreName = "",
verbosity = 0,
optLevel = 0,
+ simplPhases = 2,
maxSimplIterations = 4,
ruleCheck = Nothing,
- specThreshold = 200,
+ specConstrThreshold = Just 200,
+ liberateCaseThreshold = Just 200,
stolen_x86_regs = 4,
cmdlineHcIncludes = [],
importPaths = ["."],
runWhen True do_this = do_this
runWhen False do_this = CoreDoNothing
+runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
+runMaybe (Just x) f = f x
+runMaybe Nothing _ = CoreDoNothing
+
getCoreToDo :: DynFlags -> [CoreToDo]
getCoreToDo dflags
| Just todo <- coreToDo dflags = todo -- set explicitly by user
| otherwise = core_todo
where
opt_level = optLevel dflags
+ phases = simplPhases dflags
max_iter = maxSimplIterations dflags
strictness = dopt Opt_Strictness dflags
full_laziness = dopt Opt_FullLaziness dflags
rule_check = ruleCheck dflags
vectorisation = dopt Opt_Vectorise dflags
- core_todo =
- if opt_level == 0 then
- [
- CoreDoSimplify (SimplPhase 0) [
- MaxSimplifierIterations max_iter
- ]
- ]
- else {- opt_level >= 1 -} [
+ maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
+
+ simpl_phase phase iter = CoreDoPasses
+ [ CoreDoSimplify (SimplPhase phase) [
+ MaxSimplifierIterations iter
+ ],
+ maybe_rule_check phase
+ ]
+
+ -- By default, we have 2 phases before phase 0.
+
+ -- Want to run with inline phase 2 after the specialiser to give
+ -- maximum chance for fusion to work before we inline build/augment
+ -- in phase 1. This made a difference in 'ansi' where an
+ -- overloaded function wasn't inlined till too late.
+
+ -- Need phase 1 so that build/augment get
+ -- 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
+ | phase <- [phases, phases-1 .. 1] ]
+
-- initial simplify: mk specialiser happy: minimum effort please
- CoreDoSimplify SimplGently [
+ simpl_gently = CoreDoSimplify SimplGently [
-- Simplify "gently"
-- Don't inline anything till full laziness has bitten
-- In particular, inlining wrappers inhibits floating
NoCaseOfCase, -- Don't do case-of-case transformations.
-- This makes full laziness work better
MaxSimplifierIterations max_iter
- ],
+ ]
+ core_todo =
+ if opt_level == 0 then
+ [simpl_phase 0 max_iter]
+ else {- opt_level >= 1 -} [
+
+ -- initial simplify: mk specialiser happy: minimum effort please
+ simpl_gently,
-- We run vectorisation here for now, but we might also try to run
-- it later
- runWhen vectorisation (CoreDoPasses [
- CoreDoVectorisation,
- CoreDoSimplify SimplGently
- [NoCaseOfCase,
- MaxSimplifierIterations max_iter]]),
+ runWhen vectorisation (CoreDoPasses [ CoreDoVectorisation, simpl_gently ]),
-- Specialisation is best done before full laziness
-- so that overloaded functions have all their dictionary lambdas manifest
CoreDoFloatInwards,
- CoreDoSimplify (SimplPhase 2) [
- -- Want to run with inline phase 2 after the specialiser to give
- -- maximum chance for fusion to work before we inline build/augment
- -- in phase 1. This made a difference in 'ansi' where an
- -- overloaded function wasn't inlined till too late.
- MaxSimplifierIterations max_iter
- ],
- case rule_check of { Just pat -> CoreDoRuleCheck 2 pat; Nothing -> CoreDoNothing },
-
- CoreDoSimplify (SimplPhase 1) [
- -- Need inline-phase2 here so that build/augment get
- -- inlined. I found that spectral/hartel/genfft lost some useful
- -- strictness in the function sumcode' if augment is not inlined
- -- before strictness analysis runs
- MaxSimplifierIterations max_iter
- ],
- case rule_check of { Just pat -> CoreDoRuleCheck 1 pat; Nothing -> CoreDoNothing },
+ simpl_phases,
- CoreDoSimplify (SimplPhase 0) [
-- Phase 0: allow all Ids to be inlined now
-- This gets foldr inlined before strictness analysis
- MaxSimplifierIterations 3
-- At least 3 iterations because otherwise we land up with
-- huge dead expressions because of an infelicity in the
-- simpifier.
-- ==> 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),
- ],
- case rule_check of { Just pat -> CoreDoRuleCheck 0 pat; Nothing -> CoreDoNothing },
#ifdef OLD_STRICTNESS
CoreDoOldStrictness,
CoreDoStrictness,
CoreDoWorkerWrapper,
CoreDoGlomBinds,
- CoreDoSimplify (SimplPhase 0) [
- MaxSimplifierIterations max_iter
- ]]),
+ simpl_phase 0 max_iter
+ ]),
runWhen full_laziness
(CoreDoFloatOutwards (FloatOutSw False -- Not lambdas
CoreDoFloatInwards,
- case rule_check of { Just pat -> CoreDoRuleCheck 0 pat; Nothing -> CoreDoNothing },
+ maybe_rule_check 0,
-- Case-liberation for -O2. This should be after
-- strictness analysis and the simplification which follows it.
runWhen liberate_case (CoreDoPasses [
CoreLiberateCase,
- CoreDoSimplify (SimplPhase 0) [
- MaxSimplifierIterations max_iter
- ] ]), -- Run the simplifier after LiberateCase to vastly
+ simpl_phase 0 max_iter
+ ]), -- Run the simplifier after LiberateCase to vastly
-- reduce the possiblility of shadowing
-- Reason: see Note [Shadowing] in SpecConstr.lhs
runWhen spec_constr CoreDoSpecConstr,
- case rule_check of { Just pat -> CoreDoRuleCheck 0 pat; Nothing -> CoreDoNothing },
+ maybe_rule_check 0,
-- Final clean-up simplification:
- CoreDoSimplify (SimplPhase 0) [
- MaxSimplifierIterations max_iter
- ],
-
- case rule_check of { Just pat -> CoreDoRuleCheck 0 pat; Nothing -> CoreDoNothing }
-
+ simpl_phase 0 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-spec", setDumpFlag Opt_D_dump_spec)
, ( "ddump-prep", setDumpFlag Opt_D_dump_prep)
, ( "ddump-stg", setDumpFlag Opt_D_dump_stg)
, ( "O" , OptIntSuffix (\mb_n -> upd (setOptLevel (mb_n `orElse` 1))))
-- If the number is missing, use 1
+ , ( "fsimplifier-phases", IntSuffix (\n ->
+ upd (\dfs -> dfs{ simplPhases = n })) )
, ( "fmax-simplifier-iterations", IntSuffix (\n ->
upd (\dfs -> dfs{ maxSimplIterations = n })) )
- -- liberate-case-threshold is an old flag for '-fspec-threshold'
- , ( "fspec-threshold", IntSuffix (\n -> upd (\dfs -> dfs{ specThreshold = n })))
- , ( "fliberate-case-threshold", IntSuffix (\n -> upd (\dfs -> dfs{ specThreshold = n })))
+ , ( "fspec-constr-threshold", IntSuffix (\n ->
+ upd (\dfs -> dfs{ specConstrThreshold = Just n })))
+ , ( "fno-spec-constr-threshold", NoArg (
+ upd (\dfs -> dfs{ specConstrThreshold = Nothing })))
+ , ( "fliberate-case-threshold", IntSuffix (\n ->
+ upd (\dfs -> dfs{ liberateCaseThreshold = Just n })))
+ , ( "fno-liberate-case-threshold", NoArg (
+ upd (\dfs -> dfs{ liberateCaseThreshold = Nothing })))
, ( "frule-check", SepArg (\s -> upd (\dfs -> dfs{ ruleCheck = Just s })))
, ( "fcontext-stack" , IntSuffix $ \n -> upd $ \dfs -> dfs{ ctxtStkDepth = n })
( "PatternSignatures", Opt_PatternSignatures ),
( "EmptyDataDecls", Opt_EmptyDataDecls ),
( "ParallelListComp", Opt_ParallelListComp ),
+ ( "TransformListComp", Opt_TransformListComp ),
( "ForeignFunctionInterface", Opt_ForeignFunctionInterface ),
( "UnliftedFFITypes", Opt_UnliftedFFITypes ),
( "LiberalTypeSynonyms", Opt_LiberalTypeSynonyms ),
( "Rank2Types", Opt_Rank2Types ),
( "RankNTypes", Opt_RankNTypes ),
+ ( "ImpredicativeTypes", Opt_ImpredicativeTypes ),
( "TypeOperators", Opt_TypeOperators ),
( "RecursiveDo", Opt_RecursiveDo ),
( "Arrows", Opt_Arrows ),
impliedFlags :: [(DynFlag, [DynFlag])]
impliedFlags = [
- ( Opt_GADTs, [Opt_RelaxedPolyRec] ) -- We want type-sig variables to be completely rigid for GADTs
+ ( Opt_GADTs, [Opt_RelaxedPolyRec] ) -- We want type-sig variables to
+ -- be completely rigid for GADTs
+ , ( Opt_ScopedTypeVariables, [Opt_RelaxedPolyRec] ) -- Ditto for scoped type variables; see
+ -- Note [Scoped tyvars] in TcBinds
]
glasgowExtsFlags = [
Opt_PrintExplicitForalls
, Opt_ForeignFunctionInterface
, Opt_UnliftedFFITypes
- , Opt_GADTs
- , Opt_ImplicitParams
- , Opt_ScopedTypeVariables
+ , Opt_GADTs
+ , Opt_ImplicitParams
+ , Opt_ScopedTypeVariables
, Opt_UnboxedTuples
, Opt_TypeSynonymInstances
, Opt_StandaloneDeriving
, Opt_ConstrainedClassMethods
, Opt_MultiParamTypeClasses
, Opt_FunctionalDependencies
- , Opt_MagicHash
+ , Opt_MagicHash
, Opt_PolymorphicComponents
, Opt_ExistentialQuantification
, Opt_UnicodeSyntax
, Opt_PatternGuards
, Opt_LiberalTypeSynonyms
, Opt_RankNTypes
+ , Opt_ImpredicativeTypes
, Opt_TypeOperators
, Opt_RecursiveDo
, Opt_ParallelListComp
, Opt_KindSignatures
, Opt_PatternSignatures
, Opt_GeneralizedNewtypeDeriving
- , Opt_TypeFamilies ]
+ , Opt_TypeFamilies ]
------------------
isFlag :: [(String,a)] -> String -> Bool
setTmpDir dir dflags = dflags{ tmpDir = canonicalise dir }
where
#if !defined(mingw32_HOST_OS)
- canonicalise p = normalisePath p
+ 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 = normalisePath (xltCygdrive (removeTrailingSlash 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.)
- xltCygdrive path
- | "/cygdrive/" `isPrefixOf` path =
- case drop (length "/cygdrive/") path of
- drive:xs@('/':_) -> drive:':':xs
- _ -> path
- | otherwise = path
-
- -- strip the trailing backslash (awful, but we only do this once).
- removeTrailingSlash path =
- case last path of
- '/' -> init path
- '\\' -> init path
- _ -> path
+ -- 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
+ | othwerwise = path
#endif
-----------------------------------------------------------------------------
projects / ghc-hetmet.git / blobdiff