X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FDynFlags.hs;h=cda06e5f4c9f444cc929b4882f84a8c9f87d0be0;hp=872f13b4b04935a1815ce933f6d4fdce80c3f13a;hb=7d52c74cab50d3c9a5e76be5b97d63b60069bc2e;hpb=b0e7c6f2d78e856761944c27755b442e36ead60f diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 872f13b..cda06e5 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -68,7 +68,7 @@ import Constants ( mAX_CONTEXT_REDUCTION_DEPTH ) import Panic ( panic, GhcException(..) ) import UniqFM ( UniqFM ) import Util ( notNull, splitLongestPrefix, normalisePath ) -import Maybes ( fromJust, orElse ) +import Maybes ( orElse, fromJust ) import SrcLoc ( SrcSpan ) import Outputable import {-# SOURCE #-} ErrUtils ( Severity(..), Message, mkLocMessage ) @@ -82,7 +82,7 @@ import Data.List ( isPrefixOf ) import Util ( split ) #endif -import Data.Char ( isUpper ) +import Data.Char ( isUpper, toLower ) import System.IO ( hPutStrLn, stderr ) -- ----------------------------------------------------------------------------- @@ -92,6 +92,7 @@ data DynFlag -- debugging flags = Opt_D_dump_cmm + | Opt_D_dump_cps_cmm | Opt_D_dump_asm | Opt_D_dump_cpranal | Opt_D_dump_deriv @@ -177,6 +178,22 @@ data DynFlag | Opt_BangPatterns | Opt_TypeFamilies | Opt_OverloadedStrings + | Opt_DisambiguateRecordFields + | Opt_RecordWildCards + | Opt_RecordPuns + | Opt_GADTs + | Opt_RelaxedPolyRec -- -X=RelaxedPolyRec + | Opt_TypeSynonymInstances + | Opt_FlexibleInstances + | Opt_MultiParamTypeClasses + | Opt_FunctionalDependencies + | Opt_MagicHash + | Opt_EmptyDataDecls + | Opt_KindSignatures + | Opt_ParallelListComp + | Opt_GeneralizedNewtypeDeriving + | Opt_RecursiveDo + | Opt_PatternGuards -- optimisation opts | Opt_Strictness @@ -194,6 +211,7 @@ data DynFlag | Opt_UnboxStrictFields | Opt_DictsCheap | Opt_RewriteRules + | Opt_Vectorise -- misc opts | Opt_Cpp @@ -210,6 +228,7 @@ data DynFlag | Opt_PrintBindResult | Opt_Haddock | Opt_Hpc_No_Auto + | Opt_BreakOnException -- keeping stuff | Opt_KeepHiDiffs @@ -354,7 +373,7 @@ data GhcLink -- What to do in the link step, if there is one = NoLink -- Don't link at all | LinkBinary -- Link object code into a binary | LinkInMemory -- Use the in-memory dynamic linker - | MkDLL -- Make a DLL + | LinkDynLib -- Link objects into a dynamic lib (DLL on Windows, DSO on ELF platforms) deriving Eq isNoLink :: GhcLink -> Bool @@ -554,13 +573,14 @@ data Option updOptLevel :: Int -> DynFlags -> DynFlags -- Set dynflags appropriate to the optimisation level updOptLevel n dfs - = dfs2{ optLevel = n } + = dfs2{ optLevel = final_n } where + final_n = max 0 (min 2 n) -- Clamp to 0 <= n <= 2 dfs1 = foldr (flip dopt_unset) dfs remove_dopts dfs2 = foldr (flip dopt_set) dfs1 extra_dopts - extra_dopts = [ f | (ns,f) <- optLevelFlags, n `elem` ns ] - remove_dopts = [ f | (ns,f) <- optLevelFlags, n `notElem` ns ] + extra_dopts = [ f | (ns,f) <- optLevelFlags, final_n `elem` ns ] + remove_dopts = [ f | (ns,f) <- optLevelFlags, final_n `notElem` ns ] optLevelFlags :: [([Int], DynFlag)] optLevelFlags @@ -864,7 +884,7 @@ dynamic_flags = [ -------- Linking ---------------------------------------------------- , ( "c" , NoArg (upd $ \d -> d{ ghcLink=NoLink } )) , ( "no-link" , NoArg (upd $ \d -> d{ ghcLink=NoLink } )) -- Dep. - , ( "-mk-dll" , NoArg (upd $ \d -> d{ ghcLink=MkDLL } )) + , ( "shared" , NoArg (upd $ \d -> d{ ghcLink=LinkDynLib } )) ------- Libraries --------------------------------------------------- , ( "L" , Prefix addLibraryPath ) @@ -888,10 +908,15 @@ dynamic_flags = [ , ( "stubdir" , HasArg (upd . setStubDir . Just)) ------- Keeping temporary files ------------------------------------- - , ( "keep-hc-file" , AnySuffix (\_ -> setDynFlag Opt_KeepHcFiles)) - , ( "keep-s-file" , AnySuffix (\_ -> setDynFlag Opt_KeepSFiles)) - , ( "keep-raw-s-file", AnySuffix (\_ -> setDynFlag Opt_KeepRawSFiles)) - , ( "keep-tmp-files" , AnySuffix (\_ -> setDynFlag Opt_KeepTmpFiles)) + -- These can be singular (think ghc -c) or plural (think ghc --make) + , ( "keep-hc-file" , NoArg (setDynFlag Opt_KeepHcFiles)) + , ( "keep-hc-files" , NoArg (setDynFlag Opt_KeepHcFiles)) + , ( "keep-s-file" , NoArg (setDynFlag Opt_KeepSFiles)) + , ( "keep-s-files" , NoArg (setDynFlag Opt_KeepSFiles)) + , ( "keep-raw-s-file" , NoArg (setDynFlag Opt_KeepRawSFiles)) + , ( "keep-raw-s-files", NoArg (setDynFlag Opt_KeepRawSFiles)) + -- This only makes sense as plural + , ( "keep-tmp-files" , NoArg (setDynFlag Opt_KeepTmpFiles)) ------- Miscellaneous ---------------------------------------------- , ( "no-hs-main" , NoArg (setDynFlag Opt_NoHsMain)) @@ -925,6 +950,7 @@ dynamic_flags = [ , ( "dstg-stats", NoArg (setDynFlag Opt_StgStats)) , ( "ddump-cmm", setDumpFlag Opt_D_dump_cmm) + , ( "ddump-cps-cmm", setDumpFlag Opt_D_dump_cps_cmm) , ( "ddump-asm", setDumpFlag Opt_D_dump_asm) , ( "ddump-cpranal", setDumpFlag Opt_D_dump_cpranal) , ( "ddump-deriv", setDumpFlag Opt_D_dump_deriv) @@ -958,13 +984,13 @@ dynamic_flags = [ , ( "dsource-stats", setDumpFlag Opt_D_source_stats) , ( "dverbose-core2core", setDumpFlag Opt_D_verbose_core2core) , ( "dverbose-stg2stg", setDumpFlag Opt_D_verbose_stg2stg) - , ( "ddump-hi-diffs", setDumpFlag Opt_D_dump_hi_diffs) , ( "ddump-hi", setDumpFlag Opt_D_dump_hi) , ( "ddump-minimal-imports", setDumpFlag Opt_D_dump_minimal_imports) , ( "ddump-vect", setDumpFlag Opt_D_dump_vect) , ( "ddump-hpc", setDumpFlag Opt_D_dump_hpc) , ( "ddump-mod-cycles", setDumpFlag Opt_D_dump_mod_cycles) + , ( "ddump-hi-diffs", NoArg (setDynFlag Opt_D_dump_hi_diffs)) , ( "dcore-lint", NoArg (setDynFlag Opt_DoCoreLinting)) , ( "dstg-lint", NoArg (setDynFlag Opt_DoStgLinting)) , ( "dcmm-lint", NoArg (setDynFlag Opt_DoCmmLinting)) @@ -1003,7 +1029,7 @@ dynamic_flags = [ ------ Compiler flags ----------------------------------------------- - , ( "fasm", AnySuffix (\_ -> setObjTarget HscAsm) ) + , ( "fasm", NoArg (setObjTarget HscAsm) ) , ( "fvia-c", NoArg (setObjTarget HscC) ) , ( "fvia-C", NoArg (setObjTarget HscC) ) @@ -1014,10 +1040,17 @@ dynamic_flags = [ , ( "fglasgow-exts", NoArg (mapM_ setDynFlag glasgowExtsFlags) ) , ( "fno-glasgow-exts", NoArg (mapM_ unSetDynFlag glasgowExtsFlags) ) - -- the rest of the -f* and -fno-* flags - , ( "fno-", PrefixPred (\f -> isFFlag f) (\f -> unSetDynFlag (getFFlag f)) ) - , ( "f", PrefixPred (\f -> isFFlag f) (\f -> setDynFlag (getFFlag f)) ) + , ( "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)) ) ] -- these -f flags can all be reversed with -fno- @@ -1042,24 +1075,6 @@ fFlags = [ ( "warn-deprecations", Opt_WarnDeprecations ), ( "warn-orphans", Opt_WarnOrphans ), ( "warn-tabs", Opt_WarnTabs ), - ( "fi", Opt_FFI ), -- support `-ffi'... - ( "ffi", Opt_FFI ), -- ...and also `-fffi' - ( "arrows", Opt_Arrows ), -- arrow syntax - ( "parr", Opt_PArr ), - ( "th", Opt_TH ), - ( "implicit-prelude", Opt_ImplicitPrelude ), - ( "scoped-type-variables", Opt_ScopedTypeVariables ), - ( "bang-patterns", Opt_BangPatterns ), - ( "overloaded-strings", Opt_OverloadedStrings ), - ( "type-families", Opt_TypeFamilies ), - ( "monomorphism-restriction", Opt_MonomorphismRestriction ), - ( "mono-pat-binds", Opt_MonoPatBinds ), - ( "extended-default-rules", Opt_ExtendedDefaultRules ), - ( "implicit-params", Opt_ImplicitParams ), - ( "allow-overlapping-instances", Opt_AllowOverlappingInstances ), - ( "allow-undecidable-instances", Opt_AllowUndecidableInstances ), - ( "allow-incoherent-instances", Opt_AllowIncoherentInstances ), - ( "generics", Opt_Generics ), ( "strictness", Opt_Strictness ), ( "full-laziness", Opt_FullLaziness ), ( "liberate-case", Opt_LiberateCase ), @@ -1079,19 +1094,120 @@ fFlags = [ ( "print-bind-result", Opt_PrintBindResult ), ( "force-recomp", Opt_ForceRecomp ), ( "hpc-no-auto", Opt_Hpc_No_Auto ), - ( "rewrite-rules", Opt_RewriteRules ) + ( "rewrite-rules", Opt_RewriteRules ), + ( "break-on-exception", Opt_BreakOnException ), + ( "vectorise", Opt_Vectorise ) ] -glasgowExtsFlags = [ - Opt_GlasgowExts, - Opt_FFI, - Opt_ImplicitParams, - Opt_ScopedTypeVariables, - Opt_TypeFamilies ] +-- These -X flags can all be reversed with -Xno- +xFlags :: [(String, DynFlag)] +xFlags = [ + ( "PatternGuards", Opt_PatternGuards ), + ( "MagicHash", Opt_MagicHash ), + ( "KindSignatures", Opt_KindSignatures ), + ( "EmptyDataDecls", Opt_EmptyDataDecls ), + ( "ParallelListComp", Opt_ParallelListComp ), + ( "FI", Opt_FFI ), -- support `-ffi'... + ( "FFI", Opt_FFI ), -- ...and also `-fffi' + ( "ForeignFunctionInterface", Opt_FFI ), + + ( "RecursiveDo", Opt_RecursiveDo ), + ( "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 ), + ( "TypeSynonymInstances", Opt_TypeSynonymInstances ), + ( "FlexibleInstances", Opt_FlexibleInstances ), + ( "MultiParamTypeClasses", Opt_MultiParamTypeClasses ), + ( "FunctionalDependencies", Opt_FunctionalDependencies ), + ( "GeneralizedNewtypeDeriving", Opt_GeneralizedNewtypeDeriving ), + ( "AllowOverlappingInstances", Opt_AllowOverlappingInstances ), + ( "AllowUndecidableInstances", Opt_AllowUndecidableInstances ), + ( "AllowIncoherentInstances", Opt_AllowIncoherentInstances ) + ] + +impliedFlags :: [(DynFlag, [DynFlag])] +impliedFlags = [ + ( Opt_GADTs, [Opt_RelaxedPolyRec] ) -- We want type-sig variables to be completely rigid for GADTs + ] -isFFlag f = f `elem` (map fst fFlags) -getFFlag f = fromJust (lookup f fFlags) +glasgowExtsFlags = [ Opt_GlasgowExts + , Opt_FFI + , Opt_GADTs + , Opt_ImplicitParams + , Opt_ScopedTypeVariables + , Opt_TypeSynonymInstances + , Opt_FlexibleInstances + , Opt_MultiParamTypeClasses + , Opt_FunctionalDependencies + , Opt_MagicHash + , Opt_PatternGuards + , Opt_RecursiveDo + , Opt_ParallelListComp + , Opt_EmptyDataDecls + , Opt_KindSignatures + , 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 + +get_flag flags nf = case [ opt | (ff, opt) <- flags, normaliseFlag ff == nf] of + (o:os) -> o + [] -> panic ("get_flag " ++ nf) + +------------------ +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 -- ----------------------------------------------------------------------------- -- Parsing the dynamic flags. @@ -1112,10 +1228,18 @@ upd f = do dfs <- getCmdLineState putCmdLineState $! (f dfs) +-------------------------- setDynFlag, unSetDynFlag :: DynFlag -> DynP () -setDynFlag f = upd (\dfs -> dopt_set dfs f) +setDynFlag f = upd (\dfs -> foldl dopt_set (dopt_set dfs f) deps) + where + deps = [ d | (f', ds) <- impliedFlags, f' == f, d <- ds ] + -- When you set f, set the ones it implies + -- When you un-set f, however, we don't un-set the things it implies + -- (except for -fno-glasgow-exts, which is treated specially) + unSetDynFlag f = upd (\dfs -> dopt_unset dfs f) +-------------------------- setDumpFlag :: DynFlag -> OptKind DynP setDumpFlag dump_flag = NoArg (setDynFlag Opt_ForceRecomp >> setDynFlag dump_flag) @@ -1340,7 +1464,7 @@ machdepCCOpts dflags sta = opt_Static in ( [ if sta then "-DDONT_WANT_WIN32_DLL_SUPPORT" else "" --- , if suffixMatch "mingw32" cTARGETPLATFORM then "-mno-cygwin" else "" +-- , if "mingw32" `isSuffixOf` cTARGETPLATFORM then "-mno-cygwin" else "" ], [ "-fno-defer-pop", #ifdef HAVE_GCC_MNO_OMIT_LFPTR