X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FDynFlags.hs;h=85554cbafafbbd272243fe4ba65064cbd0308314;hp=3f5c4f1ec87f3d709cc9ed0a7b586ba7e5a52a88;hb=0cbdc7b1bd76c61ad31a14a43398ae05ce138489;hpb=27286cf2ce6733cbbf008972c6bea30ea2e562ee diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 3f5c4f1..85554cb 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -13,8 +13,13 @@ module DynFlags ( -- * Dynamic flags and associated configuration types DOpt(..), DynFlag(..), - LanguageFlag(..), + ExtensionFlag(..), + flattenExtensionFlags, + ensureFlattenedExtensionFlags, + lopt_set_flattened, + lopt_unset_flattened, DynFlags(..), + RtsOptsEnabled(..), HscTarget(..), isObjectTarget, defaultObjectTarget, GhcMode(..), isOneShot, GhcLink(..), isNoLink, @@ -41,7 +46,7 @@ module DynFlags ( parseDynamicNoPackageFlags, allFlags, - supportedLanguages, languageOptions, + supportedLanguagesAndExtensions, -- ** DynFlag C compiler options machdepCCOpts, picCCOpts, @@ -230,7 +235,6 @@ data DynFlag | Opt_EagerBlackHoling | Opt_ReadUserPackageConf | Opt_NoHsMain - | Opt_RtsOptsEnabled | Opt_SplitObjs | Opt_StgStats | Opt_HideAllPackages @@ -268,7 +272,9 @@ data DynFlag deriving (Eq, Show) -data LanguageFlag +data Language = Haskell98 | Haskell2010 + +data ExtensionFlag = Opt_Cpp | Opt_OverlappingInstances | Opt_UndecidableInstances @@ -299,6 +305,7 @@ data LanguageFlag | Opt_GADTs | Opt_RelaxedPolyRec | Opt_NPlusKPatterns + | Opt_DoAndIfThenElse | Opt_StandaloneDeriving | Opt_DeriveDataTypeable @@ -412,6 +419,7 @@ data DynFlags = DynFlags { ghcUsagePath :: FilePath, -- Filled in by SysTools ghciUsagePath :: FilePath, -- ditto rtsOpts :: Maybe String, + rtsOptsEnabled :: RtsOptsEnabled, hpcDir :: String, -- ^ Path to store the .mix files @@ -473,7 +481,9 @@ data DynFlags = DynFlags { -- hsc dynamic flags flags :: [DynFlag], - languageFlags :: [LanguageFlag], + language :: Maybe Language, + extensionFlags :: Either [OnOff ExtensionFlag] + [ExtensionFlag], -- | Message output action: use "ErrUtils" instead of this if you can log_action :: Severity -> SrcSpan -> PprStyle -> Message -> IO (), @@ -584,6 +594,8 @@ data DynLibLoader | SystemDependent deriving Eq +data RtsOptsEnabled = RtsOptsNone | RtsOptsSafeOnly | RtsOptsAll + -- | Used by 'GHC.newSession' to partially initialize a new 'DynFlags' value initDynFlags :: DynFlags -> IO DynFlags initDynFlags dflags = do @@ -654,6 +666,7 @@ defaultDynFlags = cmdlineFrameworks = [], tmpDir = cDEFAULT_TMPDIR, rtsOpts = Nothing, + rtsOptsEnabled = RtsOptsSafeOnly, hpcDir = ".hpc", @@ -725,22 +738,15 @@ defaultDynFlags = -- The default -O0 options ++ standardWarnings, - languageFlags = [ - 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_NPlusKPatterns, - Opt_DatatypeContexts - ], + language = Nothing, + extensionFlags = Left [], log_action = \severity srcSpan style msg -> case severity of - SevInfo -> printErrs (msg style) - SevFatal -> printErrs (msg style) - _ -> do + SevOutput -> printOutput (msg style) + SevInfo -> printErrs (msg style) + SevFatal -> printErrs (msg style) + _ -> do hPutChar stderr '\n' printErrs ((mkLocMessage srcSpan msg) style) -- careful (#2302): printErrs prints in UTF-8, whereas @@ -759,6 +765,59 @@ Note [Verbosity levels] 5 | "ghc -v -ddump-all" -} +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 + 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 + = Opt_MonoPatBinds -- Experimentally, I'm making this non-standard + -- behaviour the default, to see if anyone notices + -- SLPJ July 06 + : languageExtensions (Just Haskell2010) +languageExtensions (Just Haskell98) + = [Opt_ImplicitPrelude, + Opt_MonomorphismRestriction, + Opt_NPlusKPatterns, + Opt_DatatypeContexts] +languageExtensions (Just Haskell2010) + = [Opt_ImplicitPrelude, + Opt_MonomorphismRestriction, + Opt_DatatypeContexts, + Opt_EmptyDataDecls, + Opt_ForeignFunctionInterface, + Opt_PatternGuards, + Opt_DoAndIfThenElse, + Opt_RelaxedPolyRec] + -- The DOpt class is a temporary workaround, to avoid having to do -- a mass-renaming dopt->lopt at the moment class DOpt a where @@ -771,7 +830,7 @@ instance DOpt DynFlag where dopt_set = dopt_set' dopt_unset = dopt_unset' -instance DOpt LanguageFlag where +instance DOpt ExtensionFlag where dopt = lopt dopt_set = lopt_set dopt_unset = lopt_unset @@ -788,17 +847,39 @@ dopt_set' dfs f = dfs{ flags = f : flags dfs } dopt_unset' :: DynFlags -> DynFlag -> DynFlags dopt_unset' dfs f = dfs{ flags = filter (/= f) (flags dfs) } --- | Test whether a 'LanguageFlag' is set -lopt :: LanguageFlag -> DynFlags -> Bool -lopt f dflags = f `elem` languageFlags dflags - --- | Set a 'LanguageFlag' -lopt_set :: DynFlags -> LanguageFlag -> DynFlags -lopt_set dfs f = dfs{ languageFlags = f : languageFlags dfs } - --- | Unset a 'LanguageFlag' -lopt_unset :: DynFlags -> LanguageFlag -> DynFlags -lopt_unset dfs f = dfs{ languageFlags = filter (/= f) (languageFlags dfs) } +-- | Test whether a 'ExtensionFlag' is set +lopt :: ExtensionFlag -> DynFlags -> Bool +lopt f dflags = case extensionFlags dflags of + Left _ -> panic ("Testing for extension flag " ++ show f ++ " before flattening") + Right flags -> f `elem` flags + +-- | Set a 'ExtensionFlag' +lopt_set :: DynFlags -> ExtensionFlag -> DynFlags +lopt_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' +lopt_set_flattened :: DynFlags -> ExtensionFlag -> DynFlags +lopt_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) } + +-- | Unset a 'ExtensionFlag' +lopt_unset :: DynFlags -> ExtensionFlag -> DynFlags +lopt_unset dfs f = case extensionFlags dfs of + Left onoffs -> dfs { extensionFlags = Left (Off f : onoffs) } + Right _ -> panic ("Unsetting extension flag " ++ show f ++ " after flattening") + +-- | Unset a 'ExtensionFlag' +lopt_unset_flattened :: DynFlags -> ExtensionFlag -> DynFlags +lopt_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) } -- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order getOpts :: DynFlags -- ^ 'DynFlags' to retrieve the options from @@ -1056,7 +1137,7 @@ allFlags = map ('-':) $ map ("fno-"++) flags ++ map ("f"++) flags ++ map ("f"++) flags' ++ - map ("X"++) supportedLanguages + map ("X"++) supportedExtensions where ok (PrefixPred _ _) = False ok _ = True flags = [ name | (name, _, _) <- fFlags ] @@ -1065,7 +1146,7 @@ allFlags = map ('-':) $ dynamic_flags :: [Flag DynP] dynamic_flags = [ Flag "n" (NoArg (setDynFlag Opt_DryRun)) Supported - , Flag "cpp" (NoArg (setLanguageFlag Opt_Cpp)) Supported + , Flag "cpp" (NoArg (setExtensionFlag Opt_Cpp)) Supported , Flag "F" (NoArg (setDynFlag Opt_Pp)) Supported , Flag "#include" (HasArg (addCmdlineHCInclude)) (DeprecatedFullText "-#include and INCLUDE pragmas are deprecated: They no longer have any effect") @@ -1173,8 +1254,11 @@ dynamic_flags = [ , Flag "no-auto-link-packages" (NoArg (unSetDynFlag Opt_AutoLinkPackages)) Supported , Flag "no-hs-main" (NoArg (setDynFlag Opt_NoHsMain)) Supported , Flag "with-rtsopts" (HasArg setRtsOpts) Supported - , Flag "rtsopts" (NoArg (setDynFlag Opt_RtsOptsEnabled)) Supported - , Flag "no-rtsopts" (NoArg (unSetDynFlag Opt_RtsOptsEnabled)) Supported + , Flag "rtsopts" (NoArg (setRtsOptsEnabled RtsOptsAll)) Supported + , Flag "rtsopts=all" (NoArg (setRtsOptsEnabled RtsOptsAll)) Supported + , Flag "rtsopts=some" (NoArg (setRtsOptsEnabled RtsOptsSafeOnly)) Supported + , Flag "rtsopts=none" (NoArg (setRtsOptsEnabled RtsOptsNone)) Supported + , Flag "no-rtsopts" (NoArg (setRtsOptsEnabled RtsOptsNone)) Supported , Flag "main-is" (SepArg setMainIs ) Supported , Flag "haddock" (NoArg (setDynFlag Opt_Haddock)) Supported , Flag "haddock-opts" (HasArg (upd . addHaddockOpts)) Supported @@ -1468,10 +1552,11 @@ dynamic_flags = [ ] ++ map (mkFlag True "f" setDynFlag ) fFlags ++ map (mkFlag False "fno-" unSetDynFlag) fFlags - ++ map (mkFlag True "f" setLanguageFlag ) fLangFlags - ++ map (mkFlag False "fno-" unSetLanguageFlag) fLangFlags - ++ map (mkFlag True "X" setLanguageFlag ) xFlags - ++ map (mkFlag False "XNo" unSetLanguageFlag) xFlags + ++ 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 package_flags :: [Flag DynP] package_flags = [ @@ -1499,8 +1584,8 @@ mkFlag :: Bool -- ^ True <=> it should be turned on mkFlag turnOn flagPrefix f (name, flag, deprecated) = Flag (flagPrefix ++ name) (NoArg (f flag)) (deprecated turnOn) -deprecatedForLanguage :: String -> Bool -> Deprecated -deprecatedForLanguage lang turn_on +deprecatedForExtension :: String -> Bool -> Deprecated +deprecatedForExtension lang turn_on = Deprecated ("use -X" ++ flag ++ " or pragma {-# LANGUAGE " ++ flag ++ " #-} instead") where flag | turn_on = lang @@ -1593,51 +1678,60 @@ fFlags = [ ] -- | These @-f\@ flags can all be reversed with @-fno-\@ -fLangFlags :: [(String, LanguageFlag, Bool -> Deprecated)] +fLangFlags :: [(String, ExtensionFlag, Bool -> Deprecated)] fLangFlags = [ ( "th", Opt_TemplateHaskell, - deprecatedForLanguage "TemplateHaskell" ), + deprecatedForExtension "TemplateHaskell" ), ( "fi", Opt_ForeignFunctionInterface, - deprecatedForLanguage "ForeignFunctionInterface" ), + deprecatedForExtension "ForeignFunctionInterface" ), ( "ffi", Opt_ForeignFunctionInterface, - deprecatedForLanguage "ForeignFunctionInterface" ), + deprecatedForExtension "ForeignFunctionInterface" ), ( "arrows", Opt_Arrows, - deprecatedForLanguage "Arrows" ), + deprecatedForExtension "Arrows" ), ( "generics", Opt_Generics, - deprecatedForLanguage "Generics" ), + deprecatedForExtension "Generics" ), ( "implicit-prelude", Opt_ImplicitPrelude, - deprecatedForLanguage "ImplicitPrelude" ), + deprecatedForExtension "ImplicitPrelude" ), ( "bang-patterns", Opt_BangPatterns, - deprecatedForLanguage "BangPatterns" ), + deprecatedForExtension "BangPatterns" ), ( "monomorphism-restriction", Opt_MonomorphismRestriction, - deprecatedForLanguage "MonomorphismRestriction" ), + deprecatedForExtension "MonomorphismRestriction" ), ( "mono-pat-binds", Opt_MonoPatBinds, - deprecatedForLanguage "MonoPatBinds" ), + deprecatedForExtension "MonoPatBinds" ), ( "extended-default-rules", Opt_ExtendedDefaultRules, - deprecatedForLanguage "ExtendedDefaultRules" ), + deprecatedForExtension "ExtendedDefaultRules" ), ( "implicit-params", Opt_ImplicitParams, - deprecatedForLanguage "ImplicitParams" ), + deprecatedForExtension "ImplicitParams" ), ( "scoped-type-variables", Opt_ScopedTypeVariables, - deprecatedForLanguage "ScopedTypeVariables" ), + deprecatedForExtension "ScopedTypeVariables" ), ( "parr", Opt_PArr, - deprecatedForLanguage "PArr" ), + deprecatedForExtension "PArr" ), ( "allow-overlapping-instances", Opt_OverlappingInstances, - deprecatedForLanguage "OverlappingInstances" ), + deprecatedForExtension "OverlappingInstances" ), ( "allow-undecidable-instances", Opt_UndecidableInstances, - deprecatedForLanguage "UndecidableInstances" ), + deprecatedForExtension "UndecidableInstances" ), ( "allow-incoherent-instances", Opt_IncoherentInstances, - deprecatedForLanguage "IncoherentInstances" ) + deprecatedForExtension "IncoherentInstances" ) ] supportedLanguages :: [String] -supportedLanguages = [ name' | (name, _, _) <- xFlags, name' <- [name, "No" ++ name] ] +supportedLanguages = [ name | (name, _, _) <- languageFlags ] --- This may contain duplicates -languageOptions :: [LanguageFlag] -languageOptions = [ langFlag | (_, langFlag, _) <- xFlags ] +supportedExtensions :: [String] +supportedExtensions = [ name' | (name, _, _) <- xFlags, name' <- [name, "No" ++ name] ] + +supportedLanguagesAndExtensions :: [String] +supportedLanguagesAndExtensions = supportedLanguages ++ supportedExtensions + +-- | These -X flags cannot be reversed with -XNo +languageFlags :: [(String, Language, Bool -> Deprecated)] +languageFlags = [ + ( "Haskell98", Haskell98, const Supported ), + ( "Haskell2010", Haskell2010, const Supported ) + ] -- | These -X flags can all be reversed with -XNo -xFlags :: [(String, LanguageFlag, Bool -> Deprecated)] +xFlags :: [(String, ExtensionFlag, Bool -> Deprecated)] xFlags = [ ( "CPP", Opt_Cpp, const Supported ), ( "PostfixOperators", Opt_PostfixOperators, const Supported ), @@ -1661,35 +1755,31 @@ xFlags = [ const $ Deprecated "impredicative polymorphism will be simplified or removed in GHC 6.14" ), ( "TypeOperators", Opt_TypeOperators, const Supported ), ( "RecursiveDo", Opt_RecursiveDo, - deprecatedForLanguage "DoRec"), + deprecatedForExtension "DoRec"), ( "DoRec", Opt_DoRec, const Supported ), ( "Arrows", Opt_Arrows, const Supported ), ( "PArr", Opt_PArr, const Supported ), ( "TemplateHaskell", Opt_TemplateHaskell, const Supported ), ( "QuasiQuotes", Opt_QuasiQuotes, const Supported ), ( "Generics", Opt_Generics, const Supported ), - -- On by default: ( "ImplicitPrelude", Opt_ImplicitPrelude, const Supported ), ( "RecordWildCards", Opt_RecordWildCards, const Supported ), ( "NamedFieldPuns", Opt_RecordPuns, const Supported ), ( "RecordPuns", Opt_RecordPuns, - deprecatedForLanguage "NamedFieldPuns" ), + deprecatedForExtension "NamedFieldPuns" ), ( "DisambiguateRecordFields", Opt_DisambiguateRecordFields, const Supported ), ( "OverloadedStrings", Opt_OverloadedStrings, const Supported ), ( "GADTs", Opt_GADTs, const Supported ), ( "ViewPatterns", Opt_ViewPatterns, const Supported ), ( "TypeFamilies", Opt_TypeFamilies, const Supported ), ( "BangPatterns", Opt_BangPatterns, const Supported ), - -- On by default: ( "MonomorphismRestriction", Opt_MonomorphismRestriction, const Supported ), - -- On by default: ( "NPlusKPatterns", Opt_NPlusKPatterns, const Supported ), - -- On by default (which is not strictly H98): + ( "DoAndIfThenElse", Opt_DoAndIfThenElse, const Supported ), ( "MonoPatBinds", Opt_MonoPatBinds, const Supported ), ( "ExplicitForAll", Opt_ExplicitForAll, const Supported ), ( "AlternativeLayoutRule", Opt_AlternativeLayoutRule, const Supported ), ( "AlternativeLayoutRuleTransitional",Opt_AlternativeLayoutRuleTransitional, const Supported ), - -- On by default: ( "DatatypeContexts", Opt_DatatypeContexts, const Supported ), ( "MonoLocalBinds", Opt_MonoLocalBinds, const Supported ), ( "RelaxedPolyRec", Opt_RelaxedPolyRec, const Supported ), @@ -1698,7 +1788,7 @@ xFlags = [ ( "ScopedTypeVariables", Opt_ScopedTypeVariables, const Supported ), ( "PatternSignatures", Opt_ScopedTypeVariables, - deprecatedForLanguage "ScopedTypeVariables" ), + deprecatedForExtension "ScopedTypeVariables" ), ( "UnboxedTuples", Opt_UnboxedTuples, const Supported ), ( "StandaloneDeriving", Opt_StandaloneDeriving, const Supported ), @@ -1721,7 +1811,7 @@ xFlags = [ const $ Deprecated "The new qualified operator syntax was rejected by Haskell'" ) ] -impliedFlags :: [(LanguageFlag, LanguageFlag)] +impliedFlags :: [(ExtensionFlag, ExtensionFlag)] impliedFlags = [ (Opt_RankNTypes, Opt_ExplicitForAll) , (Opt_Rank2Types, Opt_ExplicitForAll) @@ -1750,13 +1840,13 @@ impliedFlags enableGlasgowExts :: DynP () enableGlasgowExts = do setDynFlag Opt_PrintExplicitForalls - mapM_ setLanguageFlag glasgowExtsFlags + mapM_ setExtensionFlag glasgowExtsFlags disableGlasgowExts :: DynP () disableGlasgowExts = do unSetDynFlag Opt_PrintExplicitForalls - mapM_ unSetLanguageFlag glasgowExtsFlags + mapM_ unSetExtensionFlag glasgowExtsFlags -glasgowExtsFlags :: [LanguageFlag] +glasgowExtsFlags :: [ExtensionFlag] glasgowExtsFlags = [ Opt_ForeignFunctionInterface , Opt_UnliftedFFITypes @@ -1865,18 +1955,22 @@ setDynFlag f = upd (\dfs -> dopt_set dfs f) unSetDynFlag f = upd (\dfs -> dopt_unset dfs f) -------------------------- -setLanguageFlag, unSetLanguageFlag :: LanguageFlag -> DynP () -setLanguageFlag f = do { upd (\dfs -> lopt_set dfs f) - ; mapM_ setLanguageFlag deps } +setLanguage :: Language -> DynP () +setLanguage l = upd (\dfs -> dfs { language = Just l }) + +-------------------------- +setExtensionFlag, unSetExtensionFlag :: ExtensionFlag -> DynP () +setExtensionFlag f = do { upd (\dfs -> lopt_set dfs f) + ; mapM_ setExtensionFlag deps } where deps = [ d | (f', d) <- impliedFlags, f' == f ] -- When you set f, set the ones it implies - -- NB: use setLanguageFlag recursively, in case the implied flags + -- 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) -unSetLanguageFlag f = upd (\dfs -> lopt_unset dfs f) +unSetExtensionFlag f = upd (\dfs -> lopt_unset dfs f) -------------------------- setDumpFlag :: DynFlag -> OptKind DynP @@ -2115,6 +2209,9 @@ setTmpDir dir dflags = dflags{ tmpDir = normalise dir } setRtsOpts :: String -> DynP () setRtsOpts arg = upd $ \ d -> d {rtsOpts = Just arg} +setRtsOptsEnabled :: RtsOptsEnabled -> DynP () +setRtsOptsEnabled arg = upd $ \ d -> d {rtsOptsEnabled = arg} + ----------------------------------------------------------------------------- -- Hpc stuff