X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FCmdLineOpts.lhs;h=fa3c878a97aeefa751ccde326f918e129f861a19;hb=ae31748ee4ef1a5e094664eb107cf843b8aee319;hp=99169c1a5cf9892d616fd28e0b2bca720acaa155;hpb=26741ec416bae2c502ef00a2ba0e79050a32cb67;p=ghc-hetmet.git diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 99169c1..fa3c878 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -4,8 +4,6 @@ \section[CmdLineOpts]{Things to do with command-line options} \begin{code} -#include "HsVersions.h" - module CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), @@ -17,16 +15,14 @@ module CmdLineOpts ( switchIsOn, maybe_CompilingGhcInternals, - opt_AllDemanded, opt_AllStrict, + opt_AllowOverlappingInstances, opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs, opt_AutoSccsOnIndividualCafs, opt_CompilingGhcInternals, - opt_UsingGhcInternals, opt_D_dump_absC, opt_D_dump_asm, - opt_D_dump_deforest, opt_D_dump_deriv, opt_D_dump_ds, opt_D_dump_flatC, @@ -35,40 +31,42 @@ module CmdLineOpts ( opt_D_dump_realC, opt_D_dump_rn, opt_D_dump_simpl, + opt_D_dump_simpl_iterations, opt_D_dump_spec, opt_D_dump_stg, opt_D_dump_stranal, opt_D_dump_tc, opt_D_show_passes, + opt_D_show_rn_trace, + opt_D_show_rn_imports, opt_D_simplifier_stats, opt_D_source_stats, opt_D_verbose_core2core, opt_D_verbose_stg2stg, opt_DoCoreLinting, + opt_DoStgLinting, opt_DoSemiTagging, + opt_DoEtaReduction, opt_DoTickyProfiling, opt_EnsureSplittableC, opt_FoldrBuildOn, - opt_FoldrBuildTrace, opt_ForConcurrent, opt_GlasgowExts, opt_GranMacros, - opt_Haskell_1_3, opt_HiMap, - opt_HideBuiltinNames, - opt_HideMostBuiltinNames, opt_IgnoreIfacePragmas, - opt_IgnoreStrictnessPragmas, - opt_IrrefutableEverything, opt_IrrefutableTuples, + opt_LiberateCaseThreshold, + opt_MultiParamClasses, + opt_NoHiCheck, opt_NoImplicitPrelude, opt_NumbersStrict, opt_OmitBlackHoling, - opt_OmitDefaultInstanceMethods, opt_OmitInterfacePragmas, opt_PprStyle_All, opt_PprStyle_Debug, - opt_PprStyle_User, + opt_PprStyle_User, -- ToDo: rm + opt_PprUserLength, opt_ProduceC, opt_ProduceHi, opt_ProduceS, @@ -77,29 +75,51 @@ module CmdLineOpts ( opt_SccGroup, opt_SccProfilingOn, opt_ShowImportSpecs, - opt_ShowPragmaNameErrs, opt_SigsRequired, + opt_SourceUnchanged, opt_SpecialiseAll, opt_SpecialiseImports, opt_SpecialiseOverloaded, opt_SpecialiseTrace, opt_SpecialiseUnboxed, opt_StgDoLetNoEscapes, + + opt_InterfaceUnfoldThreshold, opt_UnfoldingCreationThreshold, - opt_UnfoldingOverrideThreshold, + opt_UnfoldingConDiscount, opt_UnfoldingUseThreshold, + opt_UnfoldingKeenessFactor, + opt_Verbose, - opt_WarnNameShadowing + opt_WarnNameShadowing, + opt_WarnUnusedMatches, + opt_WarnUnusedBinds, + opt_WarnUnusedImports, + opt_WarnIncompletePatterns, + opt_WarnOverlappingPatterns, + opt_WarnSimplePatterns, + opt_WarnMissingMethods, + opt_WarnDuplicateExports, + opt_WarnHiShadows, + opt_PruneTyDecls, opt_PruneInstDecls, + opt_D_show_rn_stats ) where -IMPORT_1_3(Array(array, (//))) -import PreludeGlaST -- bad bad bad boy, Will (_Array internals) -import Argv +#include "HsVersions.h" -CHK_Ubiq() -- debugging consistency check +import Array ( array, (//) ) +import GlaExts +import Argv +import Constants -- Default values for some flags import Maybes ( assocMaybe, firstJust, maybeToBool ) -import Util ( startsWith, panic, panic#, assertPanic ) +import Util ( startsWith, panic, panic# ) + +#if __GLASGOW_HASKELL__ < 301 +import ArrBase ( Array(..) ) +#else +import PrelArr ( Array(..) ) +#endif \end{code} A command-line {\em switch} is (generally) either on or off; e.g., the @@ -147,7 +167,6 @@ data CoreToDo -- These are diff core-to-core passes, | CoreDoStaticArgs | CoreDoStrictness | CoreDoSpecialising - | CoreDoDeforest | CoreDoFoldrBuildWorkerWrapper | CoreDoFoldrBuildWWAnal \end{code} @@ -184,7 +203,6 @@ data SimplifierSwitch | IgnoreINLINEPragma | SimplDoLambdaEtaExpansion - | SimplDoEtaReduction | EssentialUnfoldingsOnly -- never mind the thresholds, only -- do unfoldings that *must* be done @@ -194,12 +212,6 @@ data SimplifierSwitch | MaxSimplifierIterations Int - | SimplUnfoldingUseThreshold Int -- per-simplification variants - | SimplUnfoldingCreationThreshold Int - - | KeepSpecPragmaIds -- We normally *toss* Ids we can do without - | KeepUnusedBindings - | SimplNoLetFromCase -- used when turning off floating entirely | SimplNoLetFromApp -- (for experimentation only) WDP 95/10 | SimplNoLetFromStrictLet @@ -214,6 +226,18 @@ data SimplifierSwitch -- Oops! -- So only use this flag inside List.hs -- (Sigh, what a HACK, Andy. WDP 96/01) + + | SimplCaseMerge + | SimplCaseScrutinee -- This flag tells that the expression being simplified is + -- the scrutinee of a case expression, so we should + -- apply the scrutinee discount when considering inlinings. + -- See SimplVar.lhs + + | SimplCloneBinds -- This flag controls whether the simplifier should + -- always clone binder ids when creating expression + -- copies. The default is NO, but it needs to be turned on + -- prior to floating binders outwards. + -- (see comment inside SimplVar.simplBinder) \end{code} %************************************************************************ @@ -223,9 +247,11 @@ data SimplifierSwitch %************************************************************************ \begin{code} -lookUp :: FAST_STRING -> Bool -lookup_int :: String -> Maybe Int -lookup_str :: String -> Maybe String +lookUp :: FAST_STRING -> Bool +lookup_int :: String -> Maybe Int +lookup_def_int :: String -> Int -> Int +lookup_def_float :: String -> Float -> Float +lookup_str :: String -> Maybe String lookUp sw = maybeToBool (assoc_opts sw) @@ -235,19 +261,46 @@ lookup_int sw = case (lookup_str sw) of Nothing -> Nothing Just xx -> Just (read xx) +lookup_def_int sw def = case (lookup_str sw) of + Nothing -> def -- Use default + Just xx -> read xx + +lookup_def_float sw def = case (lookup_str sw) of + Nothing -> def -- Use default + Just xx -> read xx + assoc_opts = assocMaybe [ (a, True) | a <- argv ] unpacked_opts = map _UNPK_ argv + +{- + Putting the compiler options into temporary at-files + may turn out to be necessary later on if we turn hsc into + a pure Win32 application where I think there's a command-line + length limit of 255. unpacked_opts understands the @ option. + +assoc_opts = assocMaybe [ (_PK_ a, True) | a <- unpacked_opts ] + +unpacked_opts :: [String] +unpacked_opts = + concat $ + map (expandAts) $ + map _UNPK_ argv + where + expandAts ('@':fname) = words (unsafePerformIO (readFile fname)) + expandAts l = [l] +-} \end{code} \begin{code} -opt_AllDemanded = lookUp SLIT("-fall-demanded") opt_AllStrict = lookUp SLIT("-fall-strict") +opt_AllowOverlappingInstances = lookUp SLIT("-fallow-overlapping-instances") opt_AutoSccsOnAllToplevs = lookUp SLIT("-fauto-sccs-on-all-toplevs") opt_AutoSccsOnExportedToplevs = lookUp SLIT("-fauto-sccs-on-exported-toplevs") opt_AutoSccsOnIndividualCafs = lookUp SLIT("-fauto-sccs-on-individual-cafs") +opt_CompilingGhcInternals = maybeToBool maybe_CompilingGhcInternals +maybe_CompilingGhcInternals = lookup_str "-fcompiling-ghc-internals=" opt_D_dump_absC = lookUp SLIT("-ddump-absC") opt_D_dump_asm = lookUp SLIT("-ddump-asm") -opt_D_dump_deforest = lookUp SLIT("-ddump-deforest") opt_D_dump_deriv = lookUp SLIT("-ddump-deriv") opt_D_dump_ds = lookUp SLIT("-ddump-ds") opt_D_dump_flatC = lookUp SLIT("-ddump-flatC") @@ -256,65 +309,81 @@ opt_D_dump_rdr = lookUp SLIT("-ddump-rdr") opt_D_dump_realC = lookUp SLIT("-ddump-realC") opt_D_dump_rn = lookUp SLIT("-ddump-rn") opt_D_dump_simpl = lookUp SLIT("-ddump-simpl") +opt_D_dump_simpl_iterations = lookUp SLIT("-ddump-simpl-iterations") opt_D_dump_spec = lookUp SLIT("-ddump-spec") opt_D_dump_stg = lookUp SLIT("-ddump-stg") opt_D_dump_stranal = lookUp SLIT("-ddump-stranal") opt_D_dump_tc = lookUp SLIT("-ddump-tc") opt_D_show_passes = lookUp SLIT("-dshow-passes") +opt_D_show_rn_trace = lookUp SLIT("-dshow-rn-trace") +opt_D_show_rn_imports = lookUp SLIT("-dshow-rn-imports") opt_D_simplifier_stats = lookUp SLIT("-dsimplifier-stats") opt_D_source_stats = lookUp SLIT("-dsource-stats") opt_D_verbose_core2core = lookUp SLIT("-dverbose-simpl") opt_D_verbose_stg2stg = lookUp SLIT("-dverbose-stg") opt_DoCoreLinting = lookUp SLIT("-dcore-lint") +opt_DoStgLinting = lookUp SLIT("-dstg-lint") opt_DoSemiTagging = lookUp SLIT("-fsemi-tagging") opt_DoTickyProfiling = lookUp SLIT("-fticky-ticky") +opt_DoEtaReduction = lookUp SLIT("-fdo-eta-reduction") +opt_EnsureSplittableC = lookUp SLIT("-fglobalise-toplev-names") opt_FoldrBuildOn = lookUp SLIT("-ffoldr-build-on") -opt_FoldrBuildTrace = lookUp SLIT("-ffoldr-build-trace") opt_ForConcurrent = lookUp SLIT("-fconcurrent") opt_GranMacros = lookUp SLIT("-fgransim") opt_GlasgowExts = lookUp SLIT("-fglasgow-exts") -opt_Haskell_1_3 = lookUp SLIT("-fhaskell-1.3") -opt_HideBuiltinNames = lookUp SLIT("-fhide-builtin-names") -opt_HideMostBuiltinNames = lookUp SLIT("-fmin-builtin-names") -opt_IgnoreStrictnessPragmas = lookUp SLIT("-fignore-strictness-pragmas") -opt_IrrefutableEverything = lookUp SLIT("-firrefutable-everything") +opt_HiMap = lookup_str "-himap=" -- file saying where to look for .hi files +opt_IgnoreIfacePragmas = lookUp SLIT("-fignore-interface-pragmas") opt_IrrefutableTuples = lookUp SLIT("-firrefutable-tuples") -opt_WarnNameShadowing = lookUp SLIT("-fwarn-name-shadowing") +opt_MultiParamClasses = opt_GlasgowExts +opt_NoImplicitPrelude = lookUp SLIT("-fno-implicit-prelude") +opt_NoHiCheck = lookUp SLIT("-fno-hi-version-check") opt_NumbersStrict = lookUp SLIT("-fnumbers-strict") opt_OmitBlackHoling = lookUp SLIT("-dno-black-holing") -opt_OmitDefaultInstanceMethods = lookUp SLIT("-fomit-default-instance-methods") opt_OmitInterfacePragmas = lookUp SLIT("-fomit-interface-pragmas") opt_PprStyle_All = lookUp SLIT("-dppr-all") opt_PprStyle_Debug = lookUp SLIT("-dppr-debug") opt_PprStyle_User = lookUp SLIT("-dppr-user") +opt_PprUserLength = lookup_def_int "-dppr-user-length" 5 --ToDo: give this a name +opt_ProduceC = lookup_str "-C=" +opt_ProduceS = lookup_str "-S=" +opt_ProduceHi = lookup_str "-hifile=" -- the one to produce this time opt_ReportWhyUnfoldingsDisallowed= lookUp SLIT("-freport-disallowed-unfoldings") opt_SccProfilingOn = lookUp SLIT("-fscc-profiling") opt_ShowImportSpecs = lookUp SLIT("-fshow-import-specs") -opt_ShowPragmaNameErrs = lookUp SLIT("-fshow-pragma-name-errs") opt_SigsRequired = lookUp SLIT("-fsignatures-required") +opt_SourceUnchanged = lookUp SLIT("-fsource-unchanged") opt_SpecialiseAll = lookUp SLIT("-fspecialise-all") opt_SpecialiseImports = lookUp SLIT("-fspecialise-imports") opt_SpecialiseOverloaded = lookUp SLIT("-fspecialise-overloaded") opt_SpecialiseTrace = lookUp SLIT("-ftrace-specialisation") opt_SpecialiseUnboxed = lookUp SLIT("-fspecialise-unboxed") opt_StgDoLetNoEscapes = lookUp SLIT("-flet-no-escape") -opt_Verbose = lookUp SLIT("-v") -opt_UsingGhcInternals = lookUp SLIT("-fusing-ghc-internals") -opt_CompilingGhcInternals = maybeToBool maybe_CompilingGhcInternals -maybe_CompilingGhcInternals = lookup_str "-fcompiling-ghc-internals=" -opt_SccGroup = lookup_str "-G=" -opt_ProduceC = lookup_str "-C=" -opt_ProduceS = lookup_str "-S=" -opt_ProduceHi = lookup_str "-hifile=" -- the one to produce this time -opt_HiMap = lookup_str "-himap=" -- file saying where to look for .hi files -opt_EnsureSplittableC = lookup_str "-fglobalise-toplev-names=" -opt_UnfoldingUseThreshold = lookup_int "-funfolding-use-threshold" -opt_UnfoldingCreationThreshold = lookup_int "-funfolding-creation-threshold" -opt_UnfoldingOverrideThreshold = lookup_int "-funfolding-override-threshold" opt_ReturnInRegsThreshold = lookup_int "-freturn-in-regs-threshold" +opt_SccGroup = lookup_str "-G=" +opt_Verbose = lookUp SLIT("-v") -opt_NoImplicitPrelude = lookUp SLIT("-fno-implicit-prelude") -opt_IgnoreIfacePragmas = lookUp SLIT("-fignore-interface-pragmas") +opt_InterfaceUnfoldThreshold = lookup_def_int "-funfolding-interface-threshold" iNTERFACE_UNFOLD_THRESHOLD +opt_UnfoldingCreationThreshold = lookup_def_int "-funfolding-creation-threshold" uNFOLDING_CREATION_THRESHOLD +opt_UnfoldingUseThreshold = lookup_def_int "-funfolding-use-threshold" uNFOLDING_USE_THRESHOLD +opt_UnfoldingConDiscount = lookup_def_int "-funfolding-con-discount" uNFOLDING_CON_DISCOUNT_WEIGHT + +opt_LiberateCaseThreshold = lookup_def_int "-fliberate-case-threshold" lIBERATE_CASE_THRESHOLD +opt_UnfoldingKeenessFactor = lookup_def_float "-funfolding-keeness-factor" uNFOLDING_KEENESS_FACTOR +opt_WarnNameShadowing = lookUp SLIT("-fwarn-name-shadowing") +opt_WarnHiShadows = lookUp SLIT("-fwarn-hi-shadowing") +opt_WarnIncompletePatterns = lookUp SLIT("-fwarn-incomplete-patterns") +opt_WarnOverlappingPatterns = lookUp SLIT("-fwarn-overlapping-patterns") +opt_WarnSimplePatterns = lookUp SLIT("-fwarn-simple-patterns") +opt_WarnUnusedMatches = lookUp SLIT("-fwarn-unused-matches") +opt_WarnUnusedBinds = lookUp SLIT("-fwarn-unused-binds") +opt_WarnUnusedImports = lookUp SLIT("-fwarn-unused-imports") +opt_WarnMissingMethods = lookUp SLIT("-fwarn-missing-methods") +opt_WarnDuplicateExports = lookUp SLIT("-fwarn-duplicate-exports") +opt_PruneTyDecls = not (lookUp SLIT("-fno-prune-tydecls")) +opt_PruneInstDecls = not (lookUp SLIT("-fno-prune-instdecls")) +opt_D_show_rn_stats = lookUp SLIT("-dshow-rn-stats") + +-- opt_UnfoldingOverrideThreshold = lookup_int "-funfolding-override-threshold" \end{code} \begin{code} @@ -323,7 +392,7 @@ classifyOpts :: ([CoreToDo], -- Core-to-Core processing spec classifyOpts = sep argv [] [] -- accumulators... where - sep :: [FAST_STRING] -- cmd-line opts (input) + sep :: [FAST_STRING] -- cmd-line opts (input) -> [CoreToDo] -> [StgToDo] -- to_do accumulators -> ([CoreToDo], [StgToDo]) -- result @@ -332,16 +401,13 @@ classifyOpts = sep argv [] [] -- accumulators... # define CORE_TD(to_do) sep opts (to_do:core_td) stg_td # define STG_TD(to_do) sep opts core_td (to_do:stg_td) -# define IGNORE_ARG() sep opts core_td stg_td sep (opt1:opts) core_td stg_td - = - case (_UNPK_ opt1) of -- the non-"just match a string" options are at the end... - - ',' : _ -> IGNORE_ARG() -- it is for the parser + = case (_UNPK_ opt1) of -- the non-"just match a string" options are at the end... + ',' : _ -> sep opts core_td stg_td -- it is for the parser "-fsimplify" -> -- gather up SimplifierSwitches specially... - simpl_sep opts [] core_td stg_td + simpl_sep opts defaultSimplSwitches core_td stg_td "-fcalc-inlinings1"-> CORE_TD(CoreDoCalcInlinings1) "-fcalc-inlinings2"-> CORE_TD(CoreDoCalcInlinings2) @@ -352,7 +418,6 @@ classifyOpts = sep argv [] [] -- accumulators... "-fstatic-args" -> CORE_TD(CoreDoStaticArgs) "-fstrictness" -> CORE_TD(CoreDoStrictness) "-fspecialise" -> CORE_TD(CoreDoSpecialising) - "-fdeforest" -> CORE_TD(CoreDoDeforest) "-ffoldr-build-worker-wrapper" -> CORE_TD(CoreDoFoldrBuildWorkerWrapper) "-ffoldr-build-ww-anal" -> CORE_TD(CoreDoFoldrBuildWWAnal) @@ -363,14 +428,14 @@ classifyOpts = sep argv [] [] -- accumulators... "-fmassage-stg-for-profiling" -> STG_TD(StgDoMassageForProfiling) _ -> -- NB: the driver is really supposed to handle bad options - IGNORE_ARG() + sep opts core_td stg_td ---------------- - simpl_sep :: [FAST_STRING] -- cmd-line opts (input) - -> [SimplifierSwitch] -- simplifier-switch accumulator - -> [CoreToDo] -> [StgToDo] -- to_do accumulators - -> ([CoreToDo], [StgToDo]) -- result + simpl_sep :: [FAST_STRING] -- cmd-line opts (input) + -> [SimplifierSwitch] -- simplifier-switch accumulator + -> [CoreToDo] -> [StgToDo] -- to_do accumulators + -> ([CoreToDo], [StgToDo]) -- result -- "simpl_sep" tailcalls "sep" once it's seen one set -- of SimplifierSwitches for a CoreDoSimplify. @@ -380,13 +445,12 @@ classifyOpts = sep argv [] [] -- accumulators... = panic "simpl_sep []" #endif - -- The SimplifierSwitches should be delimited by "(" and ")". + -- The SimplifierSwitches should be delimited by "[" and "]". simpl_sep (opt1:opts) simpl_sw core_td stg_td = case (_UNPK_ opt1) of - "(" -> ASSERT (null simpl_sw) - simpl_sep opts [] core_td stg_td - ")" -> let + "[" -> simpl_sep opts simpl_sw core_td stg_td + "]" -> let this_simpl = CoreDoSimplify (isAmongSimpl simpl_sw) in sep opts (this_simpl : core_td) stg_td @@ -400,7 +464,6 @@ classifyOpts = sep argv [] [] -- accumulators... "-ffloat-primops-ok" -> SIMPL_SW(SimplOkToFloatPrimOps) "-falways-float-lets-from-lets" -> SIMPL_SW(SimplAlwaysFloatLetsFromLets) "-fdo-case-elim" -> SIMPL_SW(SimplDoCaseElim) - "-fdo-eta-reduction" -> SIMPL_SW(SimplDoEtaReduction) "-fdo-lambda-eta-expansion" -> SIMPL_SW(SimplDoLambdaEtaExpansion) "-fdo-foldr-build" -> SIMPL_SW(SimplDoFoldrBuild) "-fdo-not-fold-back-append" -> SIMPL_SW(SimplDontFoldBackAppend) @@ -408,29 +471,21 @@ classifyOpts = sep argv [] [] -- accumulators... "-fdo-inline-foldr-build" -> SIMPL_SW(SimplDoInlineFoldrBuild) "-freuse-con" -> SIMPL_SW(SimplReuseCon) "-fcase-of-case" -> SIMPL_SW(SimplCaseOfCase) + "-fcase-merge" -> SIMPL_SW(SimplCaseMerge) "-flet-to-case" -> SIMPL_SW(SimplLetToCase) "-fpedantic-bottoms" -> SIMPL_SW(SimplPedanticBottoms) - "-fkeep-spec-pragma-ids" -> SIMPL_SW(KeepSpecPragmaIds) - "-fkeep-unused-bindings" -> SIMPL_SW(KeepUnusedBindings) "-fmay-delete-conjurable-ids" -> SIMPL_SW(SimplMayDeleteConjurableIds) "-fessential-unfoldings-only" -> SIMPL_SW(EssentialUnfoldingsOnly) "-fignore-inline-pragma" -> SIMPL_SW(IgnoreINLINEPragma) "-fno-let-from-case" -> SIMPL_SW(SimplNoLetFromCase) "-fno-let-from-app" -> SIMPL_SW(SimplNoLetFromApp) "-fno-let-from-strict-let" -> SIMPL_SW(SimplNoLetFromStrictLet) + "-fclone-binds" -> SIMPL_SW(SimplCloneBinds) o | starts_with_msi -> SIMPL_SW(MaxSimplifierIterations (read after_msi)) - | starts_with_suut -> SIMPL_SW(SimplUnfoldingUseThreshold (read after_suut)) - | starts_with_suct -> SIMPL_SW(SimplUnfoldingCreationThreshold (read after_suct)) where - maybe_suut = startsWith "-fsimpl-uf-use-threshold" o - maybe_suct = startsWith "-fsimpl-uf-creation-threshold" o maybe_msi = startsWith "-fmax-simplifier-iterations" o - starts_with_suut = maybeToBool maybe_suut - starts_with_suct = maybeToBool maybe_suct starts_with_msi = maybeToBool maybe_msi - (Just after_suut) = maybe_suut - (Just after_suct) = maybe_suct (Just after_msi) = maybe_msi _ -> -- NB: the driver is really supposed to handle bad options @@ -469,23 +524,22 @@ tagOf_SimplSwitch SimplDoFoldrBuild = ILIT(12) tagOf_SimplSwitch SimplDoInlineFoldrBuild = ILIT(14) tagOf_SimplSwitch IgnoreINLINEPragma = ILIT(15) tagOf_SimplSwitch SimplDoLambdaEtaExpansion = ILIT(16) -tagOf_SimplSwitch SimplDoEtaReduction = ILIT(18) tagOf_SimplSwitch EssentialUnfoldingsOnly = ILIT(19) tagOf_SimplSwitch ShowSimplifierProgress = ILIT(20) tagOf_SimplSwitch (MaxSimplifierIterations _) = ILIT(21) -tagOf_SimplSwitch (SimplUnfoldingUseThreshold _) = ILIT(22) -tagOf_SimplSwitch (SimplUnfoldingCreationThreshold _) = ILIT(23) -tagOf_SimplSwitch KeepSpecPragmaIds = ILIT(24) -tagOf_SimplSwitch KeepUnusedBindings = ILIT(25) -tagOf_SimplSwitch SimplNoLetFromCase = ILIT(26) -tagOf_SimplSwitch SimplNoLetFromApp = ILIT(27) -tagOf_SimplSwitch SimplNoLetFromStrictLet = ILIT(28) -tagOf_SimplSwitch SimplDontFoldBackAppend = ILIT(29) +tagOf_SimplSwitch SimplNoLetFromCase = ILIT(27) +tagOf_SimplSwitch SimplNoLetFromApp = ILIT(28) +tagOf_SimplSwitch SimplNoLetFromStrictLet = ILIT(29) +tagOf_SimplSwitch SimplDontFoldBackAppend = ILIT(30) +tagOf_SimplSwitch SimplCaseMerge = ILIT(31) +tagOf_SimplSwitch SimplCaseScrutinee = ILIT(32) +tagOf_SimplSwitch SimplCloneBinds = ILIT(33) + -- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too! tagOf_SimplSwitch _ = panic# "tagOf_SimplSwitch" -lAST_SIMPL_SWITCH_TAG = IBOX(tagOf_SimplSwitch SimplDontFoldBackAppend) +lAST_SIMPL_SWITCH_TAG = IBOX(tagOf_SimplSwitch SimplCloneBinds) \end{code} %************************************************************************ @@ -495,22 +549,14 @@ lAST_SIMPL_SWITCH_TAG = IBOX(tagOf_SimplSwitch SimplDontFoldBackAppend) %************************************************************************ \begin{code} -#if __GLASGOW_HASKELL__ >= 200 -# define ARRAY Array -# define LIFT GHCbase.Lift -# define SET_TO =: -(=:) a b = (a,b) -#else -# define ARRAY _Array -# define LIFT _Lift -# define SET_TO := -#endif - isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult -isAmongSimpl on_switches +isAmongSimpl on_switches -- Switches mentioned later occur *earlier* + -- in the list; defaults right at the end. = let tidied_on_switches = foldl rm_dups [] on_switches + -- The fold*l* ensures that we keep the latest switches; + -- ie the ones that occur earliest in the list. sw_tbl :: Array Int SwitchResult @@ -518,25 +564,22 @@ isAmongSimpl on_switches all_undefined) // defined_elems - all_undefined = [ i SET_TO SwBool False | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ] + all_undefined = [ (i, SwBool False) | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ] defined_elems = map mk_assoc_elem tidied_on_switches in -- (avoid some unboxing, bounds checking, and other horrible things:) - case sw_tbl of { ARRAY bounds_who_needs_'em stuff -> + case sw_tbl of { Array bounds_who_needs_'em stuff -> \ switch -> case (indexArray# stuff (tagOf_SimplSwitch switch)) of - LIFT v -> v + Lift v -> v } where - mk_assoc_elem k@(MaxSimplifierIterations lvl) = IBOX(tagOf_SimplSwitch k) SET_TO SwInt lvl - mk_assoc_elem k@(SimplUnfoldingUseThreshold i) = IBOX(tagOf_SimplSwitch k) SET_TO SwInt i - mk_assoc_elem k@(SimplUnfoldingCreationThreshold i) = IBOX(tagOf_SimplSwitch k) SET_TO SwInt i + mk_assoc_elem k@(MaxSimplifierIterations lvl) = (IBOX(tagOf_SimplSwitch k), SwInt lvl) - mk_assoc_elem k = IBOX(tagOf_SimplSwitch k) SET_TO SwBool True -- I'm here, Mom! + mk_assoc_elem k = (IBOX(tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom! -- cannot have duplicates if we are going to use the array thing - rm_dups switches_so_far switch = if switch `is_elem` switches_so_far then switches_so_far @@ -547,6 +590,13 @@ isAmongSimpl on_switches || sw `is_elem` ss \end{code} +Default settings for simplifier switches + +\begin{code} +defaultSimplSwitches = [MaxSimplifierIterations 1 + ] +\end{code} + %************************************************************************ %* * \subsection{Misc functions for command-line options} @@ -562,15 +612,6 @@ switchIsOn lookup_fn switch SwBool False -> False _ -> True -stringSwitchSet :: (switch -> SwitchResult) - -> (FAST_STRING -> switch) - -> Maybe FAST_STRING - -stringSwitchSet lookup_fn switch - = case (lookup_fn (switch (panic "stringSwitchSet"))) of - SwString str -> Just str - _ -> Nothing - intSwitchSet :: (switch -> SwitchResult) -> (Int -> switch) -> Maybe Int