X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FDynFlags.hs;h=412b472101dba85f4d793e0977547d49984cb99f;hp=513c97faf7ee2db97e9d53a74a58ca86ec41f11d;hb=d2f11ea842a25bebd51d6c0c730a756c1d987e25;hpb=0656c72a8f4fda30c348bdf40449d105e4ce00ce diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 513c97f..412b472 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -133,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 @@ -303,7 +304,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 @@ -356,11 +357,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 @@ -382,6 +384,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. @@ -650,6 +654,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 @@ -791,6 +796,8 @@ languageExtensions Nothing -- 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 + : Opt_RelaxedLayout -- This has been on by default for some time : languageExtensions (Just Haskell2010) languageExtensions (Just Haskell98) @@ -1225,6 +1232,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) @@ -1303,6 +1311,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 ---------------------------------------------------- @@ -1340,13 +1350,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 = [ @@ -1363,37 +1373,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-\@ @@ -1507,8 +1519,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, @@ -1560,7 +1574,7 @@ xFlags = [ 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 ), @@ -1584,6 +1598,8 @@ xFlags = [ ( "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 @@ -1612,9 +1628,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] @@ -1637,30 +1651,30 @@ 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_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_RebindableSyntax, Opt_ImplicitPrelude) + , (Opt_RebindableSyntax, turnOff, Opt_ImplicitPrelude) -- NB: turn off! - , (Opt_GADTs, Opt_MonoLocalBinds) - , (Opt_TypeFamilies, Opt_MonoLocalBinds) + , (Opt_GADTs, turnOn, Opt_MonoLocalBinds) + , (Opt_TypeFamilies, turnOn, Opt_MonoLocalBinds) - , (Opt_TypeFamilies, Opt_KindSignatures) -- Type families use kind signatures + , (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) ] optLevelFlags :: [([Int], DynFlag)] @@ -1855,16 +1869,18 @@ unSetDynFlag f = upd (\dfs -> dopt_unset dfs f) -------------------------- 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 () @@ -2268,7 +2284,6 @@ compilerInfo = [("Project name", String cProjectName), ("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),