X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FDynFlags.hs;h=32faa8d636f61a3b39619e7241e0676ab3cec24c;hp=4aea08345a04110861d43193f5b5fe4484ebff30;hb=fa15af5162d202a8c29e9327e1ac298f2ad900e0;hpb=58916f710a0f4789925d62c5951b15ee1d11b1a1 diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 4aea083..32faa8d 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -67,7 +67,7 @@ import CmdLineParser import Constants ( mAX_CONTEXT_REDUCTION_DEPTH ) import Panic ( panic, GhcException(..) ) import UniqFM ( UniqFM ) -import Util ( notNull, splitLongestPrefix, normalisePath ) +import Util import Maybes ( orElse, fromJust ) import SrcLoc ( SrcSpan ) import Outputable @@ -166,8 +166,8 @@ data DynFlag | Opt_MonomorphismRestriction | Opt_MonoPatBinds | Opt_ExtendedDefaultRules -- Use GHC's extended rules for defaulting - | Opt_GlasgowExts - | Opt_FFI + | Opt_ForeignFunctionInterface + | Opt_UnliftedFFITypes | Opt_PArr -- Syntactic support for parallel arrays | Opt_Arrows -- Arrow-notation syntax | Opt_TH @@ -175,6 +175,7 @@ data DynFlag | Opt_Generics | Opt_ImplicitPrelude | Opt_ScopedTypeVariables + | Opt_UnboxedTuples | Opt_BangPatterns | Opt_TypeFamilies | Opt_OverloadedStrings @@ -183,6 +184,31 @@ data DynFlag | Opt_RecordPuns | Opt_GADTs | Opt_RelaxedPolyRec -- -X=RelaxedPolyRec + | Opt_StandaloneDeriving + | Opt_DeriveDataTypeable + | Opt_TypeSynonymInstances + | Opt_FlexibleContexts + | Opt_FlexibleInstances + | Opt_ConstrainedClassMethods + | Opt_MultiParamTypeClasses + | Opt_FunctionalDependencies + | Opt_UnicodeSyntax + | Opt_PolymorphicComponents + | Opt_ExistentialQuantification + | Opt_MagicHash + | Opt_EmptyDataDecls + | Opt_KindSignatures + | Opt_PatternSignatures + | Opt_ParallelListComp + | Opt_GeneralizedNewtypeDeriving + | Opt_RecursiveDo + | Opt_PatternGuards + | Opt_PartiallyAppliedClosedTypeSynonyms + | Opt_Rank2Types + | Opt_RankNTypes + | Opt_TypeOperators + + | Opt_PrintExplicitForalls -- optimisation opts | Opt_Strictness @@ -624,6 +650,16 @@ minusWallOpts Opt_WarnOrphans ] +-- minuswRemovesOpts should be every warning option +minuswRemovesOpts + = minusWallOpts ++ + [Opt_WarnImplicitPrelude, + Opt_WarnIncompletePatternsRecUpd, + Opt_WarnSimplePatterns, + Opt_WarnMonomorphism, + Opt_WarnTabs + ] + -- ----------------------------------------------------------------------------- -- CoreToDo: abstraction of core-to-core passes to run. @@ -650,6 +686,7 @@ data CoreToDo -- These are diff core-to-core passes, | CoreCSE | CoreDoRuleCheck Int{-CompilerPhase-} String -- Check for non-application of rules -- matching this string + | CoreDoVectorisation | CoreDoNothing -- Useful when building up | CoreDoPasses [CoreToDo] -- lists of these things @@ -685,6 +722,7 @@ getCoreToDo dflags spec_constr = dopt Opt_SpecConstr dflags liberate_case = dopt Opt_LiberateCase dflags rule_check = ruleCheck dflags + vectorisation = dopt Opt_Vectorise dflags core_todo = if opt_level == 0 then @@ -712,6 +750,15 @@ getCoreToDo dflags MaxSimplifierIterations max_iter ], + + -- We run vectorisation here for now, but we might also try to run + -- it later + runWhen vectorisation (CoreDoPasses [ + CoreDoVectorisation, + CoreDoSimplify SimplGently + [NoCaseOfCase, + MaxSimplifierIterations max_iter]]), + -- Specialisation is best done before full laziness -- so that overloaded functions have all their dictionary lambdas manifest CoreDoSpecialising, @@ -998,7 +1045,7 @@ dynamic_flags = [ , ( "Werror" , NoArg (setDynFlag Opt_WarnIsError) ) , ( "Wall" , NoArg (mapM_ setDynFlag minusWallOpts) ) , ( "Wnot" , NoArg (mapM_ unSetDynFlag minusWallOpts) ) /* DEPREC */ - , ( "w" , NoArg (mapM_ unSetDynFlag minusWallOpts) ) + , ( "w" , NoArg (mapM_ unSetDynFlag minuswRemovesOpts) ) ------ Optimisation flags ------------------------------------------ , ( "O" , NoArg (upd (setOptLevel 1))) @@ -1018,111 +1065,166 @@ dynamic_flags = [ ------ Compiler flags ----------------------------------------------- - , ( "fasm", NoArg (setObjTarget HscAsm) ) - , ( "fvia-c", NoArg (setObjTarget HscC) ) - , ( "fvia-C", NoArg (setObjTarget HscC) ) + , ( "fasm", NoArg (setObjTarget HscAsm) ) + , ( "fvia-c", NoArg (setObjTarget HscC) ) + , ( "fvia-C", NoArg (setObjTarget HscC) ) - , ( "fno-code", NoArg (setTarget HscNothing)) - , ( "fbyte-code", NoArg (setTarget HscInterpreted) ) - , ( "fobject-code", NoArg (setTarget defaultHscTarget) ) + , ( "fno-code", NoArg (setTarget HscNothing)) + , ( "fbyte-code", NoArg (setTarget HscInterpreted) ) + , ( "fobject-code", NoArg (setTarget defaultHscTarget) ) , ( "fglasgow-exts", NoArg (mapM_ setDynFlag glasgowExtsFlags) ) , ( "fno-glasgow-exts", NoArg (mapM_ unSetDynFlag glasgowExtsFlags) ) - -- the rest of the -f* and -fno-* flags - , ( "f", PrefixPred (isFlag fFlags) (\f -> setDynFlag (getFlag fFlags f)) ) - , ( "f", PrefixPred (isNoFlag fFlags) (\f -> unSetDynFlag (getNoFlag fFlags f)) ) - - -- For now, allow -X flags with -f; ToDo: report this as deprecated - , ( "f", PrefixPred (isFlag xFlags) (\f -> setDynFlag (getFlag xFlags f)) ) - , ( "f", PrefixPred (isNoFlag xFlags) (\f -> unSetDynFlag (getNoFlag xFlags f)) ) - - -- the rest of the -X* and -Xno-* flags - , ( "X", PrefixPred (isFlag xFlags) (\f -> setDynFlag (getFlag xFlags f)) ) - , ( "X", PrefixPred (isNoFlag xFlags) (\f -> unSetDynFlag (getNoFlag xFlags f)) ) + -- the rest of the -f* and -fno-* flags + , ( "f", PrefixPred (isFlag fFlags) + (\f -> setDynFlag (getFlag fFlags f)) ) + , ( "f", PrefixPred (isPrefFlag "no-" fFlags) + (\f -> unSetDynFlag (getPrefFlag "no-" fFlags f)) ) + + -- the -X* and -XNo* flags + , ( "X", PrefixPred (isFlag xFlags) + (\f -> setDynFlag (getFlag xFlags f)) ) + , ( "X", PrefixPred (isPrefFlag "No" xFlags) + (\f -> unSetDynFlag (getPrefFlag "No" xFlags f)) ) ] -- these -f flags can all be reversed with -fno- fFlags = [ - ( "warn-duplicate-exports", Opt_WarnDuplicateExports ), - ( "warn-hi-shadowing", Opt_WarnHiShadows ), + ( "warn-dodgy-imports", Opt_WarnDodgyImports ), + ( "warn-duplicate-exports", Opt_WarnDuplicateExports ), + ( "warn-hi-shadowing", Opt_WarnHiShadows ), ( "warn-implicit-prelude", Opt_WarnImplicitPrelude ), - ( "warn-incomplete-patterns", Opt_WarnIncompletePatterns ), - ( "warn-incomplete-record-updates", Opt_WarnIncompletePatternsRecUpd ), - ( "warn-missing-fields", Opt_WarnMissingFields ), - ( "warn-missing-methods", Opt_WarnMissingMethods ), - ( "warn-missing-signatures", Opt_WarnMissingSigs ), - ( "warn-name-shadowing", Opt_WarnNameShadowing ), - ( "warn-overlapping-patterns", Opt_WarnOverlappingPatterns ), - ( "warn-simple-patterns", Opt_WarnSimplePatterns ), - ( "warn-type-defaults", Opt_WarnTypeDefaults ), - ( "warn-monomorphism-restriction", Opt_WarnMonomorphism ), - ( "warn-unused-binds", Opt_WarnUnusedBinds ), - ( "warn-unused-imports", Opt_WarnUnusedImports ), - ( "warn-unused-matches", Opt_WarnUnusedMatches ), - ( "warn-deprecations", Opt_WarnDeprecations ), - ( "warn-orphans", Opt_WarnOrphans ), - ( "warn-tabs", Opt_WarnTabs ), - ( "strictness", Opt_Strictness ), - ( "full-laziness", Opt_FullLaziness ), - ( "liberate-case", Opt_LiberateCase ), - ( "spec-constr", Opt_SpecConstr ), - ( "cse", Opt_CSE ), - ( "ignore-interface-pragmas", Opt_IgnoreInterfacePragmas ), - ( "omit-interface-pragmas", Opt_OmitInterfacePragmas ), - ( "do-lambda-eta-expansion", Opt_DoLambdaEtaExpansion ), - ( "ignore-asserts", Opt_IgnoreAsserts ), + ( "warn-incomplete-patterns", Opt_WarnIncompletePatterns ), + ( "warn-incomplete-record-updates", Opt_WarnIncompletePatternsRecUpd ), + ( "warn-missing-fields", Opt_WarnMissingFields ), + ( "warn-missing-methods", Opt_WarnMissingMethods ), + ( "warn-missing-signatures", Opt_WarnMissingSigs ), + ( "warn-name-shadowing", Opt_WarnNameShadowing ), + ( "warn-overlapping-patterns", Opt_WarnOverlappingPatterns ), + ( "warn-simple-patterns", Opt_WarnSimplePatterns ), + ( "warn-type-defaults", Opt_WarnTypeDefaults ), + ( "warn-monomorphism-restriction", Opt_WarnMonomorphism ), + ( "warn-unused-binds", Opt_WarnUnusedBinds ), + ( "warn-unused-imports", Opt_WarnUnusedImports ), + ( "warn-unused-matches", Opt_WarnUnusedMatches ), + ( "warn-deprecations", Opt_WarnDeprecations ), + ( "warn-orphans", Opt_WarnOrphans ), + ( "warn-tabs", Opt_WarnTabs ), + ( "print-explicit-foralls", Opt_PrintExplicitForalls ), + ( "strictness", Opt_Strictness ), + ( "full-laziness", Opt_FullLaziness ), + ( "liberate-case", Opt_LiberateCase ), + ( "spec-constr", Opt_SpecConstr ), + ( "cse", Opt_CSE ), + ( "ignore-interface-pragmas", Opt_IgnoreInterfacePragmas ), + ( "omit-interface-pragmas", Opt_OmitInterfacePragmas ), + ( "do-lambda-eta-expansion", Opt_DoLambdaEtaExpansion ), + ( "ignore-asserts", Opt_IgnoreAsserts ), ( "ignore-breakpoints", Opt_IgnoreBreakpoints), - ( "do-eta-reduction", Opt_DoEtaReduction ), - ( "case-merge", Opt_CaseMerge ), - ( "unbox-strict-fields", Opt_UnboxStrictFields ), - ( "dicts-cheap", Opt_DictsCheap ), - ( "excess-precision", Opt_ExcessPrecision ), - ( "asm-mangling", Opt_DoAsmMangling ), - ( "print-bind-result", Opt_PrintBindResult ), - ( "force-recomp", Opt_ForceRecomp ), - ( "hpc-no-auto", Opt_Hpc_No_Auto ), - ( "rewrite-rules", Opt_RewriteRules ), + ( "do-eta-reduction", Opt_DoEtaReduction ), + ( "case-merge", Opt_CaseMerge ), + ( "unbox-strict-fields", Opt_UnboxStrictFields ), + ( "dicts-cheap", Opt_DictsCheap ), + ( "excess-precision", Opt_ExcessPrecision ), + ( "asm-mangling", Opt_DoAsmMangling ), + ( "print-bind-result", Opt_PrintBindResult ), + ( "force-recomp", Opt_ForceRecomp ), + ( "hpc-no-auto", Opt_Hpc_No_Auto ), + ( "rewrite-rules", Opt_RewriteRules ), ( "break-on-exception", Opt_BreakOnException ), - ( "vectorise", Opt_Vectorise ) + ( "vectorise", Opt_Vectorise ), + -- Deprecated in favour of -XTemplateHaskell: + ( "th", Opt_TH ), + -- Deprecated in favour of -XForeignFunctionInterface: + ( "fi", Opt_ForeignFunctionInterface ), + -- Deprecated in favour of -XForeignFunctionInterface: + ( "ffi", Opt_ForeignFunctionInterface ), + -- Deprecated in favour of -XArrows: + ( "arrows", Opt_Arrows ), + -- Deprecated in favour of -XGenerics: + ( "generics", Opt_Generics ), + -- Deprecated in favour of -XImplicitPrelude: + ( "implicit-prelude", Opt_ImplicitPrelude ), + -- Deprecated in favour of -XBangPatterns: + ( "bang-patterns", Opt_BangPatterns ), + -- Deprecated in favour of -XMonomorphismRestriction: + ( "monomorphism-restriction", Opt_MonomorphismRestriction ), + -- Deprecated in favour of -XMonoPatBinds: + ( "mono-pat-binds", Opt_MonoPatBinds ), + -- Deprecated in favour of -XExtendedDefaultRules: + ( "extended-default-rules", Opt_ExtendedDefaultRules ), + -- Deprecated in favour of -XImplicitParams: + ( "implicit-params", Opt_ImplicitParams ), + -- Deprecated in favour of -XScopedTypeVariables: + ( "scoped-type-variables", Opt_ScopedTypeVariables ), + -- Deprecated in favour of -XPArr: + ( "parr", Opt_PArr ), + -- Deprecated in favour of -XOverlappingInstances: + ( "AllowOverlappingInstances", Opt_AllowOverlappingInstances ), + -- Deprecated in favour of -XUndecidableInstances: + ( "AllowUndecidableInstances", Opt_AllowUndecidableInstances ), + -- Deprecated in favour of -XIncoherentInstances: + ( "AllowIncoherentInstances", Opt_AllowIncoherentInstances ) ] --- These -X flags can all be reversed with -Xno- +-- These -X flags can all be reversed with -XNo xFlags :: [(String, DynFlag)] xFlags = [ - ( "FI", Opt_FFI ), -- support `-ffi'... - ( "FFI", Opt_FFI ), -- ...and also `-fffi' - ( "ForeignFunctionInterface", Opt_FFI ), - - ( "Arrows", Opt_Arrows ), -- arrow syntax - ( "Parr", Opt_PArr ), - - ( "TH", Opt_TH ), -- support -fth - ( "TemplateHaskelll", Opt_TH ), - - ( "Generics", Opt_Generics ), - - ( "ImplicitPrelude", Opt_ImplicitPrelude ), -- On by default - - ( "RecordWildCards", Opt_RecordWildCards ), - ( "RecordPuns", Opt_RecordPuns ), - ( "DisambiguateRecordFields", Opt_DisambiguateRecordFields ), - - ( "OverloadedStrings", Opt_OverloadedStrings ), - ( "GADTs", Opt_GADTs ), - ( "TypeFamilies", Opt_TypeFamilies ), - ( "BangPatterns", Opt_BangPatterns ), - ( "MonomorphismRestriction", Opt_MonomorphismRestriction ), -- On by default - ( "MonoPatBinds", Opt_MonoPatBinds ), -- On by default (which is not strictly H98) - ( "RelaxedPolyRec", Opt_RelaxedPolyRec), - ( "ExtendedDefaultRules", Opt_ExtendedDefaultRules ), - ( "ImplicitParams", Opt_ImplicitParams ), - ( "ScopedTypeVariables", Opt_ScopedTypeVariables ), - ( "AllowOverlappingInstances", Opt_AllowOverlappingInstances ), - ( "AllowUndecidableInstances", Opt_AllowUndecidableInstances ), - ( "AllowIncoherentInstances", Opt_AllowIncoherentInstances ) + ( "CPP", Opt_Cpp ), + ( "PatternGuards", Opt_PatternGuards ), + ( "UnicodeSyntax", Opt_UnicodeSyntax ), + ( "MagicHash", Opt_MagicHash ), + ( "PolymorphicComponents", Opt_PolymorphicComponents ), + ( "ExistentialQuantification", Opt_ExistentialQuantification ), + ( "KindSignatures", Opt_KindSignatures ), + ( "PatternSignatures", Opt_PatternSignatures ), + ( "EmptyDataDecls", Opt_EmptyDataDecls ), + ( "ParallelListComp", Opt_ParallelListComp ), + ( "ForeignFunctionInterface", Opt_ForeignFunctionInterface ), + ( "UnliftedFFITypes", Opt_UnliftedFFITypes ), + ( "PartiallyAppliedClosedTypeSynonyms", + Opt_PartiallyAppliedClosedTypeSynonyms ), + ( "Rank2Types", Opt_Rank2Types ), + ( "RankNTypes", Opt_RankNTypes ), + ( "TypeOperators", Opt_TypeOperators ), + ( "RecursiveDo", Opt_RecursiveDo ), + ( "Arrows", Opt_Arrows ), + ( "PArr", Opt_PArr ), + ( "TemplateHaskell", Opt_TH ), + ( "Generics", Opt_Generics ), + -- On by default: + ( "ImplicitPrelude", Opt_ImplicitPrelude ), + ( "RecordWildCards", Opt_RecordWildCards ), + ( "RecordPuns", Opt_RecordPuns ), + ( "DisambiguateRecordFields", Opt_DisambiguateRecordFields ), + ( "OverloadedStrings", Opt_OverloadedStrings ), + ( "GADTs", Opt_GADTs ), + ( "TypeFamilies", Opt_TypeFamilies ), + ( "BangPatterns", Opt_BangPatterns ), + -- On by default: + ( "MonomorphismRestriction", Opt_MonomorphismRestriction ), + -- On by default (which is not strictly H98): + ( "MonoPatBinds", Opt_MonoPatBinds ), + ( "RelaxedPolyRec", Opt_RelaxedPolyRec), + ( "ExtendedDefaultRules", Opt_ExtendedDefaultRules ), + ( "ImplicitParams", Opt_ImplicitParams ), + ( "ScopedTypeVariables", Opt_ScopedTypeVariables ), + ( "UnboxedTuples", Opt_UnboxedTuples ), + ( "StandaloneDeriving", Opt_StandaloneDeriving ), + ( "DeriveDataTypeable", Opt_DeriveDataTypeable ), + ( "TypeSynonymInstances", Opt_TypeSynonymInstances ), + ( "FlexibleContexts", Opt_FlexibleContexts ), + ( "FlexibleInstances", Opt_FlexibleInstances ), + ( "ConstrainedClassMethods", Opt_ConstrainedClassMethods ), + ( "MultiParamTypeClasses", Opt_MultiParamTypeClasses ), + ( "FunctionalDependencies", Opt_FunctionalDependencies ), + ( "GeneralizedNewtypeDeriving", Opt_GeneralizedNewtypeDeriving ), + ( "OverlappingInstances", Opt_AllowOverlappingInstances ), + ( "UndecidableInstances", Opt_AllowUndecidableInstances ), + ( "IncoherentInstances", Opt_AllowIncoherentInstances ) ] impliedFlags :: [(DynFlag, [DynFlag])] @@ -1130,51 +1232,56 @@ impliedFlags = [ ( Opt_GADTs, [Opt_RelaxedPolyRec] ) -- We want type-sig variables to be completely rigid for GADTs ] -glasgowExtsFlags = [ Opt_GlasgowExts - , Opt_FFI +glasgowExtsFlags = [ + Opt_PrintExplicitForalls + , Opt_ForeignFunctionInterface + , Opt_UnliftedFFITypes , Opt_GADTs , Opt_ImplicitParams , Opt_ScopedTypeVariables + , Opt_UnboxedTuples + , Opt_TypeSynonymInstances + , Opt_StandaloneDeriving + , Opt_DeriveDataTypeable + , Opt_FlexibleContexts + , Opt_FlexibleInstances + , Opt_ConstrainedClassMethods + , Opt_MultiParamTypeClasses + , Opt_FunctionalDependencies + , Opt_MagicHash + , Opt_PolymorphicComponents + , Opt_ExistentialQuantification + , Opt_UnicodeSyntax + , Opt_PatternGuards + , Opt_PartiallyAppliedClosedTypeSynonyms + , Opt_RankNTypes + , Opt_TypeOperators + , Opt_RecursiveDo + , Opt_ParallelListComp + , Opt_EmptyDataDecls + , Opt_KindSignatures + , Opt_PatternSignatures + , Opt_GeneralizedNewtypeDeriving , Opt_TypeFamilies ] ------------------ -isNoFlag, isFlag :: [(String,a)] -> String -> Bool - -isFlag flags f = is_flag flags (normaliseFlag f) - -isNoFlag flags no_f - | Just f <- noFlag_maybe (normaliseFlag no_f) = is_flag flags f - | otherwise = False - -is_flag flags nf = any (\(ff,_) -> normaliseFlag ff == nf) flags - -- nf is normalised alreadly - ------------------- -getFlag, getNoFlag :: [(String,a)] -> String -> a - -getFlag flags f = get_flag flags (normaliseFlag f) - -getNoFlag flags f = get_flag flags (fromJust (noFlag_maybe (normaliseFlag f))) - -- The flag should be a no-flag already +isFlag :: [(String,a)] -> String -> Bool +isFlag flags f = any (\(ff,_) -> ff == f) flags -get_flag flags nf = case [ opt | (ff, opt) <- flags, normaliseFlag ff == nf] of - (o:os) -> o - [] -> panic ("get_flag " ++ nf) +isPrefFlag :: String -> [(String,a)] -> String -> Bool +isPrefFlag pref flags no_f + | Just f <- maybePrefixMatch pref no_f = isFlag flags f + | otherwise = False ------------------ -noFlag_maybe :: String -> Maybe String --- The input is normalised already -noFlag_maybe ('n' : 'o' : f) = Just f -noFlag_maybe other = Nothing - -normaliseFlag :: String -> String --- Normalise a option flag by --- * map to lower case --- * removing hyphens --- Thus: -X=overloaded-strings or -XOverloadedStrings -normaliseFlag [] = [] -normaliseFlag ('-':s) = normaliseFlag s -normaliseFlag (c:s) = toLower c : normaliseFlag s +getFlag :: [(String,a)] -> String -> a +getFlag flags f = case [ opt | (ff, opt) <- flags, ff == f] of + (o:os) -> o + [] -> panic ("get_flag " ++ f) + +getPrefFlag :: String -> [(String,a)] -> String -> a +getPrefFlag pref flags f = getFlag flags (fromJust (maybePrefixMatch pref f)) +-- We should only be passed flags which match the prefix -- ----------------------------------------------------------------------------- -- Parsing the dynamic flags.