DynFlags.hs

{-# OPTIONS -fno-warn-missing-fields #-}
-- 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
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details

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

	-- 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,
    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, fromJust )
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_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_WarnDodgyImports
   | Opt_WarnOrphans
   | Opt_WarnTabs

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

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

  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,

	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",
  haddockOptions = Nothing,
        flags = [
            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_WarnOverlappingPatterns,
	Opt_WarnMissingFields,
	Opt_WarnMissingMethods,
	Opt_WarnDuplicateExports
      ]

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
  | 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
    vectorisation = dopt Opt_Vectorise 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
          ]

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

        -- We run vectorisation here for now, but we might also try to run
        -- it later
        runWhen vectorisation (CoreDoPasses [ CoreDoVectorisation, 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 ('-':) $
           [ name | (name, optkind) <- dynamic_flags, ok optkind ] ++
           map ("fno-"++) flags ++
           map ("f"++) flags ++
           map ("X"++) xs ++
           map ("XNo"++) xs
    where ok (PrefixPred _ _) = False
          ok _ = True
          flags = map fst fFlags
          xs = map fst xFlags

dynamic_flags :: [(String, OptKind DynP)]
dynamic_flags = [
     ( "n"              , NoArg  (setDynFlag Opt_DryRun) )
  ,  ( "cpp"		, NoArg  (setDynFlag Opt_Cpp))
  ,  ( "F"		, NoArg  (setDynFlag Opt_Pp))
  ,  ( "#include"	, HasArg (addCmdlineHCInclude) )