From a7f88c2f7900257d6791286f653cf141ebcb81c4 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Sat, 14 Jun 2008 14:48:29 +0000 Subject: [PATCH] Allow flags to be marked as deprecated --- compiler/ghci/InteractiveUI.hs | 4 +- compiler/main/CmdLineParser.hs | 47 +++++--- compiler/main/DriverMkDepend.hs | 10 +- compiler/main/DriverPipeline.hs | 3 +- compiler/main/DynFlags.hs | 252 +++++++++++++++++++++++++++------------ compiler/main/ErrUtils.lhs | 12 +- compiler/main/GHC.hs | 8 +- compiler/main/Main.hs | 36 ++++-- compiler/main/StaticFlags.hs | 58 +++++---- 9 files changed, 296 insertions(+), 134 deletions(-) diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index a49109a..994c0e1 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -38,6 +38,7 @@ import Name import SrcLoc -- Other random utilities +import ErrUtils import Digraph import BasicTypes hiding (isTopLevel) import Panic hiding (showException) @@ -1487,7 +1488,8 @@ newDynFlags :: [String] -> GHCi () newDynFlags minus_opts = do dflags <- getDynFlags let pkg_flags = packageFlags dflags - (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts + (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags minus_opts + io $ handleFlagWarnings dflags' warns if (not (null leftovers)) then throwDyn (CmdLineError ("unrecognised flags: " ++ diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs index 710faf6..4ff78f6 100644 --- a/compiler/main/CmdLineParser.hs +++ b/compiler/main/CmdLineParser.hs @@ -12,7 +12,7 @@ module CmdLineParser ( processArgs, OptKind(..), CmdLineP(..), getCmdLineState, putCmdLineState, - Flag(..), + Flag(..), Deprecated(..), ) where #include "HsVersions.h" @@ -20,9 +20,14 @@ module CmdLineParser ( import Util import Panic -data Flag m = Flag { flagName :: String, -- flag, without the leading - - flagOptKind :: (OptKind m) -- What to do if we see it - } +data Flag m = Flag + { + flagName :: String, -- flag, without the leading - + flagOptKind :: (OptKind m), -- what to do if we see it + flagDeprecated :: Deprecated -- is the flag deprecated? + } + +data Deprecated = Supported | Deprecated String data OptKind m -- Suppose the flag is -f = NoArg (m ()) -- -f all by itself @@ -42,23 +47,29 @@ processArgs :: Monad m -> [String] -- args -> m ( [String], -- spare args - [String] -- errors + [String], -- errors + [String] -- warnings ) -processArgs spec args = process spec args [] [] +processArgs spec args = process spec args [] [] [] where - process _spec [] spare errs = - return (reverse spare, reverse errs) + process _spec [] spare errs warns = + return (reverse spare, reverse errs, reverse warns) - process spec (dash_arg@('-':arg):args) spare errs = + process spec (dash_arg@('-' : arg) : args) spare errs warns = case findArg spec arg of - Just (rest,action) -> - case processOneArg action rest arg args of - Left err -> process spec args spare (err:errs) - Right (action,rest) -> action >> process spec rest spare errs - Nothing -> process spec args (dash_arg:spare) errs + Just (rest, action, deprecated) -> + let warns' = case deprecated of + Deprecated warning -> + (dash_arg ++ " is deprecated: " ++ warning) : warns + Supported -> warns + in case processOneArg action rest arg args of + Left err -> process spec args spare (err:errs) warns' + Right (action,rest) -> do action + process spec rest spare errs warns' + Nothing -> process spec args (dash_arg : spare) errs warns - process spec (arg:args) spare errs = - process spec args (arg:spare) errs + process spec (arg : args) spare errs warns = + process spec args (arg : spare) errs warns processOneArg :: OptKind m -> String -> String -> [String] @@ -99,9 +110,9 @@ processOneArg action rest arg args AnySuffixPred _ f -> Right (f dash_arg, args) -findArg :: [Flag m] -> String -> Maybe (String, OptKind m) +findArg :: [Flag m] -> String -> Maybe (String, OptKind m, Deprecated) findArg spec arg - = case [ (removeSpaces rest, optKind) + = case [ (removeSpaces rest, optKind, flagDeprecated flag) | flag <- spec, let optKind = flagOptKind flag, Just rest <- [maybePrefixMatch (flagName flag) arg], diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs index a0ce114..772a157 100644 --- a/compiler/main/DriverMkDepend.hs +++ b/compiler/main/DriverMkDepend.hs @@ -398,14 +398,20 @@ depEndMarker = "# DO NOT DELETE: End of Haskell dependencies" dep_opts :: [Flag IO] dep_opts = [ Flag "s" (SepArg (consIORef v_Dep_suffixes)) + Supported , Flag "f" (SepArg (writeIORef v_Dep_makefile)) + Supported , Flag "w" (NoArg (writeIORef v_Dep_warnings False)) + Supported , Flag "-include-prelude" (NoArg (writeIORef v_Dep_include_pkg_deps True)) - -- -include-prelude is the old name for -include-pkg-deps, kept around - -- for backward compatibility, but undocumented + (Deprecated "Use --include-pkg-deps instead") , Flag "-include-pkg-deps" (NoArg (writeIORef v_Dep_include_pkg_deps True)) + Supported , Flag "-exclude-module=" (Prefix (consIORef v_Dep_exclude_mods . mkModuleName)) + Supported , Flag "x" (Prefix (consIORef v_Dep_exclude_mods . mkModuleName)) + Supported ] + diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 7c515fe..318dac5 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -614,7 +614,8 @@ runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_l runPhase (Cpp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc = do let dflags0 = hsc_dflags hsc_env src_opts <- getOptionsFromFile dflags0 input_fn - (dflags,unhandled_flags) <- parseDynamicFlags dflags0 (map unLoc src_opts) + (dflags, unhandled_flags, warns) <- parseDynamicFlags dflags0 (map unLoc src_opts) + handleFlagWarnings dflags warns checkProcessArgsResult unhandled_flags (basename <.> suff) if not (dopt Opt_Cpp dflags) then diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index a051916..8264ff9 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -1020,244 +1020,345 @@ allFlags = map ('-':) $ dynamic_flags :: [Flag DynP] dynamic_flags = [ - Flag "n" (NoArg (setDynFlag Opt_DryRun)) - , Flag "cpp" (NoArg (setDynFlag Opt_Cpp)) - , Flag "F" (NoArg (setDynFlag Opt_Pp)) - , Flag "#include" (HasArg (addCmdlineHCInclude)) - , Flag "v" (OptIntSuffix setVerbosity) + Flag "n" (NoArg (setDynFlag Opt_DryRun)) Supported + , Flag "cpp" (NoArg (setDynFlag Opt_Cpp)) Supported + , Flag "F" (NoArg (setDynFlag Opt_Pp)) Supported + , Flag "#include" (HasArg (addCmdlineHCInclude)) Supported + , Flag "v" (OptIntSuffix setVerbosity) Supported ------- Specific phases -------------------------------------------- - , Flag "pgmL" (HasArg (upd . setPgmL)) - , Flag "pgmP" (HasArg (upd . setPgmP)) - , Flag "pgmF" (HasArg (upd . setPgmF)) - , Flag "pgmc" (HasArg (upd . setPgmc)) - , Flag "pgmm" (HasArg (upd . setPgmm)) - , Flag "pgms" (HasArg (upd . setPgms)) - , Flag "pgma" (HasArg (upd . setPgma)) - , Flag "pgml" (HasArg (upd . setPgml)) - , Flag "pgmdll" (HasArg (upd . setPgmdll)) - , Flag "pgmwindres" (HasArg (upd . setPgmwindres)) - - , Flag "optL" (HasArg (upd . addOptL)) - , Flag "optP" (HasArg (upd . addOptP)) - , Flag "optF" (HasArg (upd . addOptF)) - , Flag "optc" (HasArg (upd . addOptc)) - , Flag "optm" (HasArg (upd . addOptm)) - , Flag "opta" (HasArg (upd . addOpta)) - , Flag "optl" (HasArg (upd . addOptl)) - , Flag "optdep" (HasArg (upd . addOptdep)) - , Flag "optwindres" (HasArg (upd . addOptwindres)) + , Flag "pgmL" (HasArg (upd . setPgmL)) Supported + , Flag "pgmP" (HasArg (upd . setPgmP)) Supported + , Flag "pgmF" (HasArg (upd . setPgmF)) Supported + , Flag "pgmc" (HasArg (upd . setPgmc)) Supported + , Flag "pgmm" (HasArg (upd . setPgmm)) Supported + , Flag "pgms" (HasArg (upd . setPgms)) Supported + , Flag "pgma" (HasArg (upd . setPgma)) Supported + , Flag "pgml" (HasArg (upd . setPgml)) Supported + , Flag "pgmdll" (HasArg (upd . setPgmdll)) Supported + , Flag "pgmwindres" (HasArg (upd . setPgmwindres)) Supported + + , Flag "optL" (HasArg (upd . addOptL)) Supported + , Flag "optP" (HasArg (upd . addOptP)) Supported + , Flag "optF" (HasArg (upd . addOptF)) Supported + , Flag "optc" (HasArg (upd . addOptc)) Supported + , Flag "optm" (HasArg (upd . addOptm)) Supported + , Flag "opta" (HasArg (upd . addOpta)) Supported + , Flag "optl" (HasArg (upd . addOptl)) Supported + , Flag "optdep" (HasArg (upd . addOptdep)) Supported + , Flag "optwindres" (HasArg (upd . addOptwindres)) Supported , Flag "split-objs" (NoArg (if can_split then setDynFlag Opt_SplitObjs else return ())) + Supported -------- Linking ---------------------------------------------------- , Flag "c" (NoArg (upd $ \d -> d{ ghcLink=NoLink } )) - , Flag "no-link" (NoArg (upd $ \d -> d{ ghcLink=NoLink } )) -- Dep. + Supported + , Flag "no-link" (NoArg (upd $ \d -> d{ ghcLink=NoLink } )) + (Deprecated "Use -c instead") , Flag "shared" (NoArg (upd $ \d -> d{ ghcLink=LinkDynLib } )) + Supported , Flag "dynload" (HasArg (upd . parseDynLibLoaderMode)) + Supported ------- Libraries --------------------------------------------------- - , Flag "L" (Prefix addLibraryPath ) - , Flag "l" (AnySuffix (\s -> do upd (addOptl s))) + , Flag "L" (Prefix addLibraryPath ) Supported + , Flag "l" (AnySuffix (\s -> do upd (addOptl s))) Supported ------- Frameworks -------------------------------------------------- -- -framework-path should really be -F ... - , Flag "framework-path" (HasArg addFrameworkPath ) - , Flag "framework" (HasArg (upd . addCmdlineFramework)) + , Flag "framework-path" (HasArg addFrameworkPath ) Supported + , Flag "framework" (HasArg (upd . addCmdlineFramework)) Supported ------- Output Redirection ------------------------------------------ - , Flag "odir" (HasArg (upd . setObjectDir)) - , Flag "o" (SepArg (upd . setOutputFile . Just)) - , Flag "ohi" (HasArg (upd . setOutputHi . Just )) - , Flag "osuf" (HasArg (upd . setObjectSuf)) - , Flag "hcsuf" (HasArg (upd . setHcSuf)) - , Flag "hisuf" (HasArg (upd . setHiSuf)) - , Flag "hidir" (HasArg (upd . setHiDir)) - , Flag "tmpdir" (HasArg (upd . setTmpDir)) - , Flag "stubdir" (HasArg (upd . setStubDir)) + , Flag "odir" (HasArg (upd . setObjectDir)) Supported + , Flag "o" (SepArg (upd . setOutputFile . Just)) Supported + , Flag "ohi" (HasArg (upd . setOutputHi . Just )) Supported + , Flag "osuf" (HasArg (upd . setObjectSuf)) Supported + , Flag "hcsuf" (HasArg (upd . setHcSuf)) Supported + , Flag "hisuf" (HasArg (upd . setHiSuf)) Supported + , Flag "hidir" (HasArg (upd . setHiDir)) Supported + , Flag "tmpdir" (HasArg (upd . setTmpDir)) Supported + , Flag "stubdir" (HasArg (upd . setStubDir)) Supported , Flag "ddump-file-prefix" (HasArg (upd . setDumpPrefixForce . Just)) + Supported ------- Keeping temporary files ------------------------------------- -- These can be singular (think ghc -c) or plural (think ghc --make) - , Flag "keep-hc-file" (NoArg (setDynFlag Opt_KeepHcFiles)) - , Flag "keep-hc-files" (NoArg (setDynFlag Opt_KeepHcFiles)) - , Flag "keep-s-file" (NoArg (setDynFlag Opt_KeepSFiles)) - , Flag "keep-s-files" (NoArg (setDynFlag Opt_KeepSFiles)) - , Flag "keep-raw-s-file" (NoArg (setDynFlag Opt_KeepRawSFiles)) - , Flag "keep-raw-s-files" (NoArg (setDynFlag Opt_KeepRawSFiles)) + , Flag "keep-hc-file" (NoArg (setDynFlag Opt_KeepHcFiles)) Supported + , Flag "keep-hc-files" (NoArg (setDynFlag Opt_KeepHcFiles)) Supported + , Flag "keep-s-file" (NoArg (setDynFlag Opt_KeepSFiles)) Supported + , Flag "keep-s-files" (NoArg (setDynFlag Opt_KeepSFiles)) Supported + , Flag "keep-raw-s-file" (NoArg (setDynFlag Opt_KeepRawSFiles)) Supported + , Flag "keep-raw-s-files" (NoArg (setDynFlag Opt_KeepRawSFiles)) Supported -- This only makes sense as plural - , Flag "keep-tmp-files" (NoArg (setDynFlag Opt_KeepTmpFiles)) + , Flag "keep-tmp-files" (NoArg (setDynFlag Opt_KeepTmpFiles)) Supported ------- Miscellaneous ---------------------------------------------- - , Flag "no-hs-main" (NoArg (setDynFlag Opt_NoHsMain)) - , Flag "main-is" (SepArg setMainIs ) - , Flag "haddock" (NoArg (setDynFlag Opt_Haddock)) - , Flag "haddock-opts" (HasArg (upd . addHaddockOpts)) - , Flag "hpcdir" (SepArg setOptHpcDir) + , Flag "no-hs-main" (NoArg (setDynFlag Opt_NoHsMain)) Supported + , Flag "main-is" (SepArg setMainIs ) Supported + , Flag "haddock" (NoArg (setDynFlag Opt_Haddock)) Supported + , Flag "haddock-opts" (HasArg (upd . addHaddockOpts)) Supported + , Flag "hpcdir" (SepArg setOptHpcDir) Supported - ------- recompilation checker (DEPRECATED, use -fforce-recomp) ----- + ------- recompilation checker -------------------------------------- , Flag "recomp" (NoArg (unSetDynFlag Opt_ForceRecomp)) + (Deprecated "Use -fforce-recomp instead") , Flag "no-recomp" (NoArg (setDynFlag Opt_ForceRecomp)) + (Deprecated "Use -fno-force-recomp instead") ------- Packages ---------------------------------------------------- - , Flag "package-conf" (HasArg extraPkgConf_) + , Flag "package-conf" (HasArg extraPkgConf_) Supported , Flag "no-user-package-conf" (NoArg (unSetDynFlag Opt_ReadUserPackageConf)) - , Flag "package-name" (HasArg (upd . setPackageName)) - , Flag "package" (HasArg exposePackage) - , Flag "hide-package" (HasArg hidePackage) + Supported + , Flag "package-name" (HasArg (upd . setPackageName)) Supported + , Flag "package" (HasArg exposePackage) Supported + , Flag "hide-package" (HasArg hidePackage) Supported , Flag "hide-all-packages" (NoArg (setDynFlag Opt_HideAllPackages)) + Supported , Flag "ignore-package" (HasArg ignorePackage) - , Flag "syslib" (HasArg exposePackage) -- for compatibility + Supported + , Flag "syslib" (HasArg exposePackage) + (Deprecated "Use -package instead") ------ HsCpp opts --------------------------------------------------- - , Flag "D" (AnySuffix (upd . addOptP)) - , Flag "U" (AnySuffix (upd . addOptP)) + , Flag "D" (AnySuffix (upd . addOptP)) Supported + , Flag "U" (AnySuffix (upd . addOptP)) Supported ------- Include/Import Paths ---------------------------------------- - , Flag "I" (Prefix addIncludePath) - , Flag "i" (OptPrefix addImportPath ) + , Flag "I" (Prefix addIncludePath) Supported + , Flag "i" (OptPrefix addImportPath ) Supported ------ Debugging ---------------------------------------------------- - , Flag "dstg-stats" (NoArg (setDynFlag Opt_StgStats)) + , Flag "dstg-stats" (NoArg (setDynFlag Opt_StgStats)) Supported , Flag "ddump-cmm" (setDumpFlag Opt_D_dump_cmm) + Supported , Flag "ddump-cmmz" (setDumpFlag Opt_D_dump_cmmz) + Supported , Flag "ddump-cmmz-pretty" (setDumpFlag Opt_D_dump_cmmz_pretty) + Supported , Flag "ddump-cps-cmm" (setDumpFlag Opt_D_dump_cps_cmm) + Supported , Flag "ddump-cvt-cmm" (setDumpFlag Opt_D_dump_cvt_cmm) + Supported , Flag "ddump-asm" (setDumpFlag Opt_D_dump_asm) + Supported , Flag "ddump-asm-native" (setDumpFlag Opt_D_dump_asm_native) + Supported , Flag "ddump-asm-liveness" (setDumpFlag Opt_D_dump_asm_liveness) + Supported , Flag "ddump-asm-coalesce" (setDumpFlag Opt_D_dump_asm_coalesce) + Supported , Flag "ddump-asm-regalloc" (setDumpFlag Opt_D_dump_asm_regalloc) + Supported , Flag "ddump-asm-conflicts" (setDumpFlag Opt_D_dump_asm_conflicts) + Supported , Flag "ddump-asm-regalloc-stages" (setDumpFlag Opt_D_dump_asm_regalloc_stages) + Supported , Flag "ddump-asm-stats" (setDumpFlag Opt_D_dump_asm_stats) + Supported , Flag "ddump-cpranal" (setDumpFlag Opt_D_dump_cpranal) + Supported , Flag "ddump-deriv" (setDumpFlag Opt_D_dump_deriv) + Supported , Flag "ddump-ds" (setDumpFlag Opt_D_dump_ds) + Supported , Flag "ddump-flatC" (setDumpFlag Opt_D_dump_flatC) + Supported , Flag "ddump-foreign" (setDumpFlag Opt_D_dump_foreign) + Supported , Flag "ddump-inlinings" (setDumpFlag Opt_D_dump_inlinings) + Supported , Flag "ddump-rule-firings" (setDumpFlag Opt_D_dump_rule_firings) + Supported , Flag "ddump-occur-anal" (setDumpFlag Opt_D_dump_occur_anal) + Supported , Flag "ddump-parsed" (setDumpFlag Opt_D_dump_parsed) + Supported , Flag "ddump-rn" (setDumpFlag Opt_D_dump_rn) + Supported , Flag "ddump-simpl" (setDumpFlag Opt_D_dump_simpl) + Supported , Flag "ddump-simpl-iterations" (setDumpFlag Opt_D_dump_simpl_iterations) + Supported , Flag "ddump-simpl-phases" (OptPrefix setDumpSimplPhases) + Supported , Flag "ddump-spec" (setDumpFlag Opt_D_dump_spec) + Supported , Flag "ddump-prep" (setDumpFlag Opt_D_dump_prep) + Supported , Flag "ddump-stg" (setDumpFlag Opt_D_dump_stg) + Supported , Flag "ddump-stranal" (setDumpFlag Opt_D_dump_stranal) + Supported , Flag "ddump-tc" (setDumpFlag Opt_D_dump_tc) + Supported , Flag "ddump-types" (setDumpFlag Opt_D_dump_types) + Supported , Flag "ddump-rules" (setDumpFlag Opt_D_dump_rules) + Supported , Flag "ddump-cse" (setDumpFlag Opt_D_dump_cse) + Supported , Flag "ddump-worker-wrapper" (setDumpFlag Opt_D_dump_worker_wrapper) + Supported , Flag "ddump-rn-trace" (setDumpFlag Opt_D_dump_rn_trace) + Supported , Flag "ddump-if-trace" (setDumpFlag Opt_D_dump_if_trace) + Supported , Flag "ddump-tc-trace" (setDumpFlag Opt_D_dump_tc_trace) + Supported , Flag "ddump-splices" (setDumpFlag Opt_D_dump_splices) + Supported , Flag "ddump-rn-stats" (setDumpFlag Opt_D_dump_rn_stats) + Supported , Flag "ddump-opt-cmm" (setDumpFlag Opt_D_dump_opt_cmm) + Supported , Flag "ddump-simpl-stats" (setDumpFlag Opt_D_dump_simpl_stats) + Supported , Flag "ddump-bcos" (setDumpFlag Opt_D_dump_BCOs) + Supported , Flag "dsource-stats" (setDumpFlag Opt_D_source_stats) + Supported , Flag "dverbose-core2core" (NoArg setVerboseCore2Core) + Supported , Flag "dverbose-stg2stg" (setDumpFlag Opt_D_verbose_stg2stg) + Supported , Flag "ddump-hi" (setDumpFlag Opt_D_dump_hi) + Supported , Flag "ddump-minimal-imports" (setDumpFlag Opt_D_dump_minimal_imports) + Supported , Flag "ddump-vect" (setDumpFlag Opt_D_dump_vect) + Supported , Flag "ddump-hpc" (setDumpFlag Opt_D_dump_hpc) + Supported , Flag "ddump-mod-cycles" (setDumpFlag Opt_D_dump_mod_cycles) + Supported , Flag "ddump-view-pattern-commoning" (setDumpFlag Opt_D_dump_view_pattern_commoning) + Supported , Flag "ddump-to-file" (setDumpFlag Opt_DumpToFile) + Supported , Flag "ddump-hi-diffs" (setDumpFlag Opt_D_dump_hi_diffs) + Supported , Flag "dcore-lint" (NoArg (setDynFlag Opt_DoCoreLinting)) + Supported , Flag "dstg-lint" (NoArg (setDynFlag Opt_DoStgLinting)) + Supported , Flag "dcmm-lint" (NoArg (setDynFlag Opt_DoCmmLinting)) + Supported , Flag "dasm-lint" (NoArg (setDynFlag Opt_DoAsmLinting)) + Supported , Flag "dshow-passes" (NoArg (do setDynFlag Opt_ForceRecomp setVerbosity (Just 2))) + Supported , Flag "dfaststring-stats" (NoArg (setDynFlag Opt_D_faststring_stats)) + Supported ------ Machine dependant (-m) stuff --------------------------- , Flag "monly-2-regs" (NoArg (upd (\s -> s{stolen_x86_regs = 2}) )) + Supported , Flag "monly-3-regs" (NoArg (upd (\s -> s{stolen_x86_regs = 3}) )) + Supported , Flag "monly-4-regs" (NoArg (upd (\s -> s{stolen_x86_regs = 4}) )) + Supported ------ Warning opts ------------------------------------------------- , Flag "W" (NoArg (mapM_ setDynFlag minusWOpts)) + Supported , Flag "Werror" (NoArg (setDynFlag Opt_WarnIsError)) + Supported , Flag "Wwarn" (NoArg (unSetDynFlag Opt_WarnIsError)) + Supported , Flag "Wall" (NoArg (mapM_ setDynFlag minusWallOpts)) - , Flag "Wnot" (NoArg (mapM_ unSetDynFlag minusWallOpts)) -- DEPRECATED + Supported + , Flag "Wnot" (NoArg (mapM_ unSetDynFlag minusWallOpts)) + (Deprecated "Use -w instead") , Flag "w" (NoArg (mapM_ unSetDynFlag minuswRemovesOpts)) + Supported ------ Optimisation flags ------------------------------------------ - , Flag "O" (NoArg (upd (setOptLevel 1))) - , Flag "Onot" (NoArg (upd (setOptLevel 0))) -- deprecated - , Flag "Odph" (NoArg (upd setDPHOpt)) + , Flag "O" (NoArg (upd (setOptLevel 1))) Supported + , Flag "Onot" (NoArg (upd (setOptLevel 0))) + (Deprecated "Use -O0 instead") + , Flag "Odph" (NoArg (upd setDPHOpt)) Supported , Flag "O" (OptIntSuffix (\mb_n -> upd (setOptLevel (mb_n `orElse` 1)))) + Supported -- If the number is missing, use 1 , Flag "fsimplifier-phases" (IntSuffix (\n -> upd (\dfs -> dfs{ simplPhases = n }))) + Supported , Flag "fmax-simplifier-iterations" (IntSuffix (\n -> upd (\dfs -> dfs{ maxSimplIterations = n }))) + Supported , Flag "fspec-constr-threshold" (IntSuffix (\n -> upd (\dfs -> dfs{ specConstrThreshold = Just n }))) + Supported , Flag "fno-spec-constr-threshold" (NoArg (upd (\dfs -> dfs{ specConstrThreshold = Nothing }))) + Supported , Flag "fspec-constr-count" (IntSuffix (\n -> upd (\dfs -> dfs{ specConstrCount = Just n }))) + Supported , Flag "fno-spec-constr-count" (NoArg (upd (\dfs -> dfs{ specConstrCount = Nothing }))) + Supported , Flag "fliberate-case-threshold" (IntSuffix (\n -> upd (\dfs -> dfs{ liberateCaseThreshold = Just n }))) + Supported , Flag "fno-liberate-case-threshold" (NoArg (upd (\dfs -> dfs{ liberateCaseThreshold = Nothing }))) + Supported , Flag "frule-check" (SepArg (\s -> upd (\dfs -> dfs{ ruleCheck = Just s }))) + Supported , Flag "fcontext-stack" (IntSuffix $ \n -> upd $ \dfs -> dfs{ ctxtStkDepth = n }) + Supported ------ Compiler flags ----------------------------------------------- - , Flag "fasm" (NoArg (setObjTarget HscAsm)) - , Flag "fvia-c" (NoArg (setObjTarget HscC)) - , Flag "fvia-C" (NoArg (setObjTarget HscC)) + , Flag "fasm" (NoArg (setObjTarget HscAsm)) Supported + , Flag "fvia-c" (NoArg (setObjTarget HscC)) Supported + , Flag "fvia-C" (NoArg (setObjTarget HscC)) Supported - , Flag "fno-code" (NoArg (setTarget HscNothing)) - , Flag "fbyte-code" (NoArg (setTarget HscInterpreted)) - , Flag "fobject-code" (NoArg (setTarget defaultHscTarget)) + , Flag "fno-code" (NoArg (setTarget HscNothing)) Supported + , Flag "fbyte-code" (NoArg (setTarget HscInterpreted)) Supported + , Flag "fobject-code" (NoArg (setTarget defaultHscTarget)) Supported , Flag "fglasgow-exts" (NoArg (mapM_ setDynFlag glasgowExtsFlags)) + Supported , Flag "fno-glasgow-exts" (NoArg (mapM_ unSetDynFlag glasgowExtsFlags)) + Supported + + -- XXX We need to flatten these: -- the rest of the -f* and -fno-* flags , Flag "f" (PrefixPred (isFlag fFlags) (\f -> setDynFlag (getFlag fFlags f))) + Supported , Flag "f" (PrefixPred (isPrefFlag "no-" fFlags) (\f -> unSetDynFlag (getPrefFlag "no-" fFlags f))) + Supported -- the -X* and -XNo* flags , Flag "X" (PrefixPred (isFlag xFlags) (\f -> setDynFlag (getFlag xFlags f))) + Supported , Flag "X" (PrefixPred (isPrefFlag "No" xFlags) (\f -> unSetDynFlag (getPrefFlag "No" xFlags f))) + Supported ] -- these -f flags can all be reversed with -fno- @@ -1478,14 +1579,13 @@ getPrefFlag pref flags f = getFlag flags (fromJust (maybePrefixMatch pref f)) -- ----------------------------------------------------------------------------- -- Parsing the dynamic flags. -parseDynamicFlags :: DynFlags -> [String] -> IO (DynFlags,[String]) +parseDynamicFlags :: DynFlags -> [String] -> IO (DynFlags, [String], [String]) parseDynamicFlags dflags args = do - let ((leftover,errs),dflags') + let ((leftover, errs, warns), dflags') = runCmdLine (processArgs dynamic_flags args) dflags when (not (null errs)) $ do throwDyn (UsageError (unlines errs)) - return (dflags', leftover) - + return (dflags', leftover, warns) type DynP = CmdLineP DynFlags diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index 9ce02a3..b9e739f 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -13,6 +13,7 @@ module ErrUtils ( Messages, errorsFound, emptyMessages, mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg, printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings, + handleFlagWarnings, ghcExit, doIfSet, doIfSet_dyn, @@ -174,7 +175,16 @@ printBagOfWarnings dflags bag_of_warns EQ -> True GT -> False - +handleFlagWarnings :: DynFlags -> [String] -> IO () +handleFlagWarnings _ [] = return () +handleFlagWarnings dflags warns + = do -- It would be nicer if warns :: [Message], but that has circular + -- import problems. + let warns' = map text warns + mapM_ (log_action dflags SevWarning noSrcSpan defaultUserStyle) warns' + when (dopt Opt_WarnIsError dflags) $ + do errorMsg dflags $ text "\nFailing due to -Werror.\n" + exitWith (ExitFailure 1) ghcExit :: DynFlags -> Int -> IO () ghcExit dflags val diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index bf3bfd1..a629ef2 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -255,10 +255,7 @@ import FiniteMap import Panic import Digraph import Bag ( unitBag, listToBag ) -import ErrUtils ( Severity(..), showPass, fatalErrorMsg, debugTraceMsg, - mkPlainErrMsg, printBagOfErrors, printBagOfWarnings, - WarnMsg ) -import qualified ErrUtils +import ErrUtils import Util import StringBuffer ( StringBuffer, hGetStringBuffer ) import Outputable @@ -1938,8 +1935,9 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time)) let local_opts = getOptions dflags buf src_fn -- - (dflags', _errs) <- parseDynamicFlags dflags (map unLoc local_opts) + (dflags', _errs, warns) <- parseDynamicFlags dflags (map unLoc local_opts) -- XXX: shouldn't we be reporting the errors? + handleFlagWarnings dflags' warns let needs_preprocessing diff --git a/compiler/main/Main.hs b/compiler/main/Main.hs index de72089..8297323 100644 --- a/compiler/main/Main.hs +++ b/compiler/main/Main.hs @@ -37,7 +37,7 @@ import DriverPhases ( Phase(..), isSourceFilename, anyHsc, import StaticFlags import DynFlags import BasicTypes ( failed ) -import ErrUtils ( putMsg ) +import ErrUtils import FastString import Outputable import Util @@ -78,10 +78,10 @@ main = mbMinusB | null minusB_args = Nothing | otherwise = Just (drop 2 (last minusB_args)) - argv2 <- parseStaticFlags argv1 + (argv2, staticFlagWarnings) <- parseStaticFlags argv1 -- 2. Parse the "mode" flags (--make, --interactive etc.) - (cli_mode, argv3) <- parseModeFlags argv2 + (cli_mode, argv3, modeFlagWarnings) <- parseModeFlags argv2 -- If all we want to do is to show the version number then do it -- now, before we start a GHC session etc. @@ -129,7 +129,12 @@ main = -- The rest of the arguments are "dynamic" -- Leftover ones are presumably files - (dflags, fileish_args) <- GHC.parseDynamicFlags dflags1 argv3 + (dflags, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags1 argv3 + + let flagWarnings = staticFlagWarnings + ++ modeFlagWarnings + ++ dynamicFlagWarnings + handleFlagWarnings dflags flagWarnings -- make sure we clean up after ourselves GHC.defaultCleanupHandler dflags $ do @@ -355,13 +360,13 @@ isCompManagerMode _ = False -- ----------------------------------------------------------------------------- -- Parsing the mode flag -parseModeFlags :: [String] -> IO (CmdLineMode, [String]) +parseModeFlags :: [String] -> IO (CmdLineMode, [String], [String]) parseModeFlags args = do - let ((leftover, errs), (mode, _, flags)) = + let ((leftover, errs, warns), (mode, _, flags)) = runCmdLine (processArgs mode_flags args) (StopBefore StopLn, "", []) when (not (null errs)) $ do throwDyn (UsageError (unlines errs)) - return (mode, flags ++ leftover) + return (mode, flags ++ leftover, warns) type ModeM = CmdLineP (CmdLineMode, String, [String]) -- mode flags sometimes give rise to new DynFlags (eg. -C, see below) @@ -371,32 +376,49 @@ mode_flags :: [Flag ModeM] mode_flags = [ ------- help / version ---------------------------------------------- Flag "?" (PassFlag (setMode ShowUsage)) + Supported , Flag "-help" (PassFlag (setMode ShowUsage)) + Supported , Flag "-print-libdir" (PassFlag (setMode PrintLibdir)) + Supported , Flag "V" (PassFlag (setMode ShowVersion)) + Supported , Flag "-version" (PassFlag (setMode ShowVersion)) + Supported , Flag "-numeric-version" (PassFlag (setMode ShowNumVersion)) + Supported , Flag "-info" (PassFlag (setMode ShowInfo)) + Supported , Flag "-supported-languages" (PassFlag (setMode ShowSupportedLanguages)) + Supported ------- interfaces ---------------------------------------------------- , Flag "-show-iface" (HasArg (\f -> setMode (ShowInterface f) "--show-iface")) + Supported ------- primary modes ------------------------------------------------ , Flag "M" (PassFlag (setMode DoMkDependHS)) + Supported , Flag "E" (PassFlag (setMode (StopBefore anyHsc))) + Supported , Flag "C" (PassFlag (\f -> do setMode (StopBefore HCc) f addFlag "-fvia-C")) + Supported , Flag "S" (PassFlag (setMode (StopBefore As))) + Supported , Flag "-make" (PassFlag (setMode DoMake)) + Supported , Flag "-interactive" (PassFlag (setMode DoInteractive)) + Supported , Flag "e" (HasArg (\s -> updateMode (updateDoEval s) "-e")) + Supported -- -fno-code says to stop after Hsc but don't generate any code. , Flag "fno-code" (PassFlag (\f -> do setMode (StopBefore HCc) f addFlag "-fno-code" addFlag "-no-recomp")) + Supported ] setMode :: CmdLineMode -> String -> ModeM () diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index dd5754c..534c3d2 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -93,12 +93,12 @@ import Data.List ----------------------------------------------------------------------------- -- Static flags -parseStaticFlags :: [String] -> IO [String] +parseStaticFlags :: [String] -> IO ([String], [String]) parseStaticFlags args = do ready <- readIORef v_opt_C_ready when ready $ throwDyn (ProgramError "Too late for parseStaticFlags: call it before newSession") - (leftover, errs) <- processArgs static_flags args + (leftover, errs, warns1) <- processArgs static_flags args when (not (null errs)) $ throwDyn (UsageError (unlines errs)) -- deal with the way flags: the way (eg. prof) gives rise to @@ -109,7 +109,7 @@ parseStaticFlags args = do let unreg_flags | cGhcUnregisterised == "YES" = unregFlags | otherwise = [] - (more_leftover, errs) <- processArgs static_flags (unreg_flags ++ way_flags) + (more_leftover, errs, warns2) <- processArgs static_flags (unreg_flags ++ way_flags) -- see sanity code in staticOpts writeIORef v_opt_C_ready True @@ -128,7 +128,8 @@ parseStaticFlags args = do | otherwise = [] when (not (null errs)) $ ghcError (UsageError (unlines errs)) - return (excess_prec++cg_flags++more_leftover++leftover) + return (excess_prec ++ cg_flags ++ more_leftover ++ leftover, + warns1 ++ warns2) initStaticOpts :: IO () initStaticOpts = writeIORef v_opt_C_ready True @@ -149,54 +150,65 @@ static_flags :: [Flag IO] static_flags = [ ------- GHCi ------------------------------------------------------- - Flag "ignore-dot-ghci" (PassFlag addOpt) - , Flag "read-dot-ghci" (NoArg (removeOpt "-ignore-dot-ghci")) + Flag "ignore-dot-ghci" (PassFlag addOpt) Supported + , Flag "read-dot-ghci" (NoArg (removeOpt "-ignore-dot-ghci")) Supported ------- ways -------------------------------------------------------- - , Flag "prof" (NoArg (addWay WayProf)) - , Flag "ticky" (NoArg (addWay WayTicky)) - , Flag "parallel" (NoArg (addWay WayPar)) - , Flag "gransim" (NoArg (addWay WayGran)) - , Flag "smp" (NoArg (addWay WayThreaded)) -- backwards compat. - , Flag "debug" (NoArg (addWay WayDebug)) - , Flag "ndp" (NoArg (addWay WayNDP)) - , Flag "threaded" (NoArg (addWay WayThreaded)) + , Flag "prof" (NoArg (addWay WayProf)) Supported + , Flag "ticky" (NoArg (addWay WayTicky)) Supported + , Flag "parallel" (NoArg (addWay WayPar)) Supported + , Flag "gransim" (NoArg (addWay WayGran)) Supported + , Flag "smp" (NoArg (addWay WayThreaded)) + (Deprecated "Use -threaded instead") + , Flag "debug" (NoArg (addWay WayDebug)) Supported + , Flag "ndp" (NoArg (addWay WayNDP)) Supported + , Flag "threaded" (NoArg (addWay WayThreaded)) Supported -- ToDo: user ways ------ Debugging ---------------------------------------------------- - , Flag "dppr-debug" (PassFlag addOpt) - , Flag "dsuppress-uniques" (PassFlag addOpt) - , Flag "dppr-user-length" (AnySuffix addOpt) - , Flag "dopt-fuel" (AnySuffix addOpt) - , Flag "dno-debug-output" (PassFlag addOpt) + , Flag "dppr-debug" (PassFlag addOpt) Supported + , Flag "dsuppress-uniques" (PassFlag addOpt) Supported + , Flag "dppr-user-length" (AnySuffix addOpt) Supported + , Flag "dopt-fuel" (AnySuffix addOpt) Supported + , Flag "dno-debug-output" (PassFlag addOpt) Supported -- rest of the debugging flags are dynamic --------- Profiling -------------------------------------------------- , Flag "auto-all" (NoArg (addOpt "-fauto-sccs-on-all-toplevs")) + Supported , Flag "auto" (NoArg (addOpt "-fauto-sccs-on-exported-toplevs")) + Supported , Flag "caf-all" (NoArg (addOpt "-fauto-sccs-on-individual-cafs")) + Supported -- "ignore-sccs" doesn't work (ToDo) , Flag "no-auto-all" (NoArg (removeOpt "-fauto-sccs-on-all-toplevs")) + Supported , Flag "no-auto" (NoArg (removeOpt "-fauto-sccs-on-exported-toplevs")) + Supported , Flag "no-caf-all" (NoArg (removeOpt "-fauto-sccs-on-individual-cafs")) + Supported ----- Linker -------------------------------------------------------- - , Flag "static" (PassFlag addOpt) - , Flag "dynamic" (NoArg (removeOpt "-static")) - , Flag "rdynamic" (NoArg (return ())) -- ignored for compat w/ gcc + , Flag "static" (PassFlag addOpt) Supported + , Flag "dynamic" (NoArg (removeOpt "-static")) Supported + -- ignored for compat w/ gcc: + , Flag "rdynamic" (NoArg (return ())) Supported ----- RTS opts ------------------------------------------------------ , Flag "H" (HasArg (setHeapSize . fromIntegral . decodeSize)) - , Flag "Rghc-timing" (NoArg (enableTimingStats)) + Supported + , Flag "Rghc-timing" (NoArg (enableTimingStats)) Supported ------ Compiler flags ----------------------------------------------- -- All other "-fno-" options cancel out "-f" on the hsc cmdline , Flag "fno-" (PrefixPred (\s -> isStaticFlag ("f"++s)) (\s -> removeOpt ("-f"++s))) + Supported -- Pass all remaining "-f" options to hsc , Flag "f" (AnySuffixPred (isStaticFlag) addOpt) + Supported ] addOpt :: String -> IO () -- 1.7.10.4