{-# OPTIONS -fno-warn-missing-fields #-}
-{-# OPTIONS -w #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
GhcLink(..), isNoLink,
PackageFlag(..),
Option(..),
+ DynLibLoader(..),
fFlags, xFlags,
-- Configuration of the core-to-core and stg-to-stg phases
import Data.IORef ( readIORef )
import Control.Exception ( throwDyn )
import Control.Monad ( when )
-#ifdef mingw32_TARGET_OS
-import Data.List ( isPrefixOf )
-#else
-import Util ( split )
-#endif
import Data.Char
import System.FilePath
| Opt_PArr -- Syntactic support for parallel arrays
| Opt_Arrows -- Arrow-notation syntax
| Opt_TemplateHaskell
+ | Opt_QuasiQuotes
| Opt_ImplicitParams
| Opt_Generics
| Opt_ImplicitPrelude
-- 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,
outputFile :: Maybe String,
outputHi :: Maybe String,
+ dynLibLoader :: DynLibLoader,
-- | This is set by DriverPipeline.runPipeline based on where
-- its output is going.
isNoLink :: GhcLink -> Bool
isNoLink NoLink = True
-isNoLink other = False
+isNoLink _ = False
data PackageFlag
= ExposePackage String
| IgnorePackage String
deriving Eq
+defaultHscTarget :: HscTarget
defaultHscTarget = defaultObjectTarget
-- | the 'HscTarget' value corresponding to the default way to create
-- object files on the current platform.
+defaultObjectTarget :: HscTarget
defaultObjectTarget
| cGhcWithNativeCodeGen == "YES" = HscAsm
| otherwise = HscC
+data DynLibLoader
+ = Deployable
+ | Wrapped (Maybe String)
+ | SystemDependent
+ deriving Eq
+
+initDynFlags :: DynFlags -> IO DynFlags
initDynFlags dflags = do
-- someday these will be dynamic flags
ways <- readIORef v_Ways
rtsBuildTag = rts_build_tag
}
+defaultDynFlags :: DynFlags
defaultDynFlags =
DynFlags {
ghcMode = CompManager,
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 = [],
outputFile = Nothing,
outputHi = Nothing,
+ dynLibLoader = Deployable,
dumpPrefix = Nothing,
dumpPrefixForce = Nothing,
includePaths = [],
Opt_ImplicitPrelude,
Opt_MonomorphismRestriction,
+ Opt_MethodSharing,
+
Opt_DoAsmMangling,
Opt_GenManifest,
| verbosity dflags >= 3 = "-v"
| otherwise = ""
+setObjectDir, setHiDir, setStubDir, setObjectSuf, setHiSuf, setHcSuf, parseDynLibLoaderMode,
+ setPgmP, setPgmL, setPgmF, setPgmc, setPgmm, setPgms, setPgma, setPgml, setPgmdll, setPgmwindres,
+ addOptL, addOptP, addOptF, addOptc, addOptm, addOpta, addOptl, addOptdep, addOptwindres,
+ addCmdlineFramework, addHaddockOpts
+ :: String -> DynFlags -> DynFlags
+setOutputFile, setOutputHi, setDumpPrefixForce
+ :: Maybe String -> DynFlags -> DynFlags
+
setObjectDir f d = d{ objectDir = Just f}
setHiDir f d = d{ hiDir = Just f}
setStubDir f d = d{ stubDir = Just f, includePaths = f : includePaths d }
setOutputFile f d = d{ outputFile = f}
setOutputHi f d = d{ outputHi = f}
+parseDynLibLoaderMode f d =
+ case splitAt 8 f of
+ ("deploy", "") -> d{ dynLibLoader = Deployable }
+ ("sysdep", "") -> d{ dynLibLoader = SystemDependent }
+ ("wrapped", "") -> d{ dynLibLoader = Wrapped Nothing }
+ ("wrapped:", "hard") -> d{ dynLibLoader = Wrapped Nothing }
+ ("wrapped:", flex) -> d{ dynLibLoader = Wrapped (Just flex) }
+ (_,_) -> error "Unknown dynlib loader"
+
setDumpPrefixForce f d = d { dumpPrefixForce = f}
-- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"]
, ([2], Opt_LiberateCase)
, ([2], Opt_SpecConstr)
+ , ([2], Opt_StaticArgumentTransformation)
, ([0,1,2], Opt_DoLambdaEtaExpansion)
-- This one is important for a tiresome reason:
-- -----------------------------------------------------------------------------
-- Standard sets of warning options
+standardWarnings :: [DynFlag]
standardWarnings
= [ Opt_WarnDeprecations,
Opt_WarnOverlappingPatterns,
Opt_WarnDuplicateExports
]
+minusWOpts :: [DynFlag]
minusWOpts
= standardWarnings ++
[ Opt_WarnUnusedBinds,
Opt_WarnDodgyImports
]
+minusWallOpts :: [DynFlag]
minusWallOpts
= minusWOpts ++
[ Opt_WarnTypeDefaults,
]
-- minuswRemovesOpts should be every warning option
+minuswRemovesOpts :: [DynFlag]
minuswRemovesOpts
= minusWallOpts ++
[Opt_WarnImplicitPrelude,
data SimplifierMode -- See comments in SimplMonad
= SimplGently
- | SimplPhase Int
+ | SimplPhase Int [String]
data SimplifierSwitch
= MaxSimplifierIterations Int
-- The core-to-core pass ordering is derived from the DynFlags:
runWhen :: Bool -> CoreToDo -> CoreToDo
runWhen True do_this = do_this
-runWhen False do_this = CoreDoNothing
+runWhen False _ = CoreDoNothing
runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
runMaybe (Just x) f = f x
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
]
-- -----------------------------------------------------------------------------
, ( "c" , NoArg (upd $ \d -> d{ ghcLink=NoLink } ))
, ( "no-link" , NoArg (upd $ \d -> d{ ghcLink=NoLink } )) -- Dep.
, ( "shared" , NoArg (upd $ \d -> d{ ghcLink=LinkDynLib } ))
+ , ( "dynload" , HasArg (upd . parseDynLibLoaderMode))
------- Libraries ---------------------------------------------------
, ( "L" , Prefix addLibraryPath )
, ( "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 (
-- these -f<blah> flags can all be reversed with -fno-<blah>
+fFlags :: [(String, DynFlag)]
fFlags = [
( "warn-dodgy-imports", Opt_WarnDodgyImports ),
( "warn-duplicate-exports", Opt_WarnDuplicateExports ),
( "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 ),
( "Arrows", Opt_Arrows ),
( "PArr", Opt_PArr ),
( "TemplateHaskell", Opt_TemplateHaskell ),
+ ( "QuasiQuotes", Opt_QuasiQuotes ),
( "Generics", Opt_Generics ),
-- On by default:
( "ImplicitPrelude", Opt_ImplicitPrelude ),
-- Note [Scoped tyvars] in TcBinds
]
+glasgowExtsFlags :: [DynFlag]
glasgowExtsFlags = [
Opt_PrintExplicitForalls
, Opt_ForeignFunctionInterface
------------------
getFlag :: [(String,a)] -> String -> a
getFlag flags f = case [ opt | (ff, opt) <- flags, ff == f] of
- (o:os) -> o
+ (o:_) -> o
[] -> panic ("get_flag " ++ f)
getPrefFlag :: String -> [(String,a)] -> String -> a
--------------------------
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 })
+addCmdlineHCInclude :: String -> DynP ()
addCmdlineHCInclude a = upd (\s -> s{cmdlineHcIncludes = a : cmdlineHcIncludes s})
+extraPkgConf_ :: FilePath -> DynP ()
extraPkgConf_ p = upd (\s -> s{ extraPkgConfs = p : extraPkgConfs s })
+exposePackage, hidePackage, ignorePackage :: String -> DynP ()
exposePackage p =
upd (\s -> s{ packageFlags = ExposePackage p : packageFlags s })
hidePackage p =
ignorePackage p =
upd (\s -> s{ packageFlags = IgnorePackage p : packageFlags s })
+setPackageName :: String -> DynFlags -> DynFlags
setPackageName p
| Nothing <- unpackPackageId pid
= throwDyn (CmdLineError ("cannot parse \'" ++ p ++ "\' as a package identifier"))
-- If we're linking a binary, then only targets that produce object
-- code are allowed (requests for other target types are ignored).
+setTarget :: HscTarget -> DynP ()
setTarget l = upd set
where
set dfs
-- used by -fasm and -fvia-C, which switch from one to the other, but
-- not from bytecode to object-code. The idea is that -fasm/-fvia-C
-- can be safely used in an OPTIONS_GHC pragma.
+setObjTarget :: HscTarget -> DynP ()
setObjTarget l = upd set
where
set dfs
= 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)
-----------------------------------------------------------------------------
-- Paths & Libraries
+addImportPath, addLibraryPath, addIncludePath, addFrameworkPath :: FilePath -> DynP ()
+
-- -i on its own deletes the import paths
addImportPath "" = upd (\s -> s{importPaths = []})
addImportPath p = upd (\s -> s{importPaths = importPaths s ++ splitPathList p})
addFrameworkPath p =
upd (\s -> s{frameworkPaths = frameworkPaths s ++ splitPathList p})
+#ifndef mingw32_TARGET_OS
+split_marker :: Char
split_marker = ':' -- not configurable (ToDo)
+#endif
splitPathList :: String -> [String]
splitPathList s = filter notNull (splitUp s)
-- finding the next split marker.
findNextPath xs =
case break (`elem` split_markers) xs of
- (p, d:ds) -> (p, ds)
+ (p, _:ds) -> (p, ds)
(p, xs) -> (p, xs)
split_markers :: [Char]
-- 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
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
--
-- -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 ""
#endif
picCCOpts :: DynFlags -> [String]
-picCCOpts dflags
+picCCOpts _dflags
#if darwin_TARGET_OS
-- Apple prefers to do things the other way round.
-- PIC is on by default.
projects / ghc-hetmet.git / blobdiff