From: Ian Lynagh Date: Sat, 14 Jun 2008 13:38:48 +0000 (+0000) Subject: Use a proper datatype, rather than pairs, for flags X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=0079141c61f673039ccd879cd75174b33eb40b8f Use a proper datatype, rather than pairs, for flags --- diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs index 8ec2f6a..710faf6 100644 --- a/compiler/main/CmdLineParser.hs +++ b/compiler/main/CmdLineParser.hs @@ -11,7 +11,8 @@ module CmdLineParser ( processArgs, OptKind(..), - CmdLineP(..), getCmdLineState, putCmdLineState + CmdLineP(..), getCmdLineState, putCmdLineState, + Flag(..), ) where #include "HsVersions.h" @@ -19,6 +20,10 @@ 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 OptKind m -- Suppose the flag is -f = NoArg (m ()) -- -f all by itself | HasArg (String -> m ()) -- -farg or -f arg @@ -33,7 +38,7 @@ data OptKind m -- Suppose the flag is -f | AnySuffixPred (String -> Bool) (String -> m ()) processArgs :: Monad m - => [(String, OptKind m)] -- cmdline parser spec + => [Flag m] -- cmdline parser spec -> [String] -- args -> m ( [String], -- spare args @@ -94,12 +99,13 @@ processOneArg action rest arg args AnySuffixPred _ f -> Right (f dash_arg, args) -findArg :: [(String,OptKind a)] -> String -> Maybe (String,OptKind a) +findArg :: [Flag m] -> String -> Maybe (String, OptKind m) findArg spec arg - = case [ (removeSpaces rest, k) - | (pat,k) <- spec, - Just rest <- [maybePrefixMatch pat arg], - arg_ok k rest arg ] + = case [ (removeSpaces rest, optKind) + | flag <- spec, + let optKind = flagOptKind flag, + Just rest <- [maybePrefixMatch (flagName flag) arg], + arg_ok optKind rest arg ] of [] -> Nothing (one:_) -> Just one diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs index 052c138..a0ce114 100644 --- a/compiler/main/DriverMkDepend.hs +++ b/compiler/main/DriverMkDepend.hs @@ -395,17 +395,17 @@ depEndMarker = "# DO NOT DELETE: End of Haskell dependencies" -- for compatibility with the old mkDependHS, we accept options of the form -- -optdep-f -optdep.depend, etc. -dep_opts :: [(String, OptKind IO)] +dep_opts :: [Flag IO] dep_opts = - [ ( "s", SepArg (consIORef v_Dep_suffixes) ) - , ( "f", SepArg (writeIORef v_Dep_makefile) ) - , ( "w", NoArg (writeIORef v_Dep_warnings False) ) + [ Flag "s" (SepArg (consIORef v_Dep_suffixes)) + , Flag "f" (SepArg (writeIORef v_Dep_makefile)) + , Flag "w" (NoArg (writeIORef v_Dep_warnings False)) - , ( "-include-prelude", NoArg (writeIORef v_Dep_include_pkg_deps True) ) + , 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 - , ( "-include-pkg-deps", NoArg (writeIORef v_Dep_include_pkg_deps True) ) - , ( "-exclude-module=", Prefix (consIORef v_Dep_exclude_mods . mkModuleName) ) - , ( "x", Prefix (consIORef v_Dep_exclude_mods . mkModuleName) ) + , Flag "-include-pkg-deps" (NoArg (writeIORef v_Dep_include_pkg_deps True)) + , Flag "-exclude-module=" (Prefix (consIORef v_Dep_exclude_mods . mkModuleName)) + , Flag "x" (Prefix (consIORef v_Dep_exclude_mods . mkModuleName)) ] diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 2d24aac..a051916 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -1008,7 +1008,7 @@ getStgToDo dflags allFlags :: [String] allFlags = map ('-':) $ - [ name | (name, optkind) <- dynamic_flags, ok optkind ] ++ + [ flagName flag | flag <- dynamic_flags, ok (flagOptKind flag) ] ++ map ("fno-"++) flags ++ map ("f"++) flags ++ map ("X"++) xs ++ @@ -1018,240 +1018,246 @@ allFlags = map ('-':) $ flags = map fst fFlags xs = map fst xFlags -dynamic_flags :: [(String, OptKind DynP)] +dynamic_flags :: [Flag DynP] dynamic_flags = [ - ( "n" , NoArg (setDynFlag Opt_DryRun) ) - , ( "cpp" , NoArg (setDynFlag Opt_Cpp)) - , ( "F" , NoArg (setDynFlag Opt_Pp)) - , ( "#include" , HasArg (addCmdlineHCInclude) ) - , ( "v" , OptIntSuffix setVerbosity ) + 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) ------- Specific phases -------------------------------------------- - , ( "pgmL" , HasArg (upd . setPgmL) ) - , ( "pgmP" , HasArg (upd . setPgmP) ) - , ( "pgmF" , HasArg (upd . setPgmF) ) - , ( "pgmc" , HasArg (upd . setPgmc) ) - , ( "pgmm" , HasArg (upd . setPgmm) ) - , ( "pgms" , HasArg (upd . setPgms) ) - , ( "pgma" , HasArg (upd . setPgma) ) - , ( "pgml" , HasArg (upd . setPgml) ) - , ( "pgmdll" , HasArg (upd . setPgmdll) ) - , ( "pgmwindres" , HasArg (upd . setPgmwindres) ) - - , ( "optL" , HasArg (upd . addOptL) ) - , ( "optP" , HasArg (upd . addOptP) ) - , ( "optF" , HasArg (upd . addOptF) ) - , ( "optc" , HasArg (upd . addOptc) ) - , ( "optm" , HasArg (upd . addOptm) ) - , ( "opta" , HasArg (upd . addOpta) ) - , ( "optl" , HasArg (upd . addOptl) ) - , ( "optdep" , HasArg (upd . addOptdep) ) - , ( "optwindres" , HasArg (upd . addOptwindres) ) - - , ( "split-objs" , NoArg (if can_split - then setDynFlag Opt_SplitObjs - else return ()) ) + , 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 "split-objs" + (NoArg (if can_split then setDynFlag Opt_SplitObjs else return ())) -------- Linking ---------------------------------------------------- - , ( "c" , NoArg (upd $ \d -> d{ ghcLink=NoLink } )) - , ( "no-link" , NoArg (upd $ \d -> d{ ghcLink=NoLink } )) -- Dep. - , ( "shared" , NoArg (upd $ \d -> d{ ghcLink=LinkDynLib } )) - , ( "dynload" , HasArg (upd . parseDynLibLoaderMode)) + , Flag "c" (NoArg (upd $ \d -> d{ ghcLink=NoLink } )) + , Flag "no-link" (NoArg (upd $ \d -> d{ ghcLink=NoLink } )) -- Dep. + , Flag "shared" (NoArg (upd $ \d -> d{ ghcLink=LinkDynLib } )) + , Flag "dynload" (HasArg (upd . parseDynLibLoaderMode)) ------- Libraries --------------------------------------------------- - , ( "L" , Prefix addLibraryPath ) - , ( "l" , AnySuffix (\s -> do upd (addOptl s))) + , Flag "L" (Prefix addLibraryPath ) + , Flag "l" (AnySuffix (\s -> do upd (addOptl s))) ------- Frameworks -------------------------------------------------- -- -framework-path should really be -F ... - , ( "framework-path" , HasArg addFrameworkPath ) - , ( "framework" , HasArg (upd . addCmdlineFramework) ) + , Flag "framework-path" (HasArg addFrameworkPath ) + , Flag "framework" (HasArg (upd . addCmdlineFramework)) ------- Output Redirection ------------------------------------------ - , ( "odir" , HasArg (upd . setObjectDir)) - , ( "o" , SepArg (upd . setOutputFile . Just)) - , ( "ohi" , HasArg (upd . setOutputHi . Just )) - , ( "osuf" , HasArg (upd . setObjectSuf)) - , ( "hcsuf" , HasArg (upd . setHcSuf)) - , ( "hisuf" , HasArg (upd . setHiSuf)) - , ( "hidir" , HasArg (upd . setHiDir)) - , ( "tmpdir" , HasArg (upd . setTmpDir)) - , ( "stubdir" , HasArg (upd . setStubDir)) - , ( "ddump-file-prefix", HasArg (upd . setDumpPrefixForce . Just)) + , 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 "ddump-file-prefix" (HasArg (upd . setDumpPrefixForce . Just)) ------- Keeping temporary files ------------------------------------- -- 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)) + , 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)) -- This only makes sense as plural - , ( "keep-tmp-files" , NoArg (setDynFlag Opt_KeepTmpFiles)) + , Flag "keep-tmp-files" (NoArg (setDynFlag Opt_KeepTmpFiles)) ------- Miscellaneous ---------------------------------------------- - , ( "no-hs-main" , NoArg (setDynFlag Opt_NoHsMain)) - , ( "main-is" , SepArg setMainIs ) - , ( "haddock" , NoArg (setDynFlag Opt_Haddock) ) - , ( "haddock-opts" , HasArg (upd . addHaddockOpts)) - , ( "hpcdir" , SepArg setOptHpcDir ) + , 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) ------- recompilation checker (DEPRECATED, use -fforce-recomp) ----- - , ( "recomp" , NoArg (unSetDynFlag Opt_ForceRecomp) ) - , ( "no-recomp" , NoArg (setDynFlag Opt_ForceRecomp) ) + , Flag "recomp" (NoArg (unSetDynFlag Opt_ForceRecomp)) + , Flag "no-recomp" (NoArg (setDynFlag Opt_ForceRecomp)) ------- Packages ---------------------------------------------------- - , ( "package-conf" , HasArg extraPkgConf_ ) - , ( "no-user-package-conf", NoArg (unSetDynFlag Opt_ReadUserPackageConf) ) - , ( "package-name" , HasArg (upd . setPackageName) ) - , ( "package" , HasArg exposePackage ) - , ( "hide-package" , HasArg hidePackage ) - , ( "hide-all-packages", NoArg (setDynFlag Opt_HideAllPackages) ) - , ( "ignore-package" , HasArg ignorePackage ) - , ( "syslib" , HasArg exposePackage ) -- for compatibility + , Flag "package-conf" (HasArg extraPkgConf_) + , Flag "no-user-package-conf" (NoArg (unSetDynFlag Opt_ReadUserPackageConf)) + , Flag "package-name" (HasArg (upd . setPackageName)) + , Flag "package" (HasArg exposePackage) + , Flag "hide-package" (HasArg hidePackage) + , Flag "hide-all-packages" (NoArg (setDynFlag Opt_HideAllPackages)) + , Flag "ignore-package" (HasArg ignorePackage) + , Flag "syslib" (HasArg exposePackage) -- for compatibility ------ HsCpp opts --------------------------------------------------- - , ( "D", AnySuffix (upd . addOptP) ) - , ( "U", AnySuffix (upd . addOptP) ) + , Flag "D" (AnySuffix (upd . addOptP)) + , Flag "U" (AnySuffix (upd . addOptP)) ------- Include/Import Paths ---------------------------------------- - , ( "I" , Prefix addIncludePath) - , ( "i" , OptPrefix addImportPath ) + , Flag "I" (Prefix addIncludePath) + , Flag "i" (OptPrefix addImportPath ) ------ Debugging ---------------------------------------------------- - , ( "dstg-stats", NoArg (setDynFlag Opt_StgStats)) - - , ( "ddump-cmm", setDumpFlag Opt_D_dump_cmm) - , ( "ddump-cmmz", setDumpFlag Opt_D_dump_cmmz) - , ( "ddump-cmmz-pretty", setDumpFlag Opt_D_dump_cmmz_pretty) - , ( "ddump-cps-cmm", setDumpFlag Opt_D_dump_cps_cmm) - , ( "ddump-cvt-cmm", setDumpFlag Opt_D_dump_cvt_cmm) - , ( "ddump-asm", setDumpFlag Opt_D_dump_asm) - , ( "ddump-asm-native", setDumpFlag Opt_D_dump_asm_native) - , ( "ddump-asm-liveness", setDumpFlag Opt_D_dump_asm_liveness) - , ( "ddump-asm-coalesce", setDumpFlag Opt_D_dump_asm_coalesce) - , ( "ddump-asm-regalloc", setDumpFlag Opt_D_dump_asm_regalloc) - , ( "ddump-asm-conflicts", setDumpFlag Opt_D_dump_asm_conflicts) - , ( "ddump-asm-regalloc-stages", - setDumpFlag Opt_D_dump_asm_regalloc_stages) - , ( "ddump-asm-stats", setDumpFlag Opt_D_dump_asm_stats) - , ( "ddump-cpranal", setDumpFlag Opt_D_dump_cpranal) - , ( "ddump-deriv", setDumpFlag Opt_D_dump_deriv) - , ( "ddump-ds", setDumpFlag Opt_D_dump_ds) - , ( "ddump-flatC", setDumpFlag Opt_D_dump_flatC) - , ( "ddump-foreign", setDumpFlag Opt_D_dump_foreign) - , ( "ddump-inlinings", setDumpFlag Opt_D_dump_inlinings) - , ( "ddump-rule-firings", setDumpFlag Opt_D_dump_rule_firings) - , ( "ddump-occur-anal", setDumpFlag Opt_D_dump_occur_anal) - , ( "ddump-parsed", setDumpFlag Opt_D_dump_parsed) - , ( "ddump-rn", setDumpFlag Opt_D_dump_rn) - , ( "ddump-simpl", setDumpFlag Opt_D_dump_simpl) - , ( "ddump-simpl-iterations", setDumpFlag Opt_D_dump_simpl_iterations) - , ( "ddump-simpl-phases", OptPrefix setDumpSimplPhases) - , ( "ddump-spec", setDumpFlag Opt_D_dump_spec) - , ( "ddump-prep", setDumpFlag Opt_D_dump_prep) - , ( "ddump-stg", setDumpFlag Opt_D_dump_stg) - , ( "ddump-stranal", setDumpFlag Opt_D_dump_stranal) - , ( "ddump-tc", setDumpFlag Opt_D_dump_tc) - , ( "ddump-types", setDumpFlag Opt_D_dump_types) - , ( "ddump-rules", setDumpFlag Opt_D_dump_rules) - , ( "ddump-cse", setDumpFlag Opt_D_dump_cse) - , ( "ddump-worker-wrapper", setDumpFlag Opt_D_dump_worker_wrapper) - , ( "ddump-rn-trace", setDumpFlag Opt_D_dump_rn_trace) - , ( "ddump-if-trace", setDumpFlag Opt_D_dump_if_trace) - , ( "ddump-tc-trace", setDumpFlag Opt_D_dump_tc_trace) - , ( "ddump-splices", setDumpFlag Opt_D_dump_splices) - , ( "ddump-rn-stats", setDumpFlag Opt_D_dump_rn_stats) - , ( "ddump-opt-cmm", setDumpFlag Opt_D_dump_opt_cmm) - , ( "ddump-simpl-stats", setDumpFlag Opt_D_dump_simpl_stats) - , ( "ddump-bcos", setDumpFlag Opt_D_dump_BCOs) - , ( "dsource-stats", setDumpFlag Opt_D_source_stats) - , ( "dverbose-core2core", NoArg setVerboseCore2Core) - , ( "dverbose-stg2stg", setDumpFlag Opt_D_verbose_stg2stg) - , ( "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-view-pattern-commoning", setDumpFlag Opt_D_dump_view_pattern_commoning) - , ( "ddump-to-file", setDumpFlag Opt_DumpToFile) - , ( "ddump-hi-diffs", setDumpFlag Opt_D_dump_hi_diffs) - - , ( "dcore-lint", NoArg (setDynFlag Opt_DoCoreLinting)) - , ( "dstg-lint", NoArg (setDynFlag Opt_DoStgLinting)) - , ( "dcmm-lint", NoArg (setDynFlag Opt_DoCmmLinting)) - , ( "dasm-lint", NoArg (setDynFlag Opt_DoAsmLinting)) - , ( "dshow-passes", NoArg (do setDynFlag Opt_ForceRecomp - setVerbosity (Just 2)) ) - , ( "dfaststring-stats", NoArg (setDynFlag Opt_D_faststring_stats)) + , Flag "dstg-stats" (NoArg (setDynFlag Opt_StgStats)) + + , Flag "ddump-cmm" (setDumpFlag Opt_D_dump_cmm) + , Flag "ddump-cmmz" (setDumpFlag Opt_D_dump_cmmz) + , Flag "ddump-cmmz-pretty" (setDumpFlag Opt_D_dump_cmmz_pretty) + , Flag "ddump-cps-cmm" (setDumpFlag Opt_D_dump_cps_cmm) + , Flag "ddump-cvt-cmm" (setDumpFlag Opt_D_dump_cvt_cmm) + , Flag "ddump-asm" (setDumpFlag Opt_D_dump_asm) + , Flag "ddump-asm-native" (setDumpFlag Opt_D_dump_asm_native) + , Flag "ddump-asm-liveness" (setDumpFlag Opt_D_dump_asm_liveness) + , Flag "ddump-asm-coalesce" (setDumpFlag Opt_D_dump_asm_coalesce) + , Flag "ddump-asm-regalloc" (setDumpFlag Opt_D_dump_asm_regalloc) + , Flag "ddump-asm-conflicts" (setDumpFlag Opt_D_dump_asm_conflicts) + , Flag "ddump-asm-regalloc-stages" + (setDumpFlag Opt_D_dump_asm_regalloc_stages) + , Flag "ddump-asm-stats" (setDumpFlag Opt_D_dump_asm_stats) + , Flag "ddump-cpranal" (setDumpFlag Opt_D_dump_cpranal) + , Flag "ddump-deriv" (setDumpFlag Opt_D_dump_deriv) + , Flag "ddump-ds" (setDumpFlag Opt_D_dump_ds) + , Flag "ddump-flatC" (setDumpFlag Opt_D_dump_flatC) + , 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-occur-anal" (setDumpFlag Opt_D_dump_occur_anal) + , Flag "ddump-parsed" (setDumpFlag Opt_D_dump_parsed) + , Flag "ddump-rn" (setDumpFlag Opt_D_dump_rn) + , Flag "ddump-simpl" (setDumpFlag Opt_D_dump_simpl) + , Flag "ddump-simpl-iterations" (setDumpFlag Opt_D_dump_simpl_iterations) + , Flag "ddump-simpl-phases" (OptPrefix setDumpSimplPhases) + , Flag "ddump-spec" (setDumpFlag Opt_D_dump_spec) + , Flag "ddump-prep" (setDumpFlag Opt_D_dump_prep) + , Flag "ddump-stg" (setDumpFlag Opt_D_dump_stg) + , Flag "ddump-stranal" (setDumpFlag Opt_D_dump_stranal) + , Flag "ddump-tc" (setDumpFlag Opt_D_dump_tc) + , Flag "ddump-types" (setDumpFlag Opt_D_dump_types) + , Flag "ddump-rules" (setDumpFlag Opt_D_dump_rules) + , Flag "ddump-cse" (setDumpFlag Opt_D_dump_cse) + , Flag "ddump-worker-wrapper" (setDumpFlag Opt_D_dump_worker_wrapper) + , Flag "ddump-rn-trace" (setDumpFlag Opt_D_dump_rn_trace) + , Flag "ddump-if-trace" (setDumpFlag Opt_D_dump_if_trace) + , Flag "ddump-tc-trace" (setDumpFlag Opt_D_dump_tc_trace) + , Flag "ddump-splices" (setDumpFlag Opt_D_dump_splices) + , Flag "ddump-rn-stats" (setDumpFlag Opt_D_dump_rn_stats) + , Flag "ddump-opt-cmm" (setDumpFlag Opt_D_dump_opt_cmm) + , Flag "ddump-simpl-stats" (setDumpFlag Opt_D_dump_simpl_stats) + , Flag "ddump-bcos" (setDumpFlag Opt_D_dump_BCOs) + , Flag "dsource-stats" (setDumpFlag Opt_D_source_stats) + , Flag "dverbose-core2core" (NoArg setVerboseCore2Core) + , Flag "dverbose-stg2stg" (setDumpFlag Opt_D_verbose_stg2stg) + , Flag "ddump-hi" (setDumpFlag Opt_D_dump_hi) + , Flag "ddump-minimal-imports" (setDumpFlag Opt_D_dump_minimal_imports) + , Flag "ddump-vect" (setDumpFlag Opt_D_dump_vect) + , Flag "ddump-hpc" (setDumpFlag Opt_D_dump_hpc) + , Flag "ddump-mod-cycles" (setDumpFlag Opt_D_dump_mod_cycles) + , Flag "ddump-view-pattern-commoning" (setDumpFlag Opt_D_dump_view_pattern_commoning) + , Flag "ddump-to-file" (setDumpFlag Opt_DumpToFile) + , Flag "ddump-hi-diffs" (setDumpFlag Opt_D_dump_hi_diffs) + + , Flag "dcore-lint" (NoArg (setDynFlag Opt_DoCoreLinting)) + , Flag "dstg-lint" (NoArg (setDynFlag Opt_DoStgLinting)) + , Flag "dcmm-lint" (NoArg (setDynFlag Opt_DoCmmLinting)) + , Flag "dasm-lint" (NoArg (setDynFlag Opt_DoAsmLinting)) + , Flag "dshow-passes" + (NoArg (do setDynFlag Opt_ForceRecomp + setVerbosity (Just 2))) + , Flag "dfaststring-stats" (NoArg (setDynFlag Opt_D_faststring_stats)) ------ Machine dependant (-m) stuff --------------------------- - , ( "monly-2-regs", NoArg (upd (\s -> s{stolen_x86_regs = 2}) )) - , ( "monly-3-regs", NoArg (upd (\s -> s{stolen_x86_regs = 3}) )) - , ( "monly-4-regs", NoArg (upd (\s -> s{stolen_x86_regs = 4}) )) + , Flag "monly-2-regs" (NoArg (upd (\s -> s{stolen_x86_regs = 2}) )) + , Flag "monly-3-regs" (NoArg (upd (\s -> s{stolen_x86_regs = 3}) )) + , Flag "monly-4-regs" (NoArg (upd (\s -> s{stolen_x86_regs = 4}) )) ------ Warning opts ------------------------------------------------- - , ( "W" , NoArg (mapM_ setDynFlag minusWOpts) ) - , ( "Werror", NoArg (setDynFlag Opt_WarnIsError) ) - , ( "Wwarn" , NoArg (unSetDynFlag Opt_WarnIsError) ) - , ( "Wall" , NoArg (mapM_ setDynFlag minusWallOpts) ) - , ( "Wnot" , NoArg (mapM_ unSetDynFlag minusWallOpts) ) -- DEPRECATED - , ( "w" , NoArg (mapM_ unSetDynFlag minuswRemovesOpts) ) + , Flag "W" (NoArg (mapM_ setDynFlag minusWOpts)) + , Flag "Werror" (NoArg (setDynFlag Opt_WarnIsError)) + , Flag "Wwarn" (NoArg (unSetDynFlag Opt_WarnIsError)) + , Flag "Wall" (NoArg (mapM_ setDynFlag minusWallOpts)) + , Flag "Wnot" (NoArg (mapM_ unSetDynFlag minusWallOpts)) -- DEPRECATED + , Flag "w" (NoArg (mapM_ unSetDynFlag minuswRemovesOpts)) ------ Optimisation flags ------------------------------------------ - , ( "O" , NoArg (upd (setOptLevel 1))) - , ( "Onot" , NoArg (upd (setOptLevel 0))) -- deprecated - , ( "Odph" , NoArg (upd setDPHOpt)) - , ( "O" , OptIntSuffix (\mb_n -> upd (setOptLevel (mb_n `orElse` 1)))) + , Flag "O" (NoArg (upd (setOptLevel 1))) + , Flag "Onot" (NoArg (upd (setOptLevel 0))) -- deprecated + , Flag "Odph" (NoArg (upd setDPHOpt)) + , Flag "O" (OptIntSuffix (\mb_n -> upd (setOptLevel (mb_n `orElse` 1)))) -- If the number is missing, use 1 - , ( "fsimplifier-phases", IntSuffix (\n -> - upd (\dfs -> dfs{ simplPhases = n })) ) - , ( "fmax-simplifier-iterations", IntSuffix (\n -> - upd (\dfs -> dfs{ maxSimplIterations = n })) ) - - , ( "fspec-constr-threshold", IntSuffix (\n -> - upd (\dfs -> dfs{ specConstrThreshold = Just n }))) - , ( "fno-spec-constr-threshold", NoArg ( - upd (\dfs -> dfs{ specConstrThreshold = Nothing }))) - , ( "fspec-constr-count", IntSuffix (\n -> - upd (\dfs -> dfs{ specConstrCount = Just n }))) - , ( "fno-spec-constr-count", NoArg ( - upd (\dfs -> dfs{ specConstrCount = Nothing }))) - , ( "fliberate-case-threshold", IntSuffix (\n -> - upd (\dfs -> dfs{ liberateCaseThreshold = Just n }))) - , ( "fno-liberate-case-threshold", NoArg ( - upd (\dfs -> dfs{ liberateCaseThreshold = Nothing }))) - - , ( "frule-check", SepArg (\s -> upd (\dfs -> dfs{ ruleCheck = Just s }))) - , ( "fcontext-stack" , IntSuffix $ \n -> upd $ \dfs -> dfs{ ctxtStkDepth = n }) + , Flag "fsimplifier-phases" + (IntSuffix (\n -> upd (\dfs -> dfs{ simplPhases = n }))) + , Flag "fmax-simplifier-iterations" + (IntSuffix (\n -> upd (\dfs -> dfs{ maxSimplIterations = n }))) + + , Flag "fspec-constr-threshold" + (IntSuffix (\n -> upd (\dfs -> dfs{ specConstrThreshold = Just n }))) + , Flag "fno-spec-constr-threshold" + (NoArg (upd (\dfs -> dfs{ specConstrThreshold = Nothing }))) + , Flag "fspec-constr-count" + (IntSuffix (\n -> upd (\dfs -> dfs{ specConstrCount = Just n }))) + , Flag "fno-spec-constr-count" + (NoArg (upd (\dfs -> dfs{ specConstrCount = Nothing }))) + , Flag "fliberate-case-threshold" + (IntSuffix (\n -> upd (\dfs -> dfs{ liberateCaseThreshold = Just n }))) + , Flag "fno-liberate-case-threshold" + (NoArg (upd (\dfs -> dfs{ liberateCaseThreshold = Nothing }))) + + , Flag "frule-check" + (SepArg (\s -> upd (\dfs -> dfs{ ruleCheck = Just s }))) + , Flag "fcontext-stack" + (IntSuffix $ \n -> upd $ \dfs -> dfs{ ctxtStkDepth = n }) ------ Compiler flags ----------------------------------------------- - , ( "fasm", NoArg (setObjTarget HscAsm) ) - , ( "fvia-c", NoArg (setObjTarget HscC) ) - , ( "fvia-C", NoArg (setObjTarget HscC) ) + , Flag "fasm" (NoArg (setObjTarget HscAsm)) + , Flag "fvia-c" (NoArg (setObjTarget HscC)) + , Flag "fvia-C" (NoArg (setObjTarget HscC)) - , ( "fno-code", NoArg (setTarget HscNothing)) - , ( "fbyte-code", NoArg (setTarget HscInterpreted) ) - , ( "fobject-code", NoArg (setTarget defaultHscTarget) ) + , Flag "fno-code" (NoArg (setTarget HscNothing)) + , Flag "fbyte-code" (NoArg (setTarget HscInterpreted)) + , Flag "fobject-code" (NoArg (setTarget defaultHscTarget)) - , ( "fglasgow-exts", NoArg (mapM_ setDynFlag glasgowExtsFlags) ) - , ( "fno-glasgow-exts", NoArg (mapM_ unSetDynFlag glasgowExtsFlags) ) + , Flag "fglasgow-exts" (NoArg (mapM_ setDynFlag glasgowExtsFlags)) + , Flag "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 (isPrefFlag "no-" fFlags) - (\f -> unSetDynFlag (getPrefFlag "no-" fFlags f)) ) + , Flag "f" + (PrefixPred (isFlag fFlags) + (\f -> setDynFlag (getFlag fFlags f))) + , Flag "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)) ) + , Flag "X" + (PrefixPred (isFlag xFlags) + (\f -> setDynFlag (getFlag xFlags f))) + , Flag "X" + (PrefixPred (isPrefFlag "No" xFlags) + (\f -> unSetDynFlag (getPrefFlag "No" xFlags f))) ] -- these -f flags can all be reversed with -fno- diff --git a/compiler/main/Main.hs b/compiler/main/Main.hs index f0a6611..57cf28e 100644 --- a/compiler/main/Main.hs +++ b/compiler/main/Main.hs @@ -367,36 +367,36 @@ type ModeM a = CmdLineP (CmdLineMode, String, [String]) a -- mode flags sometimes give rise to new DynFlags (eg. -C, see below) -- so we collect the new ones and return them. -mode_flags :: [(String, OptKind (CmdLineP (CmdLineMode, String, [String])))] +mode_flags :: [Flag (CmdLineP (CmdLineMode, String, [String]))] mode_flags = [ ------- help / version ---------------------------------------------- - ( "?" , PassFlag (setMode ShowUsage)) - , ( "-help" , PassFlag (setMode ShowUsage)) - , ( "-print-libdir" , PassFlag (setMode PrintLibdir)) - , ( "V" , PassFlag (setMode ShowVersion)) - , ( "-version" , PassFlag (setMode ShowVersion)) - , ( "-numeric-version" , PassFlag (setMode ShowNumVersion)) - , ( "-info" , PassFlag (setMode ShowInfo)) - , ( "-supported-languages", PassFlag (setMode ShowSupportedLanguages)) + Flag "?" (PassFlag (setMode ShowUsage)) + , Flag "-help" (PassFlag (setMode ShowUsage)) + , Flag "-print-libdir" (PassFlag (setMode PrintLibdir)) + , Flag "V" (PassFlag (setMode ShowVersion)) + , Flag "-version" (PassFlag (setMode ShowVersion)) + , Flag "-numeric-version" (PassFlag (setMode ShowNumVersion)) + , Flag "-info" (PassFlag (setMode ShowInfo)) + , Flag "-supported-languages" (PassFlag (setMode ShowSupportedLanguages)) ------- interfaces ---------------------------------------------------- - , ( "-show-iface" , HasArg (\f -> setMode (ShowInterface f) - "--show-iface")) + , Flag "-show-iface" (HasArg (\f -> setMode (ShowInterface f) + "--show-iface")) ------- primary modes ------------------------------------------------ - , ( "M" , PassFlag (setMode DoMkDependHS)) - , ( "E" , PassFlag (setMode (StopBefore anyHsc))) - , ( "C" , PassFlag (\f -> do setMode (StopBefore HCc) f - addFlag "-fvia-C")) - , ( "S" , PassFlag (setMode (StopBefore As))) - , ( "-make" , PassFlag (setMode DoMake)) - , ( "-interactive" , PassFlag (setMode DoInteractive)) - , ( "e" , HasArg (\s -> updateMode (updateDoEval s) "-e")) + , Flag "M" (PassFlag (setMode DoMkDependHS)) + , Flag "E" (PassFlag (setMode (StopBefore anyHsc))) + , Flag "C" (PassFlag (\f -> do setMode (StopBefore HCc) f + addFlag "-fvia-C")) + , Flag "S" (PassFlag (setMode (StopBefore As))) + , Flag "-make" (PassFlag (setMode DoMake)) + , Flag "-interactive" (PassFlag (setMode DoInteractive)) + , Flag "e" (HasArg (\s -> updateMode (updateDoEval s) "-e")) -- -fno-code says to stop after Hsc but don't generate any code. - , ( "fno-code" , PassFlag (\f -> do setMode (StopBefore HCc) f - addFlag "-fno-code" - addFlag "-no-recomp")) + , Flag "fno-code" (PassFlag (\f -> do setMode (StopBefore HCc) f + addFlag "-fno-code" + addFlag "-no-recomp")) ] setMode :: CmdLineMode -> String -> ModeM () diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index 6d826cb..dd5754c 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -133,7 +133,7 @@ parseStaticFlags args = do initStaticOpts :: IO () initStaticOpts = writeIORef v_opt_C_ready True -static_flags :: [(String, OptKind IO)] +static_flags :: [Flag IO] -- All the static flags should appear in this list. It describes how each -- static flag should be processed. Two main purposes: -- (a) if a command-line flag doesn't appear in the list, GHC can complain @@ -148,55 +148,55 @@ static_flags :: [(String, OptKind IO)] -- flags further down the list with the same prefix. static_flags = [ - ------- GHCi ------------------------------------------------------- - ( "ignore-dot-ghci", PassFlag addOpt ) - , ( "read-dot-ghci" , NoArg (removeOpt "-ignore-dot-ghci") ) - - ------- ways -------------------------------------------------------- - , ( "prof" , NoArg (addWay WayProf) ) - , ( "ticky" , NoArg (addWay WayTicky) ) - , ( "parallel" , NoArg (addWay WayPar) ) - , ( "gransim" , NoArg (addWay WayGran) ) - , ( "smp" , NoArg (addWay WayThreaded) ) -- backwards compat. - , ( "debug" , NoArg (addWay WayDebug) ) - , ( "ndp" , NoArg (addWay WayNDP) ) - , ( "threaded" , NoArg (addWay WayThreaded) ) - -- ToDo: user ways - - ------ Debugging ---------------------------------------------------- - , ( "dppr-debug", PassFlag addOpt ) - , ( "dsuppress-uniques", PassFlag addOpt ) - , ( "dppr-user-length", AnySuffix addOpt ) - , ( "dopt-fuel", AnySuffix addOpt ) - , ( "dno-debug-output", PassFlag addOpt ) + ------- GHCi ------------------------------------------------------- + Flag "ignore-dot-ghci" (PassFlag addOpt) + , Flag "read-dot-ghci" (NoArg (removeOpt "-ignore-dot-ghci")) + + ------- 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)) + -- 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) -- rest of the debugging flags are dynamic - --------- Profiling -------------------------------------------------- - , ( "auto-all" , NoArg (addOpt "-fauto-sccs-on-all-toplevs") ) - , ( "auto" , NoArg (addOpt "-fauto-sccs-on-exported-toplevs") ) - , ( "caf-all" , NoArg (addOpt "-fauto-sccs-on-individual-cafs") ) + --------- Profiling -------------------------------------------------- + , Flag "auto-all" (NoArg (addOpt "-fauto-sccs-on-all-toplevs")) + , Flag "auto" (NoArg (addOpt "-fauto-sccs-on-exported-toplevs")) + , Flag "caf-all" (NoArg (addOpt "-fauto-sccs-on-individual-cafs")) -- "ignore-sccs" doesn't work (ToDo) - , ( "no-auto-all" , NoArg (removeOpt "-fauto-sccs-on-all-toplevs") ) - , ( "no-auto" , NoArg (removeOpt "-fauto-sccs-on-exported-toplevs") ) - , ( "no-caf-all" , NoArg (removeOpt "-fauto-sccs-on-individual-cafs") ) + , Flag "no-auto-all" (NoArg (removeOpt "-fauto-sccs-on-all-toplevs")) + , Flag "no-auto" (NoArg (removeOpt "-fauto-sccs-on-exported-toplevs")) + , Flag "no-caf-all" (NoArg (removeOpt "-fauto-sccs-on-individual-cafs")) - ----- Linker -------------------------------------------------------- - , ( "static" , PassFlag addOpt ) - , ( "dynamic" , NoArg (removeOpt "-static") ) - , ( "rdynamic" , NoArg (return ()) ) -- ignored for compat w/ gcc + ----- Linker -------------------------------------------------------- + , Flag "static" (PassFlag addOpt) + , Flag "dynamic" (NoArg (removeOpt "-static")) + , Flag "rdynamic" (NoArg (return ())) -- ignored for compat w/ gcc - ----- RTS opts ------------------------------------------------------ - , ( "H" , HasArg (setHeapSize . fromIntegral . decodeSize) ) - , ( "Rghc-timing" , NoArg (enableTimingStats) ) + ----- RTS opts ------------------------------------------------------ + , Flag "H" (HasArg (setHeapSize . fromIntegral . decodeSize)) + , Flag "Rghc-timing" (NoArg (enableTimingStats)) ------ Compiler flags ----------------------------------------------- - -- All other "-fno-" options cancel out "-f" on the hsc cmdline - , ( "fno-", PrefixPred (\s -> isStaticFlag ("f"++s)) - (\s -> removeOpt ("-f"++s)) ) + -- All other "-fno-" options cancel out "-f" on the hsc cmdline + , Flag "fno-" + (PrefixPred (\s -> isStaticFlag ("f"++s)) (\s -> removeOpt ("-f"++s))) - -- Pass all remaining "-f" options to hsc - , ( "f", AnySuffixPred (isStaticFlag) addOpt ) + -- Pass all remaining "-f" options to hsc + , Flag "f" (AnySuffixPred (isStaticFlag) addOpt) ] addOpt :: String -> IO ()