GhcLink(..), isNoLink,
PackageFlag(..),
Option(..),
+ DynLibLoader(..),
fFlags, xFlags,
-- Configuration of the core-to-core and stg-to-stg phases
#endif
import Data.Char
+import System.FilePath
import System.IO ( hPutStrLn, stderr )
-- -----------------------------------------------------------------------------
| Opt_PArr -- Syntactic support for parallel arrays
| Opt_Arrows -- Arrow-notation syntax
| Opt_TemplateHaskell
+ | Opt_QuasiQuotes
| Opt_ImplicitParams
| Opt_Generics
| Opt_ImplicitPrelude
| 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,
outputFile :: Maybe String,
outputHi :: Maybe String,
+ dynLibLoader :: DynLibLoader,
-- | This is set by DriverPipeline.runPipeline based on where
-- its output is going.
| cGhcWithNativeCodeGen == "YES" = HscAsm
| otherwise = HscC
+data DynLibLoader
+ = Deployable
+ | Wrapped (Maybe String)
+ | SystemDependent
+ deriving Eq
+
initDynFlags dflags = do
-- someday these will be dynamic flags
ways <- readIORef v_Ways
extCoreName = "",
verbosity = 0,
optLevel = 0,
+ simplPhases = 2,
maxSimplIterations = 4,
ruleCheck = Nothing,
specConstrThreshold = Just 200,
outputFile = Nothing,
outputHi = Nothing,
+ dynLibLoader = Deployable,
dumpPrefix = Nothing,
dumpPrefixForce = Nothing,
includePaths = [],
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"]
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 },
+ simpl_phases,
- 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 },
-
- CoreDoSimplify (SimplPhase 0) [
-- Phase 0: allow all Ids to be inlined now
-- This gets foldr inlined before strictness analysis
- MaxSimplifierIterations (max max_iter 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
]
-- -----------------------------------------------------------------------------
, ( "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 )
, ( "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 })) )
( "TransformListComp", Opt_TransformListComp ),
( "ForeignFunctionInterface", Opt_ForeignFunctionInterface ),
( "UnliftedFFITypes", Opt_UnliftedFFITypes ),
- ( "LiberalTypeSynonyms", Opt_LiberalTypeSynonyms ),
+ ( "LiberalTypeSynonyms", Opt_LiberalTypeSynonyms ),
( "Rank2Types", Opt_Rank2Types ),
( "RankNTypes", Opt_RankNTypes ),
+ ( "ImpredicativeTypes", Opt_ImpredicativeTypes ),
( "TypeOperators", Opt_TypeOperators ),
( "RecursiveDo", Opt_RecursiveDo ),
( "Arrows", Opt_Arrows ),
( "PArr", Opt_PArr ),
( "TemplateHaskell", Opt_TemplateHaskell ),
+ ( "QuasiQuotes", Opt_QuasiQuotes ),
( "Generics", Opt_Generics ),
-- On by default:
( "ImplicitPrelude", Opt_ImplicitPrelude ),
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
+ | otherwise = path
#endif
-----------------------------------------------------------------------------