X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FDynFlags.hs;h=7bd4d84b379644f6564c17059da34085d6aa6ba8;hp=6af63fe99215681ed893bd6446b9eb45871cabdd;hb=50d0293555691012f96259de7f8682b94db58517;hpb=3785918d9bdbd4e611ffc6da198c36b5797b8c77 diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 6af63fe..7bd4d84 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -17,16 +17,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,7 +32,7 @@ module DynFlags ( Option(..), showOpt, DynLibLoader(..), fFlags, fLangFlags, xFlags, - dphPackage, + DPHBackend(..), dphPackage, wayNames, -- ** Manipulating DynFlags @@ -137,6 +133,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,6 +153,7 @@ 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_splices @@ -184,6 +182,7 @@ data DynFlag | Opt_WarnHiShadows | Opt_WarnImplicitPrelude | Opt_WarnIncompletePatterns + | Opt_WarnIncompleteUniPatterns | Opt_WarnIncompletePatternsRecUpd | Opt_WarnMissingFields | Opt_WarnMissingImportList @@ -192,7 +191,6 @@ data DynFlag | Opt_WarnMissingLocalSigs | Opt_WarnNameShadowing | Opt_WarnOverlappingPatterns - | Opt_WarnSimplePatterns | Opt_WarnTypeDefaults | Opt_WarnMonomorphism | Opt_WarnUnusedBinds @@ -203,6 +201,8 @@ data DynFlag | Opt_WarnDodgyExports | Opt_WarnDodgyImports | Opt_WarnOrphans + | Opt_WarnAutoOrphans + | Opt_WarnIdentities | Opt_WarnTabs | Opt_WarnUnrecognisedPragmas | Opt_WarnDodgyForeignImports @@ -227,7 +227,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 @@ -270,6 +270,8 @@ data DynFlag | Opt_SharedImplib | Opt_BuildingCabalPackage | Opt_SSE2 + | Opt_GhciSandbox + | Opt_HelpfulErrors -- temporary flags | Opt_RunCPS @@ -305,7 +307,7 @@ 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_TemplateHaskell | Opt_QuasiQuotes @@ -322,8 +324,10 @@ data ExtensionFlag | Opt_RecordPuns | Opt_ViewPatterns | Opt_GADTs + | Opt_GADTSyntax | Opt_NPlusKPatterns | Opt_DoAndIfThenElse + | Opt_RebindableSyntax | Opt_StandaloneDeriving | Opt_DeriveDataTypeable @@ -357,11 +361,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 @@ -383,6 +388,8 @@ 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. @@ -499,9 +506,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 (), @@ -647,6 +658,7 @@ defaultDynFlags = specConstrThreshold = Just 200, specConstrCount = Just 3, liberateCaseThreshold = Just 200, + floatLamArgs = Just 0, -- Default: float only if no fvs strictnessBefore = [], #ifndef OMIT_NATIVE_CODEGEN @@ -659,7 +671,7 @@ defaultDynFlags = mainFunIs = Nothing, ctxtStkDepth = mAX_CONTEXT_REDUCTION_DEPTH, - dphBackend = DPHPar, + dphBackend = DPHNone, thisPackage = mainPackageId, @@ -739,7 +751,8 @@ defaultDynFlags = haddockOptions = Nothing, flags = defaultFlags, language = Nothing, - extensionFlags = Left [], + extensions = [], + extensionFlags = flattenExtensionFlags Nothing [], log_action = \severity srcSpan style msg -> case severity of @@ -768,48 +781,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, @@ -834,37 +840,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 @@ -1243,6 +1242,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) @@ -1260,6 +1260,7 @@ 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-splices" (setDumpFlag Opt_D_dump_splices) , Flag "ddump-rn-stats" (setDumpFlag Opt_D_dump_rn_stats) @@ -1321,6 +1322,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" (intSuffix (\n d -> d{ floatLamArgs = Nothing })) ------ Profiling ---------------------------------------------------- @@ -1341,6 +1344,7 @@ 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 ----------------------------------------------- @@ -1355,16 +1359,16 @@ dynamic_flags = [ setTarget HscNothing)) , Flag "fbyte-code" (NoArg (setTarget HscInterpreted)) , Flag "fobject-code" (NoArg (setTarget defaultHscTarget)) - , Flag "fglasgow-exts" (NoArg enableGlasgowExts) - , Flag "fno-glasgow-exts" (NoArg disableGlasgowExts) + , 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 = [ @@ -1381,37 +1385,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-\@ @@ -1424,6 +1430,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 ), @@ -1432,7 +1439,6 @@ fFlags = [ ( "warn-missing-local-sigs", Opt_WarnMissingLocalSigs, nop ), ( "warn-name-shadowing", Opt_WarnNameShadowing, nop ), ( "warn-overlapping-patterns", Opt_WarnOverlappingPatterns, nop ), - ( "warn-simple-patterns", Opt_WarnSimplePatterns, nop ), ( "warn-type-defaults", Opt_WarnTypeDefaults, nop ), ( "warn-monomorphism-restriction", Opt_WarnMonomorphism, nop ), ( "warn-unused-binds", Opt_WarnUnusedBinds, nop ), @@ -1442,6 +1448,8 @@ 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 ), ( "warn-lazy-unlifted-bindings", Opt_WarnLazyUnliftedBindings, nop), @@ -1465,7 +1473,9 @@ 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 ), @@ -1490,6 +1500,8 @@ fFlags = [ ( "embed-manifest", Opt_EmbedManifest, nop ), ( "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 ) ] @@ -1521,8 +1533,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, @@ -1568,14 +1582,13 @@ xFlags = [ ( "LiberalTypeSynonyms", Opt_LiberalTypeSynonyms, nop ), ( "Rank2Types", Opt_Rank2Types, nop ), ( "RankNTypes", Opt_RankNTypes, nop ), - ( "ImpredicativeTypes", Opt_ImpredicativeTypes, - \_ -> deprecate "impredicative polymorphism will be simplified or removed in GHC 6.14" ), + ( "ImpredicativeTypes", Opt_ImpredicativeTypes, nop), ( "TypeOperators", Opt_TypeOperators, nop ), ( "RecursiveDo", Opt_RecursiveDo, deprecatedForExtension "DoRec"), ( "DoRec", Opt_DoRec, nop ), ( "Arrows", Opt_Arrows, nop ), - ( "PArr", Opt_PArr, nop ), + ( "ParallelArrays", Opt_ParallelArrays, nop ), ( "TemplateHaskell", Opt_TemplateHaskell, checkTemplateHaskellOk ), ( "QuasiQuotes", Opt_QuasiQuotes, nop ), ( "Generics", Opt_Generics, nop ), @@ -1587,17 +1600,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 @@ -1626,9 +1643,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] @@ -1636,15 +1651,15 @@ defaultFlags = [ Opt_AutoLinkPackages, Opt_ReadUserPackageConf, - Opt_MethodSharing, - Opt_DoAsmMangling, Opt_SharedImplib, Opt_GenManifest, Opt_EmbedManifest, - Opt_PrintBindContents + Opt_PrintBindContents, + Opt_GhciSandbox, + Opt_HelpfulErrors ] ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns] @@ -1652,29 +1667,34 @@ 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_FunctionalDependencies, 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_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)] @@ -1733,6 +1753,7 @@ standardWarnings ] minusWOpts :: [DynFlag] +-- Things you get with -W minusWOpts = standardWarnings ++ [ Opt_WarnUnusedBinds, @@ -1744,6 +1765,7 @@ minusWOpts ] minusWallOpts :: [DynFlag] +-- Things you get with -Wall minusWallOpts = minusWOpts ++ [ Opt_WarnTypeDefaults, @@ -1754,17 +1776,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_WarnSimplePatterns, + Opt_WarnIncompleteUniPatterns, Opt_WarnMonomorphism, Opt_WarnUnrecognisedPragmas, - Opt_WarnTabs - ] + Opt_WarnAutoOrphans, + Opt_WarnImplicitPrelude + ] enableGlasgowExts :: DynP () enableGlasgowExts = do setDynFlag Opt_PrintExplicitForalls @@ -1778,7 +1801,6 @@ glasgowExtsFlags :: [ExtensionFlag] glasgowExtsFlags = [ Opt_ForeignFunctionInterface , Opt_UnliftedFFITypes - , Opt_GADTs , Opt_ImplicitParams , Opt_ScopedTypeVariables , Opt_UnboxedTuples @@ -1806,8 +1828,7 @@ glasgowExtsFlags = [ , Opt_ParallelListComp , Opt_EmptyDataDecls , Opt_KindSignatures - , Opt_GeneralizedNewtypeDeriving - , Opt_TypeFamilies ] + , Opt_GeneralizedNewtypeDeriving ] #ifdef GHCI -- Consult the RTS to find whether GHC itself has been built profiled @@ -1868,22 +1889,20 @@ 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) -------------------------- setDumpFlag' :: DynFlag -> DynP () @@ -1974,45 +1993,39 @@ 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 } +-- Query the DPH backend package to be used by the vectoriser. +-- dphPackage :: DynFlags -> PackageId -dphPackage dflags = case dphBackend dflags of - DPHPar -> dphParPackageId - DPHSeq -> dphSeqPackageId - DPHThis -> thisPackage dflags +dphPackage dflags + = case dphBackend dflags of + DPHPar -> dphParPackageId + DPHSeq -> dphSeqPackageId + DPHThis -> thisPackage dflags + DPHNone -> ghcError (CmdLineError dphBackendError) + +dphBackendError :: String +dphBackendError = "To use -fvectorise select a DPH backend with -fdph-par or -fdph-seq" setMainIs :: String -> DynP () setMainIs arg @@ -2281,14 +2294,12 @@ 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), + ("Build platform", String cBuildPlatformString), + ("Host platform", String cHostPlatformString), + ("Target platform", String cTargetPlatformString), ("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), @@ -2296,6 +2307,9 @@ compilerInfo = [("Project name", String cProjectName), ("Leading underscore", String cLeadingUnderscore), ("Debug on", String (show debugIsOn)), ("LibDir", FromDynFlags topDir), - ("Global Package DB", FromDynFlags systemPackageConfig) + ("Global Package DB", FromDynFlags systemPackageConfig), + ("C compiler flags", String (show cCcOpts)), + ("Gcc Linker flags", String (show cGccLinkerOpts)), + ("Ld Linker flags", String (show cLdLinkerOpts)) ]