+
+data FloatOutSwitches
+ = FloatOutSw Bool -- True <=> float lambdas to top level
+ Bool -- True <=> float constants to top level,
+ -- even if they do not escape a lambda
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Dynamic command-line options}
+%* *
+%************************************************************************
+
+\begin{code}
+data DynFlag
+
+ -- debugging flags
+ = Opt_D_dump_cmm
+ | Opt_D_dump_asm
+ | Opt_D_dump_cpranal
+ | Opt_D_dump_deriv
+ | Opt_D_dump_ds
+ | Opt_D_dump_flatC
+ | Opt_D_dump_foreign
+ | Opt_D_dump_inlinings
+ | Opt_D_dump_occur_anal
+ | Opt_D_dump_parsed
+ | Opt_D_dump_rn
+ | Opt_D_dump_simpl
+ | Opt_D_dump_simpl_iterations
+ | Opt_D_dump_spec
+ | Opt_D_dump_prep
+ | Opt_D_dump_stg
+ | Opt_D_dump_stranal
+ | Opt_D_dump_tc
+ | Opt_D_dump_types
+ | Opt_D_dump_rules
+ | Opt_D_dump_cse
+ | Opt_D_dump_worker_wrapper
+ | Opt_D_dump_rn_trace
+ | Opt_D_dump_rn_stats
+ | Opt_D_dump_opt_cmm
+ | Opt_D_dump_simpl_stats
+ | Opt_D_dump_tc_trace
+ | Opt_D_dump_if_trace
+ | Opt_D_dump_splices
+ | Opt_D_dump_BCOs
+ | Opt_D_dump_vect
+ | Opt_D_source_stats
+ | Opt_D_verbose_core2core
+ | Opt_D_verbose_stg2stg
+ | Opt_D_dump_hi
+ | Opt_D_dump_hi_diffs
+ | Opt_D_dump_minimal_imports
+ | Opt_DoCoreLinting
+ | Opt_DoStgLinting
+ | Opt_DoCmmLinting
+
+ | Opt_WarnIsError -- -Werror; makes warnings fatal
+ | Opt_WarnDuplicateExports
+ | Opt_WarnHiShadows
+ | Opt_WarnIncompletePatterns
+ | Opt_WarnMissingFields
+ | Opt_WarnMissingMethods
+ | Opt_WarnMissingSigs
+ | Opt_WarnNameShadowing
+ | Opt_WarnOverlappingPatterns
+ | Opt_WarnSimplePatterns
+ | Opt_WarnTypeDefaults
+ | Opt_WarnUnusedBinds
+ | Opt_WarnUnusedImports
+ | Opt_WarnUnusedMatches
+ | Opt_WarnDeprecations
+ | Opt_WarnDodgyImports
+
+ -- language opts
+ | Opt_AllowOverlappingInstances
+ | Opt_AllowUndecidableInstances
+ | Opt_AllowIncoherentInstances
+ | Opt_NoMonomorphismRestriction
+ | Opt_GlasgowExts
+ | Opt_FFI
+ | Opt_PArr -- syntactic support for parallel arrays
+ | Opt_Arrows -- Arrow-notation syntax
+ | Opt_TH
+ | Opt_ImplicitParams
+ | Opt_Generics
+ | Opt_NoImplicitPrelude
+
+ -- optimisation opts
+ | Opt_Strictness
+ | Opt_FullLaziness
+ | Opt_CSE
+ | Opt_IgnoreInterfacePragmas
+ | Opt_OmitInterfacePragmas
+ | Opt_DoLambdaEtaExpansion
+ | Opt_IgnoreAsserts
+ | Opt_DoEtaReduction
+ | Opt_CaseMerge
+ | Opt_UnboxStrictFields
+
+ deriving (Eq)
+
+data DynFlags = DynFlags {
+ coreToDo :: Maybe [CoreToDo], -- reserved for use with -Ofile
+ stgToDo :: [StgToDo],
+ hscLang :: HscLang,
+ hscOutName :: String, -- name of the output file
+ hscStubHOutName :: String, -- name of the .stub_h output file
+ hscStubCOutName :: String, -- name of the .stub_c output file
+ extCoreName :: String, -- name of the .core output file
+ verbosity :: Int, -- verbosity level
+ optLevel :: Int, -- optimisation level
+ maxSimplIterations :: Int, -- max simplifier iterations
+ ruleCheck :: Maybe String,
+ cppFlag :: Bool, -- preprocess with cpp?
+ ppFlag :: Bool, -- preprocess with a Haskell Pp?
+ stolen_x86_regs :: Int,
+ cmdlineHcIncludes :: [String], -- -#includes
+
+ -- options for particular phases
+ opt_L :: [String],
+ opt_P :: [String],
+ opt_F :: [String],
+ opt_c :: [String],
+ opt_a :: [String],
+ opt_m :: [String],
+#ifdef ILX
+ opt_I :: [String],
+ opt_i :: [String],
+#endif
+
+ -- hsc dynamic flags
+ flags :: [DynFlag]
+ }
+
+data HscLang
+ = HscC
+ | HscAsm
+ | HscJava
+ | HscILX
+ | HscInterpreted
+ | HscNothing
+ deriving (Eq, Show)
+
+defaultHscLang
+ | cGhcWithNativeCodeGen == "YES" &&
+ (prefixMatch "i386" cTARGETPLATFORM ||
+ prefixMatch "sparc" cTARGETPLATFORM ||
+ prefixMatch "powerpc" cTARGETPLATFORM) = HscAsm
+ | otherwise = HscC
+
+defaultDynFlags = DynFlags {
+ coreToDo = Nothing, stgToDo = [],
+ hscLang = defaultHscLang,
+ hscOutName = "",
+ hscStubHOutName = "", hscStubCOutName = "",
+ extCoreName = "",
+ verbosity = 0,
+ optLevel = 0,
+ maxSimplIterations = 4,
+ ruleCheck = Nothing,
+ cppFlag = False,
+ ppFlag = False,
+ stolen_x86_regs = 4,
+ cmdlineHcIncludes = [],
+ opt_L = [],
+ opt_P = [],
+ opt_F = [],
+ opt_c = [],
+ opt_a = [],
+ opt_m = [],
+#ifdef ILX
+ opt_I = [],
+ opt_i = [],
+#endif
+ flags = [
+ Opt_Generics,
+ -- Generating the helper-functions for
+ -- generics is now on by default
+ Opt_Strictness,
+ -- strictness is on by default, but this only
+ -- applies to -O.
+ Opt_CSE, -- similarly for CSE.
+ Opt_FullLaziness, -- ...and for full laziness
+
+ Opt_DoLambdaEtaExpansion,
+ -- This one is important for a tiresome reason:
+ -- we want to make sure that the bindings for data
+ -- constructors are eta-expanded. This is probably
+ -- a good thing anyway, but it seems fragile.
+
+ -- and the default no-optimisation options:
+ Opt_IgnoreInterfacePragmas,
+ Opt_OmitInterfacePragmas
+
+ ] ++ standardWarnings
+ }
+
+{-
+ Verbosity levels:
+
+ 0 | print errors & warnings only
+ 1 | minimal verbosity: print "compiling M ... done." for each module.
+ 2 | equivalent to -dshow-passes
+ 3 | equivalent to existing "ghc -v"
+ 4 | "ghc -v -ddump-most"
+ 5 | "ghc -v -ddump-all"
+-}
+
+dopt :: DynFlag -> DynFlags -> Bool
+dopt f dflags = f `elem` (flags dflags)
+
+dopt_CoreToDo :: DynFlags -> Maybe [CoreToDo]
+dopt_CoreToDo = coreToDo
+
+dopt_StgToDo :: DynFlags -> [StgToDo]
+dopt_StgToDo = stgToDo
+
+dopt_OutName :: DynFlags -> String
+dopt_OutName = hscOutName
+
+dopt_HscLang :: DynFlags -> HscLang
+dopt_HscLang = hscLang
+
+dopt_set :: DynFlags -> DynFlag -> DynFlags
+dopt_set dfs f = dfs{ flags = f : flags dfs }
+
+dopt_unset :: DynFlags -> DynFlag -> DynFlags
+dopt_unset dfs f = dfs{ flags = filter (/= f) (flags dfs) }
+
+getOpts :: (DynFlags -> [a]) -> IO [a]
+ -- We add to the options from the front, so we need to reverse the list
+getOpts opts = dynFlag opts >>= return . reverse
+
+-- we can only switch between HscC, HscAsmm, and HscILX with dynamic flags
+-- (-fvia-C, -fasm, -filx respectively).
+setLang l = updDynFlags (\ dfs -> case hscLang dfs of
+ HscC -> dfs{ hscLang = l }
+ HscAsm -> dfs{ hscLang = l }
+ HscILX -> dfs{ hscLang = l }
+ _ -> dfs)
+
+getVerbFlag = do
+ verb <- dynFlag verbosity
+ if verb >= 3 then return "-v" else return ""
+
+-----------------------------------------------------------------------------
+-- Setting the optimisation level
+
+setOptLevel :: Int -> IO ()
+setOptLevel n
+ = do dflags <- getDynFlags
+ if hscLang dflags == HscInterpreted && n > 0
+ then putStr "warning: -O conflicts with --interactive; -O ignored.\n"
+ else updDynFlags (setOptLevel' n)
+
+setOptLevel' n dfs
+ = if (n >= 1)
+ then dfs2{ hscLang = HscC, optLevel = n } -- turn on -fvia-C with -O
+ else dfs2{ optLevel = n }
+ where
+ dfs1 = foldr (flip dopt_unset) dfs remove_dopts
+ dfs2 = foldr (flip dopt_set) dfs1 extra_dopts
+
+ extra_dopts
+ | n == 0 = opt_0_dopts
+ | otherwise = opt_1_dopts
+
+ remove_dopts
+ | n == 0 = opt_1_dopts
+ | otherwise = opt_0_dopts
+
+opt_0_dopts = [
+ Opt_IgnoreInterfacePragmas,
+ Opt_OmitInterfacePragmas
+ ]
+
+opt_1_dopts = [
+ Opt_IgnoreAsserts,
+ Opt_DoEtaReduction,
+ Opt_CaseMerge
+ ]
+
+-- Core-to-core phases:
+
+buildCoreToDo :: DynFlags -> [CoreToDo]
+buildCoreToDo dflags = core_todo
+ where
+ opt_level = optLevel dflags
+ max_iter = maxSimplIterations dflags
+ strictness = dopt Opt_Strictness dflags
+ full_laziness = dopt Opt_FullLaziness dflags
+ cse = dopt Opt_CSE dflags
+ rule_check = ruleCheck dflags
+
+ core_todo =
+ if opt_level == 0 then
+ [
+ CoreDoSimplify (SimplPhase 0) [
+ MaxSimplifierIterations max_iter
+ ]
+ ]
+
+ else {- opt_level >= 1 -} [
+
+ -- initial simplify: mk specialiser happy: minimum effort please
+ CoreDoSimplify SimplGently [
+ -- Simplify "gently"
+ -- Don't inline anything till full laziness has bitten
+ -- In particular, inlining wrappers inhibits floating
+ -- e.g. ...(case f x of ...)...
+ -- ==> ...(case (case x of I# x# -> fw x#) of ...)...
+ -- ==> ...(case x of I# x# -> case fw x# of ...)...
+ -- and now the redex (f x) isn't floatable any more
+ -- Similarly, don't apply any rules until after full
+ -- laziness. Notably, list fusion can prevent floating.
+
+ NoCaseOfCase,
+ -- Don't do case-of-case transformations.
+ -- This makes full laziness work better
+ MaxSimplifierIterations max_iter
+ ],
+
+ -- Specialisation is best done before full laziness
+ -- so that overloaded functions have all their dictionary lambdas manifest
+ CoreDoSpecialising,
+
+ if full_laziness then CoreDoFloatOutwards (FloatOutSw False False)
+ else CoreDoNothing,
+
+ 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 },
+
+ 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 foldr k z xs
+ -- ==> 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!
+
+ ],
+ case rule_check of { Just pat -> CoreDoRuleCheck 0 pat; Nothing -> CoreDoNothing },
+
+#ifdef OLD_STRICTNESS
+ CoreDoOldStrictness
+#endif
+ if strictness then CoreDoStrictness else CoreDoNothing,
+ CoreDoWorkerWrapper,
+ CoreDoGlomBinds,
+
+ CoreDoSimplify (SimplPhase 0) [
+ MaxSimplifierIterations max_iter
+ ],
+
+ if full_laziness then
+ CoreDoFloatOutwards (FloatOutSw False -- Not lambdas
+ True) -- Float constants
+ else CoreDoNothing,
+ -- nofib/spectral/hartel/wang doubles in speed if you
+ -- do full laziness late in the day. It only happens
+ -- after fusion and other stuff, so the early pass doesn't
+ -- catch it. For the record, the redex is
+ -- f_el22 (f_el21 r_midblock)
+
+
+ -- We want CSE to follow the final full-laziness pass, because it may
+ -- succeed in commoning up things floated out by full laziness.
+ -- CSE used to rely on the no-shadowing invariant, but it doesn't any more
+
+ if cse then CoreCSE else CoreDoNothing,
+
+ CoreDoFloatInwards,
+
+-- Case-liberation for -O2. This should be after
+-- strictness analysis and the simplification which follows it.
+
+ case rule_check of { Just pat -> CoreDoRuleCheck 0 pat; Nothing -> CoreDoNothing },
+
+ if opt_level >= 2 then
+ CoreLiberateCase
+ else
+ CoreDoNothing,
+ if opt_level >= 2 then
+ CoreDoSpecConstr
+ else
+ CoreDoNothing,
+
+ -- Final clean-up simplification:
+ CoreDoSimplify (SimplPhase 0) [
+ MaxSimplifierIterations max_iter
+ ]
+ ]
+
+-- --------------------------------------------------------------------------
+-- Mess about with the mutable variables holding the dynamic arguments
+
+-- v_InitDynFlags
+-- is the "baseline" dynamic flags, initialised from
+-- the defaults and command line options, and updated by the
+-- ':s' command in GHCi.
+--
+-- v_DynFlags
+-- is the dynamic flags for the current compilation. It is reset
+-- to the value of v_InitDynFlags before each compilation, then
+-- updated by reading any OPTIONS pragma in the current module.
+
+GLOBAL_VAR(v_InitDynFlags, defaultDynFlags, DynFlags)
+GLOBAL_VAR(v_DynFlags, defaultDynFlags, DynFlags)
+
+setDynFlags :: DynFlags -> IO ()
+setDynFlags dfs = writeIORef v_DynFlags dfs
+
+saveDynFlags :: IO ()
+saveDynFlags = do dfs <- readIORef v_DynFlags
+ writeIORef v_InitDynFlags dfs
+
+restoreDynFlags :: IO DynFlags
+restoreDynFlags = do dfs <- readIORef v_InitDynFlags
+ writeIORef v_DynFlags dfs
+ return dfs
+
+getDynFlags :: IO DynFlags
+getDynFlags = readIORef v_DynFlags
+
+updDynFlags :: (DynFlags -> DynFlags) -> IO ()
+updDynFlags f = do dfs <- readIORef v_DynFlags
+ writeIORef v_DynFlags (f dfs)
+
+dynFlag :: (DynFlags -> a) -> IO a
+dynFlag f = do dflags <- readIORef v_DynFlags; return (f dflags)
+
+setDynFlag, unSetDynFlag :: DynFlag -> IO ()
+setDynFlag f = updDynFlags (\dfs -> dopt_set dfs f)
+unSetDynFlag f = updDynFlags (\dfs -> dopt_unset dfs f)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Warnings}
+%* *
+%************************************************************************
+
+\begin{code}
+standardWarnings
+ = [ Opt_WarnDeprecations,
+ Opt_WarnOverlappingPatterns,
+ Opt_WarnMissingFields,
+ Opt_WarnMissingMethods,
+ Opt_WarnDuplicateExports
+ ]
+
+minusWOpts
+ = standardWarnings ++
+ [ Opt_WarnUnusedBinds,
+ Opt_WarnUnusedMatches,
+ Opt_WarnUnusedImports,
+ Opt_WarnIncompletePatterns,
+ Opt_WarnDodgyImports
+ ]
+
+minusWallOpts
+ = minusWOpts ++
+ [ Opt_WarnTypeDefaults,
+ Opt_WarnNameShadowing,
+ Opt_WarnMissingSigs,
+ Opt_WarnHiShadows
+ ]