X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FDynFlags.hs;h=6ff79243a53b1403243769322a3cc8bc8bf6a759;hp=ad68ed48eaa0d135017ad093803a4ad9ddac0e9f;hb=4564ccb752ff2dd28176ff1b567b8475fdb8b403;hpb=bf60bbfb2e76a88265c60a1e9b4f7c2dd1bbfa11 diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index ad68ed4..6ff7924 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -1,6 +1,3 @@ -{-# OPTIONS_GHC -w #-} --- Temporary, until rtsIsProfiled is fixed - -- | -- Dynamic flags -- @@ -17,16 +14,12 @@ module DynFlags ( DynFlag(..), ExtensionFlag(..), glasgowExtsFlags, - flattenExtensionFlags, - ensureFlattenedExtensionFlags, dopt, dopt_set, dopt_unset, xopt, xopt_set, xopt_unset, - xopt_set_flattened, - xopt_unset_flattened, DynFlags(..), RtsOptsEnabled(..), HscTarget(..), isObjectTarget, defaultObjectTarget, @@ -36,15 +29,24 @@ module DynFlags ( Option(..), showOpt, DynLibLoader(..), fFlags, fLangFlags, xFlags, - dphPackage, + DPHBackend(..), dphPackageMaybe, wayNames, + Settings(..), + ghcUsagePath, ghciUsagePath, topDir, tmpDir, rawSettings, + extraGccViaCFlags, systemPackageConfig, + pgm_L, pgm_P, pgm_F, pgm_c, pgm_s, pgm_a, pgm_l, pgm_dll, pgm_T, + pgm_sysman, pgm_windres, pgm_lo, pgm_lc, + opt_L, opt_P, opt_F, opt_c, opt_m, opt_a, opt_l, + opt_windres, opt_lo, opt_lc, + + -- ** Manipulating DynFlags - defaultDynFlags, -- DynFlags + defaultDynFlags, -- Settings -> DynFlags initDynFlags, -- DynFlags -> IO DynFlags getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a] - getVerbFlag, + getVerbFlags, updOptLevel, setTmpDir, setPackageName, @@ -65,7 +67,6 @@ module DynFlags ( getStgToDo, -- * Compiler configuration suitable for display to the user - Printable(..), compilerInfo #ifdef GHCI -- Only in stage 2 can we be sure that the RTS @@ -94,10 +95,14 @@ import Maybes ( orElse ) import SrcLoc import FastString import Outputable +#ifdef GHCI import Foreign.C ( CInt ) +#endif import {-# SOURCE #-} ErrUtils ( Severity(..), Message, mkLocMessage ) +#ifdef GHCI import System.IO.Unsafe ( unsafePerformIO ) +#endif import Data.IORef import Control.Monad ( when ) @@ -105,6 +110,7 @@ import Data.Char import Data.List import Data.Map (Map) import qualified Data.Map as Map +-- import Data.Maybe import System.FilePath import System.IO ( stderr, hPutChar ) @@ -116,6 +122,7 @@ data DynFlag -- debugging flags = Opt_D_dump_cmm + | Opt_D_dump_raw_cmm | Opt_D_dump_cmmz | Opt_D_dump_cmmz_pretty | Opt_D_dump_cps_cmm @@ -130,6 +137,7 @@ data DynFlag | Opt_D_dump_asm_stats | Opt_D_dump_asm_expanded | Opt_D_dump_llvm + | Opt_D_dump_core_stats | Opt_D_dump_cpranal | Opt_D_dump_deriv | Opt_D_dump_ds @@ -137,6 +145,7 @@ data DynFlag | Opt_D_dump_foreign | Opt_D_dump_inlinings | Opt_D_dump_rule_firings + | Opt_D_dump_rule_rewrites | Opt_D_dump_occur_anal | Opt_D_dump_parsed | Opt_D_dump_rn @@ -156,8 +165,10 @@ data DynFlag | Opt_D_dump_rn_stats | Opt_D_dump_opt_cmm | Opt_D_dump_simpl_stats + | Opt_D_dump_cs_trace -- Constraint solver in type checker | Opt_D_dump_tc_trace | Opt_D_dump_if_trace + | Opt_D_dump_vt_trace | Opt_D_dump_splices | Opt_D_dump_BCOs | Opt_D_dump_vect @@ -179,11 +190,18 @@ data DynFlag | Opt_DoCmmLinting | Opt_DoAsmLinting + | Opt_F_coqpass -- run the core-to-core coqPass, but don't change anything (just "parse/unparse") + | Opt_F_skolemize -- run the core-to-core coqPass, skolemizing the proof + | Opt_F_flatten -- run the core-to-core coqPass, flattening the proof + | Opt_D_dump_proofs -- dump natural deduction typing proof of the coqpass input + | Opt_D_coqpass -- run the core-to-string coqPass and dumps the result + | Opt_WarnIsError -- -Werror; makes warnings fatal | Opt_WarnDuplicateExports | Opt_WarnHiShadows | Opt_WarnImplicitPrelude | Opt_WarnIncompletePatterns + | Opt_WarnIncompleteUniPatterns | Opt_WarnIncompletePatternsRecUpd | Opt_WarnMissingFields | Opt_WarnMissingImportList @@ -203,6 +221,7 @@ data DynFlag | Opt_WarnDodgyImports | Opt_WarnOrphans | Opt_WarnAutoOrphans + | Opt_WarnIdentities | Opt_WarnTabs | Opt_WarnUnrecognisedPragmas | Opt_WarnDodgyForeignImports @@ -227,7 +246,7 @@ data DynFlag | Opt_DoEtaReduction | Opt_CaseMerge | Opt_UnboxStrictFields - | Opt_MethodSharing + | Opt_MethodSharing -- Now a no-op; remove in GHC 7.2 | Opt_DictsCheap | Opt_EnableRewriteRules -- Apply rewrite rules during simplification | Opt_Vectorise @@ -248,7 +267,6 @@ data DynFlag | Opt_Pp | Opt_ForceRecomp | Opt_DryRun - | Opt_DoAsmMangling | Opt_ExcessPrecision | Opt_EagerBlackHoling | Opt_ReadUserPackageConf @@ -271,6 +289,7 @@ data DynFlag | Opt_BuildingCabalPackage | Opt_SSE2 | Opt_GhciSandbox + | Opt_HelpfulErrors -- temporary flags | Opt_RunCPS @@ -284,7 +303,6 @@ data DynFlag | Opt_KeepHiDiffs | Opt_KeepHcFiles | Opt_KeepSFiles - | Opt_KeepRawSFiles | Opt_KeepTmpFiles | Opt_KeepRawTokenStream | Opt_KeepLlvmFiles @@ -306,8 +324,9 @@ data ExtensionFlag | Opt_ForeignFunctionInterface | Opt_UnliftedFFITypes | Opt_GHCForeignImportPrim - | Opt_PArr -- Syntactic support for parallel arrays + | Opt_ParallelArrays -- Syntactic support for parallel arrays | Opt_Arrows -- Arrow-notation syntax + | Opt_ModalTypes -- Heterogeneous Metaprogramming (modal types, brackets, escape, CSP) | Opt_TemplateHaskell | Opt_QuasiQuotes | Opt_ImplicitParams @@ -323,8 +342,10 @@ data ExtensionFlag | Opt_RecordPuns | Opt_ViewPatterns | Opt_GADTs + | Opt_GADTSyntax | Opt_NPlusKPatterns | Opt_DoAndIfThenElse + | Opt_RebindableSyntax | Opt_StandaloneDeriving | Opt_DeriveDataTypeable @@ -358,11 +379,12 @@ data ExtensionFlag | Opt_ImpredicativeTypes | Opt_TypeOperators | Opt_PackageImports - | Opt_NewQualifiedOperators | Opt_ExplicitForAll | Opt_AlternativeLayoutRule | Opt_AlternativeLayoutRuleTransitional | Opt_DatatypeContexts + | Opt_NondecreasingIndentation + | Opt_RelaxedLayout deriving (Eq, Show) -- | Contains not only a collection of 'DynFlag's but also a plethora of @@ -384,11 +406,12 @@ data DynFlags = DynFlags { specConstrThreshold :: Maybe Int, -- ^ Threshold for SpecConstr specConstrCount :: Maybe Int, -- ^ Max number of specialisations for any one function liberateCaseThreshold :: Maybe Int, -- ^ Threshold for LiberateCase + floatLamArgs :: Maybe Int, -- ^ Arg count for lambda floating + -- See CoreMonad.FloatOutSwitches #ifndef OMIT_NATIVE_CODEGEN targetPlatform :: Platform, -- ^ The platform we're compiling for. Used by the NCG. #endif - stolen_x86_regs :: Int, cmdlineHcIncludes :: [String], -- ^ @\-\#includes@ importPaths :: [FilePath], mainModIs :: Module, @@ -433,42 +456,13 @@ data DynFlags = DynFlags { libraryPaths :: [String], frameworkPaths :: [String], -- used on darwin only cmdlineFrameworks :: [String], -- ditto - tmpDir :: String, -- no trailing '/' - ghcUsagePath :: FilePath, -- Filled in by SysTools - ghciUsagePath :: FilePath, -- ditto rtsOpts :: Maybe String, rtsOptsEnabled :: RtsOptsEnabled, 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_windres :: [String], - opt_lo :: [String], -- LLVM: llvm optimiser - opt_lc :: [String], -- LLVM: llc static compiler - - -- 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, - pgm_lo :: (String,[Option]), -- LLVM: opt llvm optimiser - pgm_lc :: (String,[Option]), -- LLVM: llc static compiler + settings :: Settings, -- For ghc -M depMakefile :: FilePath, @@ -478,8 +472,6 @@ data DynFlags = DynFlags { -- 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. @@ -500,9 +492,13 @@ data DynFlags = DynFlags { -- hsc dynamic flags flags :: [DynFlag], + -- Don't change this without updating extensionFlags: language :: Maybe Language, - extensionFlags :: Either [OnOff ExtensionFlag] - [ExtensionFlag], + -- Don't change this without updating extensionFlags: + extensions :: [OnOff ExtensionFlag], + -- extensionFlags should always be equal to + -- flattenExtensionFlags language extensions + extensionFlags :: [ExtensionFlag], -- | Message output action: use "ErrUtils" instead of this if you can log_action :: Severity -> SrcSpan -> PprStyle -> Message -> IO (), @@ -510,6 +506,105 @@ data DynFlags = DynFlags { haddockOptions :: Maybe String } +data Settings = Settings { + sGhcUsagePath :: FilePath, -- Filled in by SysTools + sGhciUsagePath :: FilePath, -- ditto + sTopDir :: FilePath, + sTmpDir :: String, -- no trailing '/' + -- You shouldn't need to look things up in rawSettings directly. + -- They should have their own fields instead. + sRawSettings :: [(String, String)], + sExtraGccViaCFlags :: [String], + sSystemPackageConfig :: FilePath, + -- commands for particular phases + sPgm_L :: String, + sPgm_P :: (String,[Option]), + sPgm_F :: String, + sPgm_c :: (String,[Option]), + sPgm_s :: (String,[Option]), + sPgm_a :: (String,[Option]), + sPgm_l :: (String,[Option]), + sPgm_dll :: (String,[Option]), + sPgm_T :: String, + sPgm_sysman :: String, + sPgm_windres :: String, + sPgm_lo :: (String,[Option]), -- LLVM: opt llvm optimiser + sPgm_lc :: (String,[Option]), -- LLVM: llc static compiler + -- options for particular phases + sOpt_L :: [String], + sOpt_P :: [String], + sOpt_F :: [String], + sOpt_c :: [String], + sOpt_m :: [String], + sOpt_a :: [String], + sOpt_l :: [String], + sOpt_windres :: [String], + sOpt_lo :: [String], -- LLVM: llvm optimiser + sOpt_lc :: [String] -- LLVM: llc static compiler + + } + +ghcUsagePath :: DynFlags -> FilePath +ghcUsagePath dflags = sGhcUsagePath (settings dflags) +ghciUsagePath :: DynFlags -> FilePath +ghciUsagePath dflags = sGhciUsagePath (settings dflags) +topDir :: DynFlags -> FilePath +topDir dflags = sTopDir (settings dflags) +tmpDir :: DynFlags -> String +tmpDir dflags = sTmpDir (settings dflags) +rawSettings :: DynFlags -> [(String, String)] +rawSettings dflags = sRawSettings (settings dflags) +extraGccViaCFlags :: DynFlags -> [String] +extraGccViaCFlags dflags = sExtraGccViaCFlags (settings dflags) +systemPackageConfig :: DynFlags -> FilePath +systemPackageConfig dflags = sSystemPackageConfig (settings dflags) +pgm_L :: DynFlags -> String +pgm_L dflags = sPgm_L (settings dflags) +pgm_P :: DynFlags -> (String,[Option]) +pgm_P dflags = sPgm_P (settings dflags) +pgm_F :: DynFlags -> String +pgm_F dflags = sPgm_F (settings dflags) +pgm_c :: DynFlags -> (String,[Option]) +pgm_c dflags = sPgm_c (settings dflags) +pgm_s :: DynFlags -> (String,[Option]) +pgm_s dflags = sPgm_s (settings dflags) +pgm_a :: DynFlags -> (String,[Option]) +pgm_a dflags = sPgm_a (settings dflags) +pgm_l :: DynFlags -> (String,[Option]) +pgm_l dflags = sPgm_l (settings dflags) +pgm_dll :: DynFlags -> (String,[Option]) +pgm_dll dflags = sPgm_dll (settings dflags) +pgm_T :: DynFlags -> String +pgm_T dflags = sPgm_T (settings dflags) +pgm_sysman :: DynFlags -> String +pgm_sysman dflags = sPgm_sysman (settings dflags) +pgm_windres :: DynFlags -> String +pgm_windres dflags = sPgm_windres (settings dflags) +pgm_lo :: DynFlags -> (String,[Option]) +pgm_lo dflags = sPgm_lo (settings dflags) +pgm_lc :: DynFlags -> (String,[Option]) +pgm_lc dflags = sPgm_lc (settings dflags) +opt_L :: DynFlags -> [String] +opt_L dflags = sOpt_L (settings dflags) +opt_P :: DynFlags -> [String] +opt_P dflags = sOpt_P (settings dflags) +opt_F :: DynFlags -> [String] +opt_F dflags = sOpt_F (settings dflags) +opt_c :: DynFlags -> [String] +opt_c dflags = sOpt_c (settings dflags) +opt_m :: DynFlags -> [String] +opt_m dflags = sOpt_m (settings dflags) +opt_a :: DynFlags -> [String] +opt_a dflags = sOpt_a (settings dflags) +opt_l :: DynFlags -> [String] +opt_l dflags = sOpt_l (settings dflags) +opt_windres :: DynFlags -> [String] +opt_windres dflags = sOpt_windres (settings dflags) +opt_lo :: DynFlags -> [String] +opt_lo dflags = sOpt_lo (settings dflags) +opt_lc :: DynFlags -> [String] +opt_lc dflags = sOpt_lc (settings dflags) + wayNames :: DynFlags -> [WayName] wayNames = map wayName . ways @@ -613,6 +708,7 @@ data DynLibLoader deriving Eq data RtsOptsEnabled = RtsOptsNone | RtsOptsSafeOnly | RtsOptsAll + deriving (Show) -- | Used by 'GHC.newSession' to partially initialize a new 'DynFlags' value initDynFlags :: DynFlags -> IO DynFlags @@ -631,8 +727,8 @@ initDynFlags dflags = do -- | The normal 'DynFlags'. Note that they is not suitable for use in this form -- and must be fully initialized by 'GHC.newSession' first. -defaultDynFlags :: DynFlags -defaultDynFlags = +defaultDynFlags :: Settings -> DynFlags +defaultDynFlags mySettings = DynFlags { ghcMode = CompManager, ghcLink = LinkBinary, @@ -648,19 +744,19 @@ defaultDynFlags = specConstrThreshold = Just 200, specConstrCount = Just 3, liberateCaseThreshold = Just 200, + floatLamArgs = Just 0, -- Default: float only if no fvs strictnessBefore = [], #ifndef OMIT_NATIVE_CODEGEN targetPlatform = defaultTargetPlatform, #endif - stolen_x86_regs = 4, cmdlineHcIncludes = [], importPaths = ["."], mainModIs = mAIN, mainFunIs = Nothing, ctxtStkDepth = mAX_CONTEXT_REDUCTION_DEPTH, - dphBackend = DPHPar, + dphBackend = DPHNone, thisPackage = mainPackageId, @@ -682,25 +778,11 @@ defaultDynFlags = libraryPaths = [], frameworkPaths = [], cmdlineFrameworks = [], - tmpDir = cDEFAULT_TMPDIR, rtsOpts = Nothing, rtsOptsEnabled = RtsOptsSafeOnly, hpcDir = ".hpc", - opt_L = [], - opt_P = (if opt_PIC - then ["-D__PIC__", "-U __PIC__"] -- this list is reversed - else []), - opt_F = [], - opt_c = [], - opt_a = [], - opt_m = [], - opt_l = [], - opt_windres = [], - opt_lo = [], - opt_lc = [], - extraPkgConfs = [], packageFlags = [], pkgDatabase = Nothing, @@ -709,26 +791,7 @@ defaultDynFlags = buildTag = panic "defaultDynFlags: No buildTag", rtsBuildTag = panic "defaultDynFlags: No rtsBuildTag", splitInfo = Nothing, - -- initSysTools fills all these in - ghcUsagePath = panic "defaultDynFlags: No ghciUsagePath", - ghciUsagePath = panic "defaultDynFlags: No ghciUsagePath", - topDir = panic "defaultDynFlags: No topDir", - systemPackageConfig = panic "no systemPackageConfig: call GHC.setSessionDynFlags", - 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", - pgm_lo = panic "defaultDynFlags: No pgm_lo", - pgm_lc = panic "defaultDynFlags: No pgm_lc", - -- end of initSysTools values + settings = mySettings, -- ghc -M values depMakefile = "Makefile", depIncludePkgDeps = False, @@ -740,7 +803,8 @@ defaultDynFlags = haddockOptions = Nothing, flags = defaultFlags, language = Nothing, - extensionFlags = Left [], + extensions = [], + extensionFlags = flattenExtensionFlags Nothing [], log_action = \severity srcSpan style msg -> case severity of @@ -769,49 +833,41 @@ Note [Verbosity levels] data OnOff a = On a | Off a -flattenExtensionFlags :: DynFlags -> DynFlags -flattenExtensionFlags dflags - = case extensionFlags dflags of - Left onoffs -> - dflags { - extensionFlags = Right $ flattenExtensionFlags' (language dflags) onoffs - } - Right _ -> - panic "Flattening already-flattened extension flags" - -ensureFlattenedExtensionFlags :: DynFlags -> DynFlags -ensureFlattenedExtensionFlags dflags - = case extensionFlags dflags of - Left onoffs -> - dflags { - extensionFlags = Right $ flattenExtensionFlags' (language dflags) onoffs - } - Right _ -> - dflags - -- OnOffs accumulate in reverse order, so we use foldr in order to -- process them in the right order -flattenExtensionFlags' :: Maybe Language -> [OnOff ExtensionFlag] - -> [ExtensionFlag] -flattenExtensionFlags' ml = foldr f defaultExtensionFlags +flattenExtensionFlags :: Maybe Language -> [OnOff ExtensionFlag] + -> [ExtensionFlag] +flattenExtensionFlags ml = foldr f defaultExtensionFlags where f (On f) flags = f : delete f flags f (Off f) flags = delete f flags defaultExtensionFlags = languageExtensions ml languageExtensions :: Maybe Language -> [ExtensionFlag] + languageExtensions Nothing + -- Nothing => the default case = Opt_MonoPatBinds -- Experimentally, I'm making this non-standard -- behaviour the default, to see if anyone notices -- SLPJ July 06 -- In due course I'd like Opt_MonoLocalBinds to be on by default -- But NB it's implied by GADTs etc -- SLPJ September 2010 + : Opt_NondecreasingIndentation -- This has been on by default for some time : languageExtensions (Just Haskell2010) + languageExtensions (Just Haskell98) = [Opt_ImplicitPrelude, Opt_MonomorphismRestriction, Opt_NPlusKPatterns, - Opt_DatatypeContexts] + Opt_DatatypeContexts, + Opt_NondecreasingIndentation + -- strictly speaking non-standard, but we always had this + -- on implicitly before the option was added in 7.1, and + -- turning it off breaks code, so we're keeping it on for + -- backwards compatibility. Cabal uses -XHaskell98 by + -- default unless you specify another language. + ] + languageExtensions (Just Haskell2010) = [Opt_ImplicitPrelude, Opt_MonomorphismRestriction, @@ -836,37 +892,30 @@ dopt_unset dfs f = dfs{ flags = filter (/= f) (flags dfs) } -- | Test whether a 'ExtensionFlag' is set xopt :: ExtensionFlag -> DynFlags -> Bool -xopt f dflags = case extensionFlags dflags of - Left _ -> panic ("Testing for extension flag " ++ show f ++ " before flattening") - Right flags -> f `elem` flags +xopt f dflags = f `elem` extensionFlags dflags -- | Set a 'ExtensionFlag' xopt_set :: DynFlags -> ExtensionFlag -> DynFlags -xopt_set dfs f = case extensionFlags dfs of - Left onoffs -> dfs { extensionFlags = Left (On f : onoffs) } - Right _ -> panic ("Setting extension flag " ++ show f ++ " after flattening") - --- | Set a 'ExtensionFlag' -xopt_set_flattened :: DynFlags -> ExtensionFlag -> DynFlags -xopt_set_flattened dfs f = case extensionFlags dfs of - Left _ -> - panic ("Setting extension flag " ++ show f ++ " before flattening, but expected flattened") - Right flags -> - dfs { extensionFlags = Right (f : delete f flags) } +xopt_set dfs f + = let onoffs = On f : extensions dfs + in dfs { extensions = onoffs, + extensionFlags = flattenExtensionFlags (language dfs) onoffs } -- | Unset a 'ExtensionFlag' xopt_unset :: DynFlags -> ExtensionFlag -> DynFlags -xopt_unset dfs f = case extensionFlags dfs of - Left onoffs -> dfs { extensionFlags = Left (Off f : onoffs) } - Right _ -> panic ("Unsetting extension flag " ++ show f ++ " after flattening") +xopt_unset dfs f + = let onoffs = Off f : extensions dfs + in dfs { extensions = onoffs, + extensionFlags = flattenExtensionFlags (language dfs) onoffs } --- | Unset a 'ExtensionFlag' -xopt_unset_flattened :: DynFlags -> ExtensionFlag -> DynFlags -xopt_unset_flattened dfs f = case extensionFlags dfs of - Left _ -> - panic ("Unsetting extension flag " ++ show f ++ " before flattening, but expected flattened") - Right flags -> - dfs { extensionFlags = Right (delete f flags) } +setLanguage :: Language -> DynP () +setLanguage l = upd f + where f dfs = let mLang = Just l + oneoffs = extensions dfs + in dfs { + language = mLang, + extensionFlags = flattenExtensionFlags mLang oneoffs + } -- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order getOpts :: DynFlags -- ^ 'DynFlags' to retrieve the options from @@ -877,10 +926,10 @@ getOpts dflags opts = reverse (opts dflags) -- | Gets the verbosity flag for the current verbosity level. This is fed to -- other tools, so GHC-specific verbosity flags like @-ddump-most@ are not included -getVerbFlag :: DynFlags -> String -getVerbFlag dflags - | verbosity dflags >= 3 = "-v" - | otherwise = "" +getVerbFlags :: DynFlags -> [String] +getVerbFlags dflags + | verbosity dflags >= 4 = ["-v"] + | otherwise = [] setObjectDir, setHiDir, setStubDir, setOutputDir, setDylibInstallName, setObjectSuf, setHiSuf, setHcSuf, parseDynLibLoaderMode, @@ -894,7 +943,8 @@ 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. + -- \#included from the .hc file when compiling via C (i.e. unregisterised + -- builds). setOutputDir f = setObjectDir f . setHiDir f . setStubDir f setDylibInstallName f d = d{ dylibInstallName = Just f} @@ -915,9 +965,9 @@ 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)} -addOptl f d = d{ opt_l = f : opt_l d} -addOptP f d = d{ opt_P = f : opt_P d} +setPgmP f = let (pgm:args) = words f in alterSettings (\s -> s { sPgm_P = (pgm, map Option args)}) +addOptl f = alterSettings (\s -> s { sOpt_l = f : sOpt_l s}) +addOptP f = alterSettings (\s -> s { sOpt_P = f : sOpt_P s}) setDepMakefile :: FilePath -> DynFlags -> DynFlags @@ -1055,16 +1105,7 @@ parseDynamicFlags_ dflags0 args pkg_flags = do = runCmdLine (processArgs flag_spec args') dflags0 when (not (null errs)) $ ghcError $ errorsToGhcException errs - -- Cannot use -fPIC with registerised -fvia-C, because the mangler - -- isn't up to the job. We know that if hscTarget == HscC, then the - -- user has explicitly used -fvia-C, because -fasm is the default, - -- unless there is no NCG on this platform. The latter case is - -- checked when the -fPIC flag is parsed. - -- let (pic_warns, dflags2) - | opt_PIC && hscTarget dflags1 == HscC && cGhcUnregisterised == "NO" - = ([L noSrcSpan $ "Warning: -fvia-C is incompatible with -fPIC; ignoring -fvia-C"], - dflags1{ hscTarget = HscAsm }) #if !(x86_64_TARGET_ARCH && linux_TARGET_OS) | (not opt_Static || opt_PIC) && hscTarget dflags1 == HscLlvm = ([L noSrcSpan $ "Warning: -fllvm is incompatible with -fPIC and -" @@ -1107,30 +1148,30 @@ dynamic_flags = [ ------- Specific phases -------------------------------------------- -- need to appear before -pgmL to be parsed as LLVM flags. - , Flag "pgmlo" (hasArg (\f d -> d{ pgm_lo = (f,[])})) - , Flag "pgmlc" (hasArg (\f d -> d{ pgm_lc = (f,[])})) - , Flag "pgmL" (hasArg (\f d -> d{ pgm_L = f})) + , Flag "pgmlo" (hasArg (\f -> alterSettings (\s -> s { sPgm_lo = (f,[])}))) + , Flag "pgmlc" (hasArg (\f -> alterSettings (\s -> s { sPgm_lc = (f,[])}))) + , Flag "pgmL" (hasArg (\f -> alterSettings (\s -> s { sPgm_L = f}))) , Flag "pgmP" (hasArg setPgmP) - , Flag "pgmF" (hasArg (\f d -> d{ pgm_F = f})) - , Flag "pgmc" (hasArg (\f d -> d{ pgm_c = (f,[])})) - , Flag "pgmm" (hasArg (\f d -> d{ pgm_m = (f,[])})) - , Flag "pgms" (hasArg (\f d -> d{ pgm_s = (f,[])})) - , Flag "pgma" (hasArg (\f d -> d{ pgm_a = (f,[])})) - , Flag "pgml" (hasArg (\f d -> d{ pgm_l = (f,[])})) - , Flag "pgmdll" (hasArg (\f d -> d{ pgm_dll = (f,[])})) - , Flag "pgmwindres" (hasArg (\f d -> d{ pgm_windres = f})) + , Flag "pgmF" (hasArg (\f -> alterSettings (\s -> s { sPgm_F = f}))) + , Flag "pgmc" (hasArg (\f -> alterSettings (\s -> s { sPgm_c = (f,[])}))) + , Flag "pgmm" (HasArg (\_ -> addWarn "The -keep-raw-s-files flag does nothing; it will be removed in a future GHC release")) + , Flag "pgms" (hasArg (\f -> alterSettings (\s -> s { sPgm_s = (f,[])}))) + , Flag "pgma" (hasArg (\f -> alterSettings (\s -> s { sPgm_a = (f,[])}))) + , Flag "pgml" (hasArg (\f -> alterSettings (\s -> s { sPgm_l = (f,[])}))) + , Flag "pgmdll" (hasArg (\f -> alterSettings (\s -> s { sPgm_dll = (f,[])}))) + , Flag "pgmwindres" (hasArg (\f -> alterSettings (\s -> s { sPgm_windres = f}))) -- need to appear before -optl/-opta to be parsed as LLVM flags. - , Flag "optlo" (hasArg (\f d -> d{ opt_lo = f : opt_lo d})) - , Flag "optlc" (hasArg (\f d -> d{ opt_lc = f : opt_lc d})) - , Flag "optL" (hasArg (\f d -> d{ opt_L = f : opt_L d})) + , Flag "optlo" (hasArg (\f -> alterSettings (\s -> s { sOpt_lo = f : sOpt_lo s}))) + , Flag "optlc" (hasArg (\f -> alterSettings (\s -> s { sOpt_lc = f : sOpt_lc s}))) + , Flag "optL" (hasArg (\f -> alterSettings (\s -> s { sOpt_L = f : sOpt_L s}))) , Flag "optP" (hasArg addOptP) - , Flag "optF" (hasArg (\f d -> d{ opt_F = f : opt_F d})) - , Flag "optc" (hasArg (\f d -> d{ opt_c = f : opt_c d})) - , Flag "optm" (hasArg (\f d -> d{ opt_m = f : opt_m d})) - , Flag "opta" (hasArg (\f d -> d{ opt_a = f : opt_a d})) + , Flag "optF" (hasArg (\f -> alterSettings (\s -> s { sOpt_F = f : sOpt_F s}))) + , Flag "optc" (hasArg (\f -> alterSettings (\s -> s { sOpt_c = f : sOpt_c s}))) + , Flag "optm" (hasArg (\f -> alterSettings (\s -> s { sOpt_m = f : sOpt_m s}))) + , Flag "opta" (hasArg (\f -> alterSettings (\s -> s { sOpt_a = f : sOpt_a s}))) , Flag "optl" (hasArg addOptl) - , Flag "optwindres" (hasArg (\f d -> d{ opt_windres = f : opt_windres d})) + , Flag "optwindres" (hasArg (\f -> alterSettings (\s -> s { sOpt_windres = f : sOpt_windres s}))) , Flag "split-objs" (NoArg (if can_split @@ -1184,8 +1225,8 @@ dynamic_flags = [ , Flag "keep-hc-files" (NoArg (setDynFlag Opt_KeepHcFiles)) , Flag "keep-s-file" (NoArg (setDynFlag Opt_KeepSFiles)) , Flag "keep-s-files" (NoArg (setDynFlag Opt_KeepSFiles)) - , Flag "keep-raw-s-file" (NoArg (setDynFlag Opt_KeepRawSFiles)) - , Flag "keep-raw-s-files" (NoArg (setDynFlag Opt_KeepRawSFiles)) + , Flag "keep-raw-s-file" (NoArg (addWarn "The -keep-raw-s-file flag does nothing; it will be removed in a future GHC release")) + , Flag "keep-raw-s-files" (NoArg (addWarn "The -keep-raw-s-files flag does nothing; it will be removed in a future GHC release")) , Flag "keep-llvm-file" (NoArg (setDynFlag Opt_KeepLlvmFiles)) , Flag "keep-llvm-files" (NoArg (setDynFlag Opt_KeepLlvmFiles)) -- This only makes sense as plural @@ -1223,8 +1264,10 @@ dynamic_flags = [ , Flag "dstg-stats" (NoArg (setDynFlag Opt_StgStats)) , Flag "ddump-cmm" (setDumpFlag Opt_D_dump_cmm) + , Flag "ddump-raw-cmm" (setDumpFlag Opt_D_dump_raw_cmm) , Flag "ddump-cmmz" (setDumpFlag Opt_D_dump_cmmz) , Flag "ddump-cmmz-pretty" (setDumpFlag Opt_D_dump_cmmz_pretty) + , Flag "ddump-core-stats" (setDumpFlag Opt_D_dump_core_stats) , Flag "ddump-cps-cmm" (setDumpFlag Opt_D_dump_cps_cmm) , Flag "ddump-cvt-cmm" (setDumpFlag Opt_D_dump_cvt_cmm) , Flag "ddump-asm" (setDumpFlag Opt_D_dump_asm) @@ -1245,6 +1288,7 @@ dynamic_flags = [ , Flag "ddump-foreign" (setDumpFlag Opt_D_dump_foreign) , Flag "ddump-inlinings" (setDumpFlag Opt_D_dump_inlinings) , Flag "ddump-rule-firings" (setDumpFlag Opt_D_dump_rule_firings) + , Flag "ddump-rule-rewrites" (setDumpFlag Opt_D_dump_rule_rewrites) , Flag "ddump-occur-anal" (setDumpFlag Opt_D_dump_occur_anal) , Flag "ddump-parsed" (setDumpFlag Opt_D_dump_parsed) , Flag "ddump-rn" (setDumpFlag Opt_D_dump_rn) @@ -1262,7 +1306,9 @@ dynamic_flags = [ , Flag "ddump-worker-wrapper" (setDumpFlag Opt_D_dump_worker_wrapper) , Flag "ddump-rn-trace" (setDumpFlag Opt_D_dump_rn_trace) , Flag "ddump-if-trace" (setDumpFlag Opt_D_dump_if_trace) + , Flag "ddump-cs-trace" (setDumpFlag Opt_D_dump_cs_trace) , Flag "ddump-tc-trace" (setDumpFlag Opt_D_dump_tc_trace) + , Flag "ddump-vt-trace" (setDumpFlag Opt_D_dump_vt_trace) , Flag "ddump-splices" (setDumpFlag Opt_D_dump_splices) , Flag "ddump-rn-stats" (setDumpFlag Opt_D_dump_rn_stats) , Flag "ddump-opt-cmm" (setDumpFlag Opt_D_dump_opt_cmm) @@ -1289,11 +1335,18 @@ dynamic_flags = [ setVerbosity (Just 2))) , Flag "dfaststring-stats" (NoArg (setDynFlag Opt_D_faststring_stats)) + ------ Coq-in-GHC --------------------------- + , Flag "ddump-proofs" (NoArg (setDynFlag Opt_D_dump_proofs)) + , Flag "ddump-coqpass" (NoArg (setDynFlag Opt_D_coqpass)) + , Flag "fcoqpass" (NoArg (setDynFlag Opt_F_coqpass)) + , Flag "fflatten" (NoArg (do { setDynFlag Opt_F_coqpass ; setDynFlag Opt_F_flatten })) + , Flag "funsafe-skolemize" (NoArg (do { setDynFlag Opt_F_coqpass ; setDynFlag Opt_F_flatten ; setDynFlag Opt_F_skolemize })) + ------ Machine dependant (-m) stuff --------------------------- - , Flag "monly-2-regs" (noArg (\s -> s{stolen_x86_regs = 2})) - , Flag "monly-3-regs" (noArg (\s -> s{stolen_x86_regs = 3})) - , Flag "monly-4-regs" (noArg (\s -> s{stolen_x86_regs = 4})) + , Flag "monly-2-regs" (NoArg (addWarn "The -monly-2-regs flag does nothing; it will be removed in a future GHC release")) + , Flag "monly-3-regs" (NoArg (addWarn "The -monly-3-regs flag does nothing; it will be removed in a future GHC release")) + , Flag "monly-4-regs" (NoArg (addWarn "The -monly-4-regs flag does nothing; it will be removed in a future GHC release")) , Flag "msse2" (NoArg (setDynFlag Opt_SSE2)) ------ Warning opts ------------------------------------------------- @@ -1323,6 +1376,8 @@ dynamic_flags = [ , Flag "frule-check" (SepArg (\s -> upd (\d -> d{ ruleCheck = Just s }))) , Flag "fcontext-stack" (intSuffix (\n d -> d{ ctxtStkDepth = n })) , Flag "fstrictness-before" (intSuffix (\n d -> d{ strictnessBefore = n : strictnessBefore d })) + , Flag "ffloat-lam-args" (intSuffix (\n d -> d{ floatLamArgs = Just n })) + , Flag "ffloat-all-lams" (noArg (\d -> d{ floatLamArgs = Nothing })) ------ Profiling ---------------------------------------------------- @@ -1343,14 +1398,15 @@ dynamic_flags = [ , Flag "fdph-seq" (NoArg (setDPHBackend DPHSeq)) , Flag "fdph-par" (NoArg (setDPHBackend DPHPar)) , Flag "fdph-this" (NoArg (setDPHBackend DPHThis)) + , Flag "fdph-none" (NoArg (setDPHBackend DPHNone)) ------ Compiler flags ----------------------------------------------- , Flag "fasm" (NoArg (setObjTarget HscAsm)) - , Flag "fvia-c" (NoArg (setObjTarget HscC >> - (addWarn "The -fvia-c flag will be removed in a future GHC release"))) - , Flag "fvia-C" (NoArg (setObjTarget HscC >> - (addWarn "The -fvia-C flag will be removed in a future GHC release"))) + , Flag "fvia-c" (NoArg + (addWarn "The -fvia-c flag does nothing; it will be removed in a future GHC release")) + , Flag "fvia-C" (NoArg + (addWarn "The -fvia-C flag does nothing; it will be removed in a future GHC release")) , Flag "fllvm" (NoArg (setObjTarget HscLlvm)) , Flag "fno-code" (NoArg (do upd $ \d -> d{ ghcLink=NoLink } @@ -1360,13 +1416,13 @@ dynamic_flags = [ , Flag "fglasgow-exts" (NoArg (enableGlasgowExts >> deprecate "Use individual extensions instead")) , Flag "fno-glasgow-exts" (NoArg (disableGlasgowExts >> deprecate "Use individual extensions instead")) ] - ++ map (mkFlag True "f" setDynFlag ) fFlags - ++ map (mkFlag False "fno-" unSetDynFlag) fFlags - ++ map (mkFlag True "f" setExtensionFlag ) fLangFlags - ++ map (mkFlag False "fno-" unSetExtensionFlag) fLangFlags - ++ map (mkFlag True "X" setExtensionFlag ) xFlags - ++ map (mkFlag False "XNo" unSetExtensionFlag) xFlags - ++ map (mkFlag True "X" setLanguage) languageFlags + ++ map (mkFlag turnOn "f" setDynFlag ) fFlags + ++ map (mkFlag turnOff "fno-" unSetDynFlag) fFlags + ++ map (mkFlag turnOn "f" setExtensionFlag ) fLangFlags + ++ map (mkFlag turnOff "fno-" unSetExtensionFlag) fLangFlags + ++ map (mkFlag turnOn "X" setExtensionFlag ) xFlags + ++ map (mkFlag turnOff "XNo" unSetExtensionFlag) xFlags + ++ map (mkFlag turnOn "X" setLanguage) languageFlags package_flags :: [Flag (CmdLineP DynFlags)] package_flags = [ @@ -1383,37 +1439,39 @@ package_flags = [ ; deprecate "Use -package instead" })) ] -type FlagSpec flag - = ( String -- Flag in string form - , flag -- Flag in internal form - , Bool -> DynP ()) -- Extra action to run when the flag is found - -- Typically, emit a warning or error - -- True <=> we are turning the flag on +type TurnOnFlag = Bool -- True <=> we are turning the flag on -- False <=> we are turning the flag off +turnOn :: TurnOnFlag; turnOn = True +turnOff :: TurnOnFlag; turnOff = False +type FlagSpec flag + = ( String -- Flag in string form + , flag -- Flag in internal form + , TurnOnFlag -> DynP ()) -- Extra action to run when the flag is found + -- Typically, emit a warning or error -mkFlag :: Bool -- ^ True <=> it should be turned on +mkFlag :: TurnOnFlag -- ^ True <=> it should be turned on -> String -- ^ The flag prefix -> (flag -> DynP ()) -- ^ What to do when the flag is found -> FlagSpec flag -- ^ Specification of this particular flag -> Flag (CmdLineP DynFlags) -mkFlag turnOn flagPrefix f (name, flag, extra_action) - = Flag (flagPrefix ++ name) (NoArg (f flag >> extra_action turnOn)) +mkFlag turn_on flagPrefix f (name, flag, extra_action) + = Flag (flagPrefix ++ name) (NoArg (f flag >> extra_action turn_on)) -deprecatedForExtension :: String -> Bool -> DynP () +deprecatedForExtension :: String -> TurnOnFlag -> DynP () deprecatedForExtension lang turn_on = deprecate ("use -X" ++ flag ++ " or pragma {-# LANGUAGE " ++ flag ++ " #-} instead") where flag | turn_on = lang | otherwise = "No"++lang -useInstead :: String -> Bool -> DynP () +useInstead :: String -> TurnOnFlag -> DynP () useInstead flag turn_on = deprecate ("Use -f" ++ no ++ flag ++ " instead") where no = if turn_on then "" else "no-" -nop :: Bool -> DynP () +nop :: TurnOnFlag -> DynP () nop _ = return () -- | These @-f\@ flags can all be reversed with @-fno-\@ @@ -1426,6 +1484,7 @@ fFlags = [ ( "warn-hi-shadowing", Opt_WarnHiShadows, nop ), ( "warn-implicit-prelude", Opt_WarnImplicitPrelude, nop ), ( "warn-incomplete-patterns", Opt_WarnIncompletePatterns, nop ), + ( "warn-incomplete-uni-patterns", Opt_WarnIncompleteUniPatterns, nop ), ( "warn-incomplete-record-updates", Opt_WarnIncompletePatternsRecUpd, nop ), ( "warn-missing-fields", Opt_WarnMissingFields, nop ), ( "warn-missing-import-lists", Opt_WarnMissingImportList, nop ), @@ -1443,6 +1502,7 @@ fFlags = [ ( "warn-deprecations", Opt_WarnWarningsDeprecations, nop ), ( "warn-deprecated-flags", Opt_WarnDeprecatedFlags, nop ), ( "warn-orphans", Opt_WarnOrphans, nop ), + ( "warn-identities", Opt_WarnIdentities, nop ), ( "warn-auto-orphans", Opt_WarnAutoOrphans, nop ), ( "warn-tabs", Opt_WarnTabs, nop ), ( "warn-unrecognised-pragmas", Opt_WarnUnrecognisedPragmas, nop ), @@ -1467,11 +1527,12 @@ fFlags = [ ( "do-eta-reduction", Opt_DoEtaReduction, nop ), ( "case-merge", Opt_CaseMerge, nop ), ( "unbox-strict-fields", Opt_UnboxStrictFields, nop ), - ( "method-sharing", Opt_MethodSharing, nop ), + ( "method-sharing", Opt_MethodSharing, + \_ -> deprecate "doesn't do anything any more"), + -- Remove altogether in GHC 7.2 ( "dicts-cheap", Opt_DictsCheap, nop ), ( "excess-precision", Opt_ExcessPrecision, nop ), ( "eager-blackholing", Opt_EagerBlackHoling, nop ), - ( "asm-mangling", Opt_DoAsmMangling, nop ), ( "print-bind-result", Opt_PrintBindResult, nop ), ( "force-recomp", Opt_ForceRecomp, nop ), ( "hpc-no-auto", Opt_Hpc_No_Auto, nop ), @@ -1493,6 +1554,7 @@ fFlags = [ ( "ext-core", Opt_EmitExternalCore, nop ), ( "shared-implib", Opt_SharedImplib, nop ), ( "ghci-sandbox", Opt_GhciSandbox, nop ), + ( "helpful-errors", Opt_HelpfulErrors, nop ), ( "building-cabal-package", Opt_BuildingCabalPackage, nop ), ( "implicit-import-qualified", Opt_ImplicitImportQualified, nop ) ] @@ -1524,8 +1586,10 @@ fLangFlags = [ deprecatedForExtension "ImplicitParams" ), ( "scoped-type-variables", Opt_ScopedTypeVariables, deprecatedForExtension "ScopedTypeVariables" ), - ( "parr", Opt_PArr, - deprecatedForExtension "PArr" ), + ( "parr", Opt_ParallelArrays, + deprecatedForExtension "ParallelArrays" ), + ( "PArr", Opt_ParallelArrays, + deprecatedForExtension "ParallelArrays" ), ( "allow-overlapping-instances", Opt_OverlappingInstances, deprecatedForExtension "OverlappingInstances" ), ( "allow-undecidable-instances", Opt_UndecidableInstances, @@ -1577,7 +1641,8 @@ xFlags = [ deprecatedForExtension "DoRec"), ( "DoRec", Opt_DoRec, nop ), ( "Arrows", Opt_Arrows, nop ), - ( "PArr", Opt_PArr, nop ), + ( "ModalTypes", Opt_ModalTypes, nop ), + ( "ParallelArrays", Opt_ParallelArrays, nop ), ( "TemplateHaskell", Opt_TemplateHaskell, checkTemplateHaskellOk ), ( "QuasiQuotes", Opt_QuasiQuotes, nop ), ( "Generics", Opt_Generics, nop ), @@ -1589,17 +1654,21 @@ xFlags = [ ( "DisambiguateRecordFields", Opt_DisambiguateRecordFields, nop ), ( "OverloadedStrings", Opt_OverloadedStrings, nop ), ( "GADTs", Opt_GADTs, nop ), + ( "GADTSyntax", Opt_GADTSyntax, nop ), ( "ViewPatterns", Opt_ViewPatterns, nop ), ( "TypeFamilies", Opt_TypeFamilies, nop ), ( "BangPatterns", Opt_BangPatterns, nop ), ( "MonomorphismRestriction", Opt_MonomorphismRestriction, nop ), ( "NPlusKPatterns", Opt_NPlusKPatterns, nop ), ( "DoAndIfThenElse", Opt_DoAndIfThenElse, nop ), + ( "RebindableSyntax", Opt_RebindableSyntax, nop ), ( "MonoPatBinds", Opt_MonoPatBinds, nop ), ( "ExplicitForAll", Opt_ExplicitForAll, nop ), ( "AlternativeLayoutRule", Opt_AlternativeLayoutRule, nop ), ( "AlternativeLayoutRuleTransitional",Opt_AlternativeLayoutRuleTransitional, nop ), ( "DatatypeContexts", Opt_DatatypeContexts, nop ), + ( "NondecreasingIndentation", Opt_NondecreasingIndentation, nop ), + ( "RelaxedLayout", Opt_RelaxedLayout, nop ), ( "MonoLocalBinds", Opt_MonoLocalBinds, nop ), ( "RelaxedPolyRec", Opt_RelaxedPolyRec, \ turn_on -> if not turn_on @@ -1628,9 +1697,7 @@ xFlags = [ ( "OverlappingInstances", Opt_OverlappingInstances, nop ), ( "UndecidableInstances", Opt_UndecidableInstances, nop ), ( "IncoherentInstances", Opt_IncoherentInstances, nop ), - ( "PackageImports", Opt_PackageImports, nop ), - ( "NewQualifiedOperators", Opt_NewQualifiedOperators, - \_ -> deprecate "The new qualified operator syntax was rejected by Haskell'" ) + ( "PackageImports", Opt_PackageImports, nop ) ] defaultFlags :: [DynFlag] @@ -1638,16 +1705,17 @@ defaultFlags = [ Opt_AutoLinkPackages, Opt_ReadUserPackageConf, - Opt_MethodSharing, - - Opt_DoAsmMangling, - Opt_SharedImplib, +#if GHC_DEFAULT_NEW_CODEGEN + Opt_TryNewCodeGen, +#endif + Opt_GenManifest, Opt_EmbedManifest, Opt_PrintBindContents, - Opt_GhciSandbox + Opt_GhciSandbox, + Opt_HelpfulErrors ] ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns] @@ -1655,28 +1723,40 @@ defaultFlags ++ standardWarnings -impliedFlags :: [(ExtensionFlag, ExtensionFlag)] +impliedFlags :: [(ExtensionFlag, TurnOnFlag, ExtensionFlag)] impliedFlags - = [ (Opt_RankNTypes, Opt_ExplicitForAll) - , (Opt_Rank2Types, Opt_ExplicitForAll) - , (Opt_ScopedTypeVariables, Opt_ExplicitForAll) - , (Opt_LiberalTypeSynonyms, Opt_ExplicitForAll) - , (Opt_ExistentialQuantification, Opt_ExplicitForAll) - , (Opt_PolymorphicComponents, Opt_ExplicitForAll) - - , (Opt_GADTs, Opt_MonoLocalBinds) - , (Opt_TypeFamilies, Opt_MonoLocalBinds) - - , (Opt_TypeFamilies, Opt_KindSignatures) -- Type families use kind signatures + = [ (Opt_RankNTypes, turnOn, Opt_ExplicitForAll) + , (Opt_Rank2Types, turnOn, Opt_ExplicitForAll) + , (Opt_ScopedTypeVariables, turnOn, Opt_ExplicitForAll) + , (Opt_LiberalTypeSynonyms, turnOn, Opt_ExplicitForAll) + , (Opt_ExistentialQuantification, turnOn, Opt_ExplicitForAll) + , (Opt_PolymorphicComponents, turnOn, Opt_ExplicitForAll) + , (Opt_FlexibleInstances, turnOn, Opt_TypeSynonymInstances) + , (Opt_FunctionalDependencies, turnOn, Opt_MultiParamTypeClasses) + + , (Opt_ModalTypes, turnOn, Opt_RankNTypes) + , (Opt_ModalTypes, turnOn, Opt_ExplicitForAll) + --, (Opt_ModalTypes, turnOn, Opt_RebindableSyntax) + , (Opt_ModalTypes, turnOff, Opt_MonomorphismRestriction) + + , (Opt_RebindableSyntax, turnOff, Opt_ImplicitPrelude) -- NB: turn off! + + , (Opt_GADTs, turnOn, Opt_GADTSyntax) + , (Opt_GADTs, turnOn, Opt_MonoLocalBinds) + , (Opt_TypeFamilies, turnOn, Opt_MonoLocalBinds) + + , (Opt_TypeFamilies, turnOn, Opt_KindSignatures) -- Type families use kind signatures -- all over the place - , (Opt_ImpredicativeTypes, Opt_RankNTypes) + , (Opt_ImpredicativeTypes, turnOn, Opt_RankNTypes) -- Record wild-cards implies field disambiguation -- Otherwise if you write (C {..}) you may well get -- stuff like " 'a' not in scope ", which is a bit silly -- if the compiler has just filled in field 'a' of constructor 'C' - , (Opt_RecordWildCards, Opt_DisambiguateRecordFields) + , (Opt_RecordWildCards, turnOn, Opt_DisambiguateRecordFields) + + , (Opt_ParallelArrays, turnOn, Opt_ParallelListComp) ] optLevelFlags :: [([Int], DynFlag)] @@ -1735,6 +1815,7 @@ standardWarnings ] minusWOpts :: [DynFlag] +-- Things you get with -W minusWOpts = standardWarnings ++ [ Opt_WarnUnusedBinds, @@ -1746,6 +1827,7 @@ minusWOpts ] minusWallOpts :: [DynFlag] +-- Things you get with -Wall minusWallOpts = minusWOpts ++ [ Opt_WarnTypeDefaults, @@ -1756,17 +1838,18 @@ minusWallOpts Opt_WarnUnusedDoBind ] --- minuswRemovesOpts should be every warning option minuswRemovesOpts :: [DynFlag] +-- minuswRemovesOpts should be every warning option minuswRemovesOpts = minusWallOpts ++ - [Opt_WarnImplicitPrelude, + [Opt_WarnTabs, Opt_WarnIncompletePatternsRecUpd, + Opt_WarnIncompleteUniPatterns, Opt_WarnMonomorphism, Opt_WarnUnrecognisedPragmas, Opt_WarnAutoOrphans, - Opt_WarnTabs - ] + Opt_WarnImplicitPrelude + ] enableGlasgowExts :: DynP () enableGlasgowExts = do setDynFlag Opt_PrintExplicitForalls @@ -1816,18 +1899,20 @@ foreign import ccall unsafe "rts_isProfiled" rtsIsProfiledIO :: IO CInt rtsIsProfiled :: Bool rtsIsProfiled = unsafePerformIO rtsIsProfiledIO /= 0 +#endif checkTemplateHaskellOk :: Bool -> DynP () -checkTemplateHaskellOk turn_on +#ifdef GHCI +checkTemplateHaskellOk turn_on | turn_on && rtsIsProfiled = addErr "You can't use Template Haskell with a profiled compiler" | otherwise = return () #else --- In stage 1 we don't know that the RTS has rts_isProfiled, +-- In stage 1 we don't know that the RTS has rts_isProfiled, -- so we simply say "ok". It doesn't matter because TH isn't -- available in stage 1 anyway. -checkTemplateHaskellOk turn_on = return () +checkTemplateHaskellOk _ = return () #endif {- ********************************************************************** @@ -1868,22 +1953,24 @@ setDynFlag f = upd (\dfs -> dopt_set dfs f) unSetDynFlag f = upd (\dfs -> dopt_unset dfs f) -------------------------- -setLanguage :: Language -> DynP () -setLanguage l = upd (\dfs -> dfs { language = Just l }) - --------------------------- setExtensionFlag, unSetExtensionFlag :: ExtensionFlag -> DynP () setExtensionFlag f = do { upd (\dfs -> xopt_set dfs f) - ; mapM_ setExtensionFlag deps } + ; sequence_ deps } where - deps = [ d | (f', d) <- impliedFlags, f' == f ] + deps = [ if turn_on then setExtensionFlag d + else unSetExtensionFlag d + | (f', turn_on, d) <- impliedFlags, f' == f ] -- When you set f, set the ones it implies -- NB: use setExtensionFlag recursively, in case the implied flags -- implies further flags - -- When you un-set f, however, we don't un-set the things it implies - -- (except for -fno-glasgow-exts, which is treated specially) unSetExtensionFlag f = upd (\dfs -> xopt_unset dfs f) + -- When you un-set f, however, we don't un-set the things it implies + -- (except for -fno-glasgow-exts, which is treated specially) + +-------------------------- +alterSettings :: (Settings -> Settings) -> DynFlags -> DynFlags +alterSettings f dflags = dflags { settings = f (settings dflags) } -------------------------- setDumpFlag' :: DynFlag -> DynP () @@ -1951,8 +2038,8 @@ setTarget l = upd set | otherwise = dfs -- Changes the target only if we're compiling object code. This is --- used by -fasm and -fvia-C, which switch from one to the other, but --- not from bytecode to object-code. The idea is that -fasm/-fvia-C +-- used by -fasm and -fllvm, which switch from one to the other, but +-- not from bytecode to object-code. The idea is that -fasm/-fllvm -- can be safely used in an OPTIONS_GHC pragma. setObjTarget :: HscTarget -> DynP () setObjTarget l = upd set @@ -1974,45 +2061,36 @@ setOptLevel n dflags -- -Odph is equivalent to -- -- -O2 optimise as much as possible --- -fno-method-sharing sharing specialisation defeats fusion --- sometimes --- -fdicts-cheap always inline dictionaries -- -fmax-simplifier-iterations20 this is necessary sometimes --- -fsimplifier-phases=3 we use an additional simplifier phase --- for fusion --- -fno-spec-constr-threshold run SpecConstr even for big loops --- -fno-spec-constr-count SpecConstr as much as possible --- -finline-enough-args hack to prevent excessive inlining +-- -fsimplifier-phases=3 we use an additional simplifier phase for fusion -- setDPHOpt :: DynFlags -> DynFlags setDPHOpt dflags = setOptLevel 2 (dflags { maxSimplIterations = 20 , simplPhases = 3 - , specConstrThreshold = Nothing - , specConstrCount = Nothing }) - `dopt_set` Opt_DictsCheap - `dopt_unset` Opt_MethodSharing -data DPHBackend = DPHPar - | DPHSeq - | DPHThis +-- Determines the package used by the vectoriser for the symbols of the vectorised code. +-- 'DPHNone' indicates that no data-parallel backend library is available; hence, the +-- vectoriser cannot be used. +-- +data DPHBackend = DPHPar -- "dph-par" + | DPHSeq -- "dph-seq" + | DPHThis -- the currently compiled package + | DPHNone -- no DPH library available deriving(Eq, Ord, Enum, Show) setDPHBackend :: DPHBackend -> DynP () -setDPHBackend backend - = do - upd $ \dflags -> dflags { dphBackend = backend } - mapM_ exposePackage (dph_packages backend) - where - dph_packages DPHThis = [] - dph_packages DPHPar = ["dph-prim-par", "dph-par"] - dph_packages DPHSeq = ["dph-prim-seq", "dph-seq"] +setDPHBackend backend = upd $ \dflags -> dflags { dphBackend = backend } -dphPackage :: DynFlags -> PackageId -dphPackage dflags = case dphBackend dflags of - DPHPar -> dphParPackageId - DPHSeq -> dphSeqPackageId - DPHThis -> thisPackage dflags +-- Query the DPH backend package to be used by the vectoriser and desugaring of DPH syntax. +-- +dphPackageMaybe :: DynFlags -> Maybe PackageId +dphPackageMaybe dflags + = case dphBackend dflags of + DPHPar -> Just dphParPackageId + DPHSeq -> Just dphSeqPackageId + DPHThis -> Just (thisPackage dflags) + DPHNone -> Nothing setMainIs :: String -> DynP () setMainIs arg @@ -2109,7 +2187,7 @@ splitPathList s = filter notNull (splitUp s) -- tmpDir, where we store temporary files. setTmpDir :: FilePath -> DynFlags -> DynFlags -setTmpDir dir dflags = dflags{ tmpDir = normalise dir } +setTmpDir dir = alterSettings (\s -> s { sTmpDir = normalise dir }) -- we used to fix /cygdrive/c/.. on Windows, but this doesn't -- seem necessary now --SDM 7/2/2008 @@ -2134,29 +2212,25 @@ setOptHpcDir arg = upd $ \ d -> d{hpcDir = arg} -- There are some options that we need to pass to gcc when compiling -- Haskell code via C, but are only supported by recent versions of -- gcc. The configure script decides which of these options we need, --- and puts them in the file "extra-gcc-opts" in $topdir, which is --- read before each via-C compilation. The advantage of having these --- in a separate file is that the file can be created at install-time --- depending on the available gcc version, and even re-generated later --- if gcc is upgraded. +-- and puts them in the "settings" file in $topdir. The advantage of +-- having these in a separate file is that the file can be created at +-- install-time depending on the available gcc version, and even +-- re-generated later if gcc is upgraded. -- -- The options below are not dependent on the version of gcc, only the -- platform. -machdepCCOpts :: DynFlags -> ([String], -- flags for all C compilations - [String]) -- for registerised HC compilations -machdepCCOpts dflags = let (flagsAll, flagsRegHc) = machdepCCOpts' dflags - in (cCcOpts ++ flagsAll, flagsRegHc) +machdepCCOpts :: DynFlags -> [String] -- flags for all C compilations +machdepCCOpts _ = cCcOpts ++ machdepCCOpts' -machdepCCOpts' :: DynFlags -> ([String], -- flags for all C compilations - [String]) -- for registerised HC compilations -machdepCCOpts' _dflags +machdepCCOpts' :: [String] -- flags for all C compilations +machdepCCOpts' #if alpha_TARGET_ARCH - = ( ["-w", "-mieee" + = ["-w", "-mieee" #ifdef HAVE_THREADED_RTS_SUPPORT , "-D_REENTRANT" #endif - ], [] ) + ] -- For now, to suppress the gcc warning "call-clobbered -- register used for global register variable", we simply -- disable all warnings altogether using the -w flag. Oh well. @@ -2164,71 +2238,17 @@ machdepCCOpts' _dflags #elif hppa_TARGET_ARCH -- ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi! -- (very nice, but too bad the HP /usr/include files don't agree.) - = ( ["-D_HPUX_SOURCE"], [] ) - -#elif m68k_TARGET_ARCH - -- -fno-defer-pop : for the .hc files, we want all the pushing/ - -- popping of args to routines to be explicit; if we let things - -- be deferred 'til after an STGJUMP, imminent death is certain! - -- - -- -fomit-frame-pointer : *don't* - -- It's better to have a6 completely tied up being a frame pointer - -- rather than let GCC pick random things to do with it. - -- (If we want to steal a6, then we would try to do things - -- as on iX86, where we *do* steal the frame pointer [%ebp].) - = ( [], ["-fno-defer-pop", "-fno-omit-frame-pointer"] ) + = ["-D_HPUX_SOURCE"] #elif i386_TARGET_ARCH -- -fno-defer-pop : basically the same game as for m68k -- -- -fomit-frame-pointer : *must* in .hc files; because we're stealing -- the fp (%ebp) for our register maps. - = let n_regs = stolen_x86_regs _dflags - in - ( - [ if opt_Static then "-DDONT_WANT_WIN32_DLL_SUPPORT" else "" - ], - [ "-fno-defer-pop", - "-fomit-frame-pointer", - -- we want -fno-builtin, because when gcc inlines - -- built-in functions like memcpy() it tends to - -- run out of registers, requiring -monly-n-regs - "-fno-builtin", - "-DSTOLEN_X86_REGS="++show n_regs ] - ) - -#elif ia64_TARGET_ARCH - = ( [], ["-fomit-frame-pointer", "-G0"] ) - -#elif x86_64_TARGET_ARCH - = ( - [], - ["-fomit-frame-pointer", - "-fno-asynchronous-unwind-tables", - -- the unwind tables are unnecessary for HC code, - -- and get in the way of -split-objs. Another option - -- would be to throw them away in the mangler, but this - -- is easier. - "-fno-builtin" - -- calling builtins like strlen() using the FFI can - -- cause gcc to run out of regs, so use the external - -- version. - ] ) - -#elif sparc_TARGET_ARCH - = ( [], ["-w"] ) - -- For now, to suppress the gcc warning "call-clobbered - -- register used for global register variable", we simply - -- disable all warnings altogether using the -w flag. Oh well. + = if opt_Static then ["-DDONT_WANT_WIN32_DLL_SUPPORT"] else [] -#elif powerpc_apple_darwin_TARGET - -- -no-cpp-precomp: - -- Disable Apple's precompiling preprocessor. It's a great thing - -- for "normal" programs, but it doesn't support register variable - -- declarations. - = ( [], ["-no-cpp-precomp"] ) #else - = ( [], [] ) + = [] #endif picCCOpts :: DynFlags -> [String] @@ -2268,34 +2288,40 @@ picCCOpts _dflags -- Splitting can_split :: Bool -can_split = cSplitObjs == "YES" +can_split = cSupportsSplitObjs == "YES" -- ----------------------------------------------------------------------------- -- Compiler Info -data Printable = String String - | FromDynFlags (DynFlags -> String) - -compilerInfo :: [(String, Printable)] -compilerInfo = [("Project name", String cProjectName), - ("Project version", String cProjectVersion), - ("Booter version", String cBooterVersion), - ("Stage", String cStage), - ("Build platform", String cBuildPlatform), - ("Host platform", String cHostPlatform), - ("Target platform", String cTargetPlatform), - ("Have interpreter", String cGhcWithInterpreter), - ("Object splitting", String cSplitObjs), - ("Have native code generator", String cGhcWithNativeCodeGen), - ("Have llvm code generator", String cGhcWithLlvmCodeGen), - ("Use archives for ghci", String (show cUseArchivesForGhci)), - ("Support SMP", String cGhcWithSMP), - ("Unregisterised", String cGhcUnregisterised), - ("Tables next to code", String cGhcEnableTablesNextToCode), - ("RTS ways", String cGhcRTSWays), - ("Leading underscore", String cLeadingUnderscore), - ("Debug on", String (show debugIsOn)), - ("LibDir", FromDynFlags topDir), - ("Global Package DB", FromDynFlags systemPackageConfig) - ] +compilerInfo :: DynFlags -> [(String, String)] +compilerInfo dflags + = -- We always make "Project name" be first to keep parsing in + -- other languages simple, i.e. when looking for other fields, + -- you don't have to worry whether there is a leading '[' or not + ("Project name", cProjectName) + -- Next come the settings, so anything else can be overridden + -- in the settings file (as "lookup" uses the first match for the + -- key) + : rawSettings dflags + ++ [("Project version", cProjectVersion), + ("Booter version", cBooterVersion), + ("Stage", cStage), + ("Build platform", cBuildPlatformString), + ("Host platform", cHostPlatformString), + ("Target platform", cTargetPlatformString), + ("Have interpreter", cGhcWithInterpreter), + ("Object splitting supported", cSupportsSplitObjs), + ("Have native code generator", cGhcWithNativeCodeGen), + ("Support SMP", cGhcWithSMP), + ("Unregisterised", cGhcUnregisterised), + ("Tables next to code", cGhcEnableTablesNextToCode), + ("RTS ways", cGhcRTSWays), + ("Leading underscore", cLeadingUnderscore), + ("Debug on", show debugIsOn), + ("LibDir", topDir dflags), + ("Global Package DB", systemPackageConfig dflags), + ("C compiler flags", show cCcOpts), + ("Gcc Linker flags", show cGccLinkerOpts), + ("Ld Linker flags", show cLdLinkerOpts) + ]