DynFlags.hs

-----------------------------------------------------------------------------
--
-- Dynamic flags
--
-- Most flags are dynamic flags, which means they can change from
-- compilation to compilation using OPTIONS_GHC pragmas, and in a
-- multi-session GHC each session can be using different dynamic
-- flags.  Dynamic flags can also be set at the prompt in GHCi.
--
-- (c) The University of Glasgow 2005
--
-----------------------------------------------------------------------------

module DynFlags (
        -- Dynamic flags
        DynFlag(..),
        DynFlags(..),
        HscTarget(..), isObjectTarget, defaultObjectTarget,
        GhcMode(..), isOneShot,
        GhcLink(..), isNoLink,
        PackageFlag(..),
        Option(..),
        DynLibLoader(..),
        fFlags, xFlags,
        DPHBackend(..),

        -- Configuration of the core-to-core and stg-to-stg phases
        CoreToDo(..),
        StgToDo(..),
        SimplifierSwitch(..),
        SimplifierMode(..), FloatOutSwitches(..),
        getCoreToDo, getStgToDo,

        -- Manipulating DynFlags
        defaultDynFlags,                -- DynFlags
        initDynFlags,                   -- DynFlags -> IO DynFlags

        dopt,                           -- DynFlag -> DynFlags -> Bool
        dopt_set, dopt_unset,           -- DynFlags -> DynFlag -> DynFlags
        getOpts,                        -- (DynFlags -> [a]) -> IO [a]
        getVerbFlag,
        updOptLevel,
        setTmpDir,
        setPackageName,

        -- parsing DynFlags
        parseDynamicFlags,
        allFlags,

        -- misc stuff
        machdepCCOpts, picCCOpts,
    supportedLanguages, languageOptions,
    compilerInfo,
  ) where

#include "HsVersions.h"

import Module
import PackageConfig
import PrelNames        ( mAIN )
#ifdef i386_TARGET_ARCH
import StaticFlags      ( opt_Static )
#endif
import StaticFlags      ( opt_PIC, WayName(..), v_Ways, v_Build_tag,
                          v_RTS_Build_tag )
import {-# SOURCE #-} Packages (PackageState)
import DriverPhases     ( Phase(..), phaseInputExt )
import Config
import CmdLineParser
import Constants        ( mAX_CONTEXT_REDUCTION_DEPTH )
import Panic            ( panic, GhcException(..) )
import UniqFM           ( UniqFM )
import Util
import Maybes           ( orElse )
import SrcLoc           ( SrcSpan )
import Outputable
import {-# SOURCE #-} ErrUtils ( Severity(..), Message, mkLocMessage )

import Data.IORef       ( readIORef )
import Control.Exception ( throwDyn )
import Control.Monad    ( when )

import Data.Char
import System.FilePath
import System.IO        ( hPutStrLn, stderr )

-- -----------------------------------------------------------------------------
-- DynFlags

data DynFlag

   -- debugging flags
   = Opt_D_dump_cmm
   | Opt_D_dump_cmmz
   | Opt_D_dump_cmmz_pretty
   | Opt_D_dump_cps_cmm
   | Opt_D_dump_cvt_cmm
   | Opt_D_dump_asm
   | Opt_D_dump_asm_native
   | Opt_D_dump_asm_liveness
   | Opt_D_dump_asm_coalesce
   | Opt_D_dump_asm_regalloc
   | Opt_D_dump_asm_regalloc_stages
   | Opt_D_dump_asm_conflicts
   | Opt_D_dump_asm_stats
   | 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_rule_firings
   | 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_simpl_phases
   | 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_dump_hpc
   | 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_D_dump_mod_cycles
   | Opt_D_dump_view_pattern_commoning
   | Opt_D_faststring_stats
   | Opt_DumpToFile                     -- ^ Append dump output to files instead of stdout.
   | Opt_D_no_debug_output
   | Opt_DoCoreLinting
   | Opt_DoStgLinting
   | Opt_DoCmmLinting
   | Opt_DoAsmLinting

   | Opt_WarnIsError                    -- -Werror; makes warnings fatal
   | Opt_WarnDuplicateExports
   | Opt_WarnHiShadows
   | Opt_WarnImplicitPrelude
   | Opt_WarnIncompletePatterns
   | Opt_WarnIncompletePatternsRecUpd
   | Opt_WarnMissingFields
   | Opt_WarnMissingMethods
   | Opt_WarnMissingSigs
   | Opt_WarnNameShadowing
   | Opt_WarnOverlappingPatterns
   | Opt_WarnSimplePatterns
   | Opt_WarnTypeDefaults
   | Opt_WarnMonomorphism
   | Opt_WarnUnusedBinds
   | Opt_WarnUnusedImports
   | Opt_WarnUnusedMatches
   | Opt_WarnDeprecations
   | Opt_WarnDeprecatedFlags
   | Opt_WarnDodgyImports
   | Opt_WarnOrphans
   | Opt_WarnTabs
   | Opt_WarnDodgyForeignImports

   -- language opts
   | Opt_OverlappingInstances
   | Opt_UndecidableInstances
   | Opt_IncoherentInstances
   | Opt_MonomorphismRestriction
   | Opt_MonoPatBinds
   | Opt_ExtendedDefaultRules           -- Use GHC's extended rules for defaulting
   | Opt_ForeignFunctionInterface
   | Opt_UnliftedFFITypes
   | Opt_PArr                           -- Syntactic support for parallel arrays
   | Opt_Arrows                         -- Arrow-notation syntax
   | Opt_TemplateHaskell
   | Opt_QuasiQuotes
   | Opt_ImplicitParams
   | Opt_Generics
   | Opt_ImplicitPrelude
   | Opt_ScopedTypeVariables
   | Opt_UnboxedTuples
   | Opt_BangPatterns
   | Opt_TypeFamilies
   | Opt_OverloadedStrings
   | Opt_DisambiguateRecordFields
   | Opt_RecordWildCards
   | Opt_RecordPuns
   | Opt_ViewPatterns
   | Opt_GADTs
   | Opt_RelaxedPolyRec
   | Opt_StandaloneDeriving
   | Opt_DeriveDataTypeable
   | Opt_TypeSynonymInstances
   | Opt_FlexibleContexts
   | Opt_FlexibleInstances
   | Opt_ConstrainedClassMethods
   | Opt_MultiParamTypeClasses
   | Opt_FunctionalDependencies
   | Opt_UnicodeSyntax
   | Opt_PolymorphicComponents
   | Opt_ExistentialQuantification
   | Opt_MagicHash
   | Opt_EmptyDataDecls
   | Opt_KindSignatures
   | Opt_PatternSignatures
   | Opt_ParallelListComp
   | Opt_TransformListComp
   | Opt_GeneralizedNewtypeDeriving
   | Opt_RecursiveDo
   | Opt_PostfixOperators
   | Opt_PatternGuards
   | Opt_LiberalTypeSynonyms
   | Opt_Rank2Types
   | Opt_RankNTypes
   | Opt_ImpredicativeTypes
   | Opt_TypeOperators

   | Opt_PrintExplicitForalls

   -- optimisation opts
   | Opt_Strictness
   | Opt_FullLaziness
   | Opt_StaticArgumentTransformation
   | Opt_CSE
   | Opt_LiberateCase
   | Opt_SpecConstr
   | Opt_IgnoreInterfacePragmas
   | Opt_OmitInterfacePragmas
   | Opt_DoLambdaEtaExpansion
   | Opt_IgnoreAsserts
   | Opt_DoEtaReduction
   | Opt_CaseMerge
   | Opt_UnboxStrictFields
   | Opt_MethodSharing
   | Opt_DictsCheap
   | Opt_RewriteRules
   | Opt_Vectorise
   | Opt_RegsGraph                      -- do graph coloring register allocation
   | Opt_RegsIterative                  -- do iterative coalescing graph coloring register allocation

   -- misc opts
   | Opt_Cpp
   | Opt_Pp
   | Opt_ForceRecomp
   | Opt_DryRun
   | Opt_DoAsmMangling
   | Opt_ExcessPrecision
   | Opt_ReadUserPackageConf
   | Opt_NoHsMain
   | Opt_SplitObjs
   | Opt_StgStats
   | Opt_HideAllPackages
   | Opt_PrintBindResult
   | Opt_Haddock
   | Opt_HaddockOptions
   | Opt_Hpc_No_Auto
   | Opt_BreakOnException
   | Opt_BreakOnError
   | Opt_PrintEvldWithShow
   | Opt_PrintBindContents
   | Opt_GenManifest
   | Opt_EmbedManifest
   | Opt_RunCPSZ
   | Opt_ConvertToZipCfgAndBack
   | Opt_AutoLinkPackages

   -- keeping stuff
   | Opt_KeepHiDiffs
   | Opt_KeepHcFiles
   | Opt_KeepSFiles
   | Opt_KeepRawSFiles
   | Opt_KeepTmpFiles

   deriving (Eq, Show)

data DynFlags = DynFlags {
  ghcMode               :: GhcMode,
  ghcLink               :: GhcLink,
  coreToDo              :: Maybe [CoreToDo], -- reserved for -Ofile
  stgToDo               :: Maybe [StgToDo],  -- similarly
  hscTarget             :: HscTarget,
  hscOutName            :: String,      -- name of the output file
  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
  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,
  cmdlineHcIncludes     :: [String],    -- -#includes
  importPaths           :: [FilePath],
  mainModIs             :: Module,
  mainFunIs             :: Maybe String,
  ctxtStkDepth          :: Int,         -- Typechecker context stack depth

  dphBackend            :: DPHBackend,

  thisPackage           :: PackageId,

  -- ways
  wayNames              :: [WayName],   -- way flags from the cmd line
  buildTag              :: String,      -- the global "way" (eg. "p" for prof)
  rtsBuildTag           :: String,      -- the RTS "way"

  -- paths etc.
  objectDir             :: Maybe String,
  hiDir                 :: Maybe String,
  stubDir               :: Maybe String,

  objectSuf             :: String,
  hcSuf                 :: String,
  hiSuf                 :: String,

  outputFile            :: Maybe String,
  outputHi              :: Maybe String,
  dynLibLoader          :: DynLibLoader,

  -- | This is set by DriverPipeline.runPipeline based on where
  --    its output is going.
  dumpPrefix            :: Maybe FilePath,

  -- | Override the dumpPrefix set by runPipeline.
  --    Set by -ddump-file-prefix
  dumpPrefixForce       :: Maybe FilePath,

  includePaths          :: [String],
  libraryPaths          :: [String],
  frameworkPaths        :: [String],    -- used on darwin only
  cmdlineFrameworks     :: [String],    -- ditto
  tmpDir                :: String,      -- no trailing '/'

  ghcUsagePath          :: FilePath,    -- Filled in by SysTools
  ghciUsagePath         :: FilePath,    -- ditto

  hpcDir                :: String,      -- ^ path to store the .mix files

  -- options for particular phases
  opt_L                 :: [String],
  opt_P                 :: [String],
  opt_F                 :: [String],
  opt_c                 :: [String],
  opt_m                 :: [String],
  opt_a                 :: [String],
  opt_l                 :: [String],
  opt_dep               :: [String],
  opt_windres           :: [String],

  -- commands for particular phases
  pgm_L                 :: String,
  pgm_P                 :: (String,[Option]),
  pgm_F                 :: String,
  pgm_c                 :: (String,[Option]),
  pgm_m                 :: (String,[Option]),
  pgm_s                 :: (String,[Option]),
  pgm_a                 :: (String,[Option]),
  pgm_l                 :: (String,[Option]),
  pgm_dll               :: (String,[Option]),
  pgm_T                 :: String,
  pgm_sysman            :: String,
  pgm_windres           :: String,

  --  Package flags
  extraPkgConfs         :: [FilePath],
  topDir                :: FilePath,    -- filled in by SysTools
  systemPackageConfig   :: FilePath,    -- ditto
        -- The -package-conf flags given on the command line, in the order
        -- they appeared.

  packageFlags          :: [PackageFlag],
        -- The -package and -hide-package flags from the command-line

  -- Package state
  -- NB. do not modify this field, it is calculated by
  -- Packages.initPackages and Packages.updatePackages.
  pkgDatabase           :: Maybe (UniqFM PackageConfig),
  pkgState              :: PackageState,

  -- hsc dynamic flags
  flags                 :: [DynFlag],

  -- message output
  log_action            :: Severity -> SrcSpan -> PprStyle -> Message -> IO (),

  haddockOptions :: Maybe String
 }

data HscTarget
  = HscC
  | HscAsm
  | HscJava
  | HscInterpreted
  | HscNothing
  deriving (Eq, Show)

-- | will this target result in an object file on the disk?
isObjectTarget :: HscTarget -> Bool
isObjectTarget HscC     = True
isObjectTarget HscAsm   = True
isObjectTarget _        = False

-- | The 'GhcMode' tells us whether we're doing multi-module
-- compilation (controlled via the "GHC" API) or one-shot
-- (single-module) compilation.  This makes a difference primarily to
-- the "Finder": in one-shot mode we look for interface files for
-- imported modules, but in multi-module mode we look for source files
-- in order to check whether they need to be recompiled.
data GhcMode
  = CompManager         -- ^ --make, GHCi, etc.
  | OneShot             -- ^ ghc -c Foo.hs
  | MkDepend            -- ^ ghc -M, see Finder for why we need this
  deriving Eq

isOneShot :: GhcMode -> Bool
isOneShot OneShot = True
isOneShot _other  = False

-- | What kind of linking to do.
data GhcLink    -- What to do in the link step, if there is one
  = NoLink              -- Don't link at all
  | 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, Show)

isNoLink :: GhcLink -> Bool
isNoLink NoLink = True
isNoLink _      = False

data PackageFlag
  = ExposePackage  String
  | HidePackage    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
 build_tag <- readIORef v_Build_tag
 rts_build_tag <- readIORef v_RTS_Build_tag
 return dflags{
        wayNames        = ways,
        buildTag        = build_tag,
        rtsBuildTag     = rts_build_tag
        }

defaultDynFlags :: DynFlags
defaultDynFlags =
     DynFlags {
        ghcMode                 = CompManager,
        ghcLink                 = LinkBinary,
        coreToDo                = Nothing,
        stgToDo                 = Nothing,
        hscTarget               = defaultHscTarget,
        hscOutName              = "",
        extCoreName             = "",
        verbosity               = 0,
        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       = [],
        importPaths             = ["."],
        mainModIs               = mAIN,
        mainFunIs               = Nothing,
        ctxtStkDepth            = mAX_CONTEXT_REDUCTION_DEPTH,

        dphBackend              = DPHPar,

        thisPackage             = mainPackageId,

        objectDir               = Nothing,
        hiDir                   = Nothing,
        stubDir                 = Nothing,

        objectSuf               = phaseInputExt StopLn,
        hcSuf                   = phaseInputExt HCc,
        hiSuf                   = "hi",

        outputFile              = Nothing,
        outputHi                = Nothing,
        dynLibLoader            = Deployable,
        dumpPrefix              = Nothing,
        dumpPrefixForce         = Nothing,
        includePaths            = [],
        libraryPaths            = [],
        frameworkPaths          = [],
        cmdlineFrameworks       = [],
        tmpDir                  = cDEFAULT_TMPDIR,

        hpcDir                  = ".hpc",

        opt_L                   = [],
        opt_P                   = (if opt_PIC
                                   then ["-D__PIC__"]
                                   else []),
        opt_F                   = [],
        opt_c                   = [],
        opt_a                   = [],
        opt_m                   = [],
        opt_l                   = [],
        opt_dep                 = [],
        opt_windres             = [],

        extraPkgConfs           = [],
        packageFlags            = [],
        pkgDatabase             = Nothing,
        pkgState                = panic "no package state yet: call GHC.setSessionDynFlags",
        wayNames                = panic "defaultDynFlags: No wayNames",
        buildTag                = panic "defaultDynFlags: No buildTag",
        rtsBuildTag             = panic "defaultDynFlags: No rtsBuildTag",
        -- initSysTools fills all these in
        ghcUsagePath            = panic "defaultDynFlags: No ghciUsagePath",
        ghciUsagePath           = panic "defaultDynFlags: No ghciUsagePath",
        topDir                  = panic "defaultDynFlags: No topDir",
        systemPackageConfig     = panic "defaultDynFlags: No systemPackageConfig",
        pgm_L                   = panic "defaultDynFlags: No pgm_L",
        pgm_P                   = panic "defaultDynFlags: No pgm_P",
        pgm_F                   = panic "defaultDynFlags: No pgm_F",
        pgm_c                   = panic "defaultDynFlags: No pgm_c",
        pgm_m                   = panic "defaultDynFlags: No pgm_m",
        pgm_s                   = panic "defaultDynFlags: No pgm_s",
        pgm_a                   = panic "defaultDynFlags: No pgm_a",
        pgm_l                   = panic "defaultDynFlags: No pgm_l",
        pgm_dll                 = panic "defaultDynFlags: No pgm_dll",
        pgm_T                   = panic "defaultDynFlags: No pgm_T",
        pgm_sysman              = panic "defaultDynFlags: No pgm_sysman",
        pgm_windres             = panic "defaultDynFlags: No pgm_windres",
        -- end of initSysTools values
        haddockOptions = Nothing,
        flags = [
            Opt_AutoLinkPackages,
            Opt_ReadUserPackageConf,

            Opt_MonoPatBinds,   -- Experimentally, I'm making this non-standard
                                -- behaviour the default, to see if anyone notices
                                -- SLPJ July 06

            Opt_ImplicitPrelude,
            Opt_MonomorphismRestriction,

            Opt_MethodSharing,

            Opt_DoAsmMangling,

            Opt_GenManifest,
            Opt_EmbedManifest,
            Opt_PrintBindContents
            ]
            ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns]
                    -- The default -O0 options
            ++ standardWarnings,

        log_action = \severity srcSpan style msg ->
                        case severity of
                          SevInfo  -> hPutStrLn stderr (show (msg style))
                          SevFatal -> hPutStrLn stderr (show (msg style))
                          _        -> hPutStrLn stderr ('\n':show ((mkLocMessage srcSpan msg) style))
      }

{-
    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_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 -> (DynFlags -> [a]) -> [a]
getOpts dflags opts = reverse (opts dflags)
        -- We add to the options from the front, so we need to reverse the list

getVerbFlag :: DynFlags -> String
getVerbFlag dflags
  | 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 }
  -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file
  -- #included from the .hc file when compiling with -fvia-C.

setObjectSuf  f d = d{ objectSuf  = f}
setHiSuf      f d = d{ hiSuf      = f}
setHcSuf      f d = d{ hcSuf      = f}

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"]
-- Config.hs should really use Option.
setPgmP   f d = let (pgm:args) = words f in d{ pgm_P   = (pgm, map Option args)}

setPgmL   f d = d{ pgm_L   = f}
setPgmF   f d = d{ pgm_F   = f}
setPgmc   f d = d{ pgm_c   = (f,[])}
setPgmm   f d = d{ pgm_m   = (f,[])}
setPgms   f d = d{ pgm_s   = (f,[])}
setPgma   f d = d{ pgm_a   = (f,[])}
setPgml   f d = d{ pgm_l   = (f,[])}
setPgmdll f d = d{ pgm_dll = (f,[])}
setPgmwindres f d = d{ pgm_windres = f}

addOptL   f d = d{ opt_L   = f : opt_L d}
addOptP   f d = d{ opt_P   = f : opt_P d}
addOptF   f d = d{ opt_F   = f : opt_F d}
addOptc   f d = d{ opt_c   = f : opt_c d}
addOptm   f d = d{ opt_m   = f : opt_m d}
addOpta   f d = d{ opt_a   = f : opt_a d}
addOptl   f d = d{ opt_l   = f : opt_l d}
addOptdep f d = d{ opt_dep = f : opt_dep d}
addOptwindres f d = d{ opt_windres = f : opt_windres d}

addCmdlineFramework f d = d{ cmdlineFrameworks = f : cmdlineFrameworks d}

addHaddockOpts f d = d{ haddockOptions = Just f}

-- -----------------------------------------------------------------------------
-- Command-line options

-- When invoking external tools as part of the compilation pipeline, we
-- pass these a sequence of options on the command-line. Rather than
-- just using a list of Strings, we use a type that allows us to distinguish
-- between filepaths and 'other stuff'. [The reason being, of course, that
-- this type gives us a handle on transforming filenames, and filenames only,
-- to whatever format they're expected to be on a particular platform.]

data Option
 = FileOption -- an entry that _contains_ filename(s) / filepaths.
              String  -- a non-filepath prefix that shouldn't be
                      -- transformed (e.g., "/out=")
              String  -- the filepath/filename portion
 | Option     String

-----------------------------------------------------------------------------
-- Setting the optimisation level

updOptLevel :: Int -> DynFlags -> DynFlags
-- Set dynflags appropriate to the optimisation level
updOptLevel n dfs
  = dfs2{ optLevel = final_n }
  where
   final_n = max 0 (min 2 n)    -- Clamp to 0 <= n <= 2
   dfs1 = foldr (flip dopt_unset) dfs  remove_dopts
   dfs2 = foldr (flip dopt_set)   dfs1 extra_dopts

   extra_dopts  = [ f | (ns,f) <- optLevelFlags, final_n `elem` ns ]
   remove_dopts = [ f | (ns,f) <- optLevelFlags, final_n `notElem` ns ]

optLevelFlags :: [([Int], DynFlag)]
optLevelFlags
  = [ ([0],     Opt_IgnoreInterfacePragmas)
    , ([0],     Opt_OmitInterfacePragmas)

    , ([1,2],   Opt_IgnoreAsserts)
    , ([1,2],   Opt_RewriteRules)       -- Off for -O0; see Note [Scoping for Builtin rules]
                                        --              in PrelRules
    , ([1,2],   Opt_DoEtaReduction)
    , ([1,2],   Opt_CaseMerge)
    , ([1,2],   Opt_Strictness)
    , ([1,2],   Opt_CSE)
    , ([1,2],   Opt_FullLaziness)

    , ([2],     Opt_LiberateCase)
    , ([2],     Opt_SpecConstr)
    , ([2],     Opt_StaticArgumentTransformation)

    , ([0,1,2], 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.
    ]

-- -----------------------------------------------------------------------------
-- Standard sets of warning options

standardWarnings :: [DynFlag]
standardWarnings
    = [ Opt_WarnDeprecations,
        Opt_WarnDeprecatedFlags,
        Opt_WarnOverlappingPatterns,
        Opt_WarnMissingFields,
        Opt_WarnMissingMethods,
        Opt_WarnDuplicateExports,
        Opt_WarnDodgyForeignImports
      ]

minusWOpts :: [DynFlag]
minusWOpts
    = standardWarnings ++
      [ Opt_WarnUnusedBinds,
        Opt_WarnUnusedMatches,
        Opt_WarnUnusedImports,
        Opt_WarnIncompletePatterns,
        Opt_WarnDodgyImports
      ]

minusWallOpts :: [DynFlag]
minusWallOpts
    = minusWOpts ++
      [ Opt_WarnTypeDefaults,
        Opt_WarnNameShadowing,
        Opt_WarnMissingSigs,
        Opt_WarnHiShadows,
        Opt_WarnOrphans
      ]

-- minuswRemovesOpts should be every warning option
minuswRemovesOpts :: [DynFlag]
minuswRemovesOpts
    = minusWallOpts ++
      [Opt_WarnImplicitPrelude,
       Opt_WarnIncompletePatternsRecUpd,
       Opt_WarnSimplePatterns,
       Opt_WarnMonomorphism,
       Opt_WarnTabs
      ]

-- -----------------------------------------------------------------------------
-- CoreToDo:  abstraction of core-to-core passes to run.

data CoreToDo           -- These are diff core-to-core passes,
                        -- which may be invoked in any order,
                        -- as many times as you like.

  = CoreDoSimplify      -- The core-to-core simplifier.
        SimplifierMode
        [SimplifierSwitch]
                        -- Each run of the simplifier can take a different
                        -- set of simplifier-specific flags.
  | CoreDoFloatInwards
  | CoreDoFloatOutwards FloatOutSwitches
  | CoreLiberateCase
  | CoreDoPrintCore
  | CoreDoStaticArgs
  | CoreDoStrictness
  | CoreDoWorkerWrapper
  | CoreDoSpecialising
  | CoreDoSpecConstr
  | CoreDoOldStrictness
  | CoreDoGlomBinds
  | CoreCSE
  | CoreDoRuleCheck Int{-CompilerPhase-} String -- Check for non-application of rules
                                                -- matching this string
  | CoreDoVectorisation DPHBackend
  | CoreDoNothing                -- Useful when building up
  | CoreDoPasses [CoreToDo]      -- lists of these things

data SimplifierMode             -- See comments in SimplMonad
  = SimplGently
  | SimplPhase Int [String]

data SimplifierSwitch
  = MaxSimplifierIterations Int
  | NoCaseOfCase

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


-- The core-to-core pass ordering is derived from the DynFlags:
runWhen :: Bool -> CoreToDo -> CoreToDo
runWhen True  do_this = do_this
runWhen False _       = 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
    cse           = dopt Opt_CSE dflags
    spec_constr   = dopt Opt_SpecConstr dflags
    liberate_case = dopt Opt_LiberateCase dflags
    rule_check    = ruleCheck dflags
    static_args   = dopt Opt_StaticArgumentTransformation dflags

    maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)

    simpl_phase phase names iter
      = CoreDoPasses
          [ CoreDoSimplify (SimplPhase phase names) [
              MaxSimplifierIterations iter
            ],
            maybe_rule_check phase
          ]

    vectorisation
      = runWhen (dopt Opt_Vectorise dflags)
        $ CoreDoPasses [ simpl_gently, CoreDoVectorisation (dphBackend dflags) ]


                -- 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 ["main"] max_iter
                                  | phase <- [phases, phases-1 .. 1] ]


        -- initial simplify: mk specialiser happy: minimum effort please
    simpl_gently = 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
        ]

    core_todo =
     if opt_level == 0 then
       [vectorisation,
        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 (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),

        -- We run vectorisation here for now, but we might also try to run
        -- it later
        vectorisation,

        -- initial simplify: mk specialiser happy: minimum effort please
        simpl_gently,

        -- Specialisation is best done before full laziness
        -- so that overloaded functions have all their dictionary lambdas manifest
        CoreDoSpecialising,

        runWhen full_laziness (CoreDoFloatOutwards (FloatOutSw False False)),

        CoreDoFloatInwards,

        simpl_phases,

                -- Phase 0: allow all Ids to be inlined now
                -- This gets foldr inlined before strictness analysis

                -- 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!
        simpl_phase 0 ["main"] (max max_iter 3),


#ifdef OLD_STRICTNESS
        CoreDoOldStrictness,
#endif
        runWhen strictness (CoreDoPasses [
                CoreDoStrictness,
                CoreDoWorkerWrapper,
                CoreDoGlomBinds,
                simpl_phase 0 ["post-worker-wrapper"] max_iter
                ]),

        runWhen full_laziness
          (CoreDoFloatOutwards (FloatOutSw False    -- Not lambdas
                                           True)),  -- Float constants
                -- 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)


        runWhen cse CoreCSE,
                -- 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

        CoreDoFloatInwards,

        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,
            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

        runWhen spec_constr CoreDoSpecConstr,

        maybe_rule_check 0,

        -- Final clean-up simplification:
        simpl_phase 0 ["final"] max_iter
     ]

-- -----------------------------------------------------------------------------
-- StgToDo:  abstraction of stg-to-stg passes to run.

data StgToDo
  = StgDoMassageForProfiling  -- should be (next to) last
  -- There's also setStgVarInfo, but its absolute "lastness"
  -- is so critical that it is hardwired in (no flag).
  | D_stg_stats

getStgToDo :: DynFlags -> [StgToDo]
getStgToDo dflags
  | Just todo <- stgToDo dflags = todo -- set explicitly by user
  | otherwise = todo2
  where
        stg_stats = dopt Opt_StgStats dflags

        todo1 = if stg_stats then [D_stg_stats] else []

        todo2 | WayProf `elem` wayNames dflags
              = StgDoMassageForProfiling : todo1
              | otherwise
              = todo1

-- -----------------------------------------------------------------------------
-- DynFlags parser

allFlags :: [String]
allFlags = map ('-':) $
           [ flagName flag | flag <- dynamic_flags, ok (flagOptKind flag) ] ++
           map ("fno-"++) flags ++
           map ("f"++) flags ++
           map ("X"++) supportedLanguages ++
           map ("XNo"++) supportedLanguages
    where ok (PrefixPred _ _) = False
          ok _ = True
          flags = [ name | (name, _, _) <- fFlags ]

dynamic_flags :: [Flag DynP]
dynamic_flags = [
    Flag "n"              (NoArg  (setDynFlag Opt_DryRun)) Supported
  , Flag "cpp"            (NoArg  (setDynFlag Opt_Cpp)) Supported
  , Flag "F"              (NoArg  (setDynFlag Opt_Pp)) Supported
  , Flag "#include"       (HasArg (addCmdlineHCInclude)) Supported
  , Flag "v"              (OptIntSuffix setVerbosity) Supported

        ------- Specific phases  --------------------------------------------
  , Flag "pgmL"           (HasArg (upd . setPgmL)) Supported
  , Flag "pgmP"           (HasArg (upd . setPgmP)) Supported
  , Flag "pgmF"           (HasArg (upd . setPgmF)) Supported
  , Flag "pgmc"           (HasArg (upd . setPgmc)) Supported
  , Flag "pgmm"           (HasArg (upd . setPgmm)) Supported
  , Flag "pgms"           (HasArg (upd . setPgms)) Supported
  , Flag "pgma"           (HasArg (upd . setPgma)) Supported
  , Flag "pgml"           (HasArg (upd . setPgml)) Supported
  , Flag "pgmdll"         (HasArg (upd . setPgmdll)) Supported
  , Flag "pgmwindres"     (HasArg (upd . setPgmwindres)) Supported

  , Flag "optL"           (HasArg (upd . addOptL)) Supported
  , Flag "optP"           (HasArg (upd . addOptP)) Supported
  , Flag "optF"           (HasArg (upd . addOptF)) Supported
  , Flag "optc"           (HasArg (upd . addOptc)) Supported
  , Flag "optm"           (HasArg (upd . addOptm)) Supported
  , Flag "opta"           (HasArg (upd . addOpta)) Supported
  , Flag "optl"           (HasArg (upd . addOptl)) Supported
  , Flag "optdep"         (HasArg (upd . addOptdep)) Supported
  , Flag "optwindres"     (HasArg (upd . addOptwindres)) Supported

  , Flag "split-objs"
         (NoArg (if can_split then setDynFlag Opt_SplitObjs else return ()))
         Supported

        -------- Linking ----------------------------------------------------
  , Flag "c"              (NoArg (upd $ \d -> d{ ghcLink=NoLink } ))
         Supported
  , Flag "no-link"        (NoArg (upd $ \d -> d{ ghcLink=NoLink } ))
         (Deprecated "Use -c instead")
  , Flag "shared"         (NoArg (upd $ \d -> d{ ghcLink=LinkDynLib } ))
         Supported
  , Flag "dynload"        (HasArg (upd . parseDynLibLoaderMode))
         Supported

        ------- Libraries ---------------------------------------------------
  , Flag "L"              (Prefix addLibraryPath ) Supported
  , Flag "l"              (AnySuffix (\s -> do upd (addOptl s))) Supported

        ------- Frameworks --------------------------------------------------
        -- -framework-path should really be -F ...
  , Flag "framework-path" (HasArg addFrameworkPath ) Supported
  , Flag "framework"