X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FCmdLineOpts.lhs;h=d1fe78aedb7ba0fe64f5b7cb8a82a3c28001e2f2;hb=a6c7e7dc8d0c5626ea29c71c3fc957d33064697b;hp=cf036450aafdf83cda85dec31dbbb716b4eb61e1;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index cf03645..d1fe78a 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -6,15 +6,122 @@ \begin{code} #include "HsVersions.h" -module CmdLineOpts where +module CmdLineOpts ( + CoreToDo(..), + SimplifierSwitch(..), + StgToDo(..), + SwitchResult(..), + classifyOpts, + + intSwitchSet, + switchIsOn, + + maybe_CompilingGhcInternals, + opt_AllDemanded, + opt_AllStrict, + opt_AutoSccsOnAllToplevs, + opt_AutoSccsOnExportedToplevs, + opt_AutoSccsOnIndividualCafs, + opt_CompilingGhcInternals, + opt_D_dump_absC, + opt_D_dump_asm, + opt_D_dump_deriv, + opt_D_dump_ds, + opt_D_dump_flatC, + opt_D_dump_occur_anal, + opt_D_dump_rdr, + 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_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_HiMap, + opt_IgnoreIfacePragmas, + opt_IgnoreStrictnessPragmas, + opt_IrrefutableEverything, + opt_IrrefutableTuples, + opt_LiberateCaseThreshold, + opt_NoImplicitPrelude, + opt_NumbersStrict, + opt_OmitBlackHoling, + opt_OmitDefaultInstanceMethods, + opt_OmitInterfacePragmas, + opt_PprStyle_All, + opt_PprStyle_Debug, + opt_PprStyle_User, -- ToDo: rm + opt_PprUserLength, + opt_ProduceC, + opt_ProduceHi, + opt_ProduceS, + opt_ReportWhyUnfoldingsDisallowed, + opt_ReturnInRegsThreshold, + 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_UnfoldingConDiscount, + opt_UnfoldingUseThreshold, + + opt_Verbose, + opt_WarnNameShadowing, + opt_WarnUnusedNames, + opt_WarnIncompletePatterns, opt_WarnOverlappedPatterns, + opt_PruneTyDecls, opt_PruneInstDecls, + opt_D_show_unused_imports, + opt_D_show_rn_stats, + + all_toplev_ids_visible + ) where +IMPORT_1_3(Array(array, (//))) +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 import PreludeGlaST -- bad bad bad boy, Will (_Array internals) -import Argv +#else +import GlaExts +import ArrBase +-- 2.04 and later exports Lift from GlaExts +#if __GLASGOW_HASKELL__ < 204 +import PrelBase (Lift(..)) +#endif +#endif CHK_Ubiq() -- debugging consistency check -import Maybes ( assocMaybe, firstJust, maybeToBool, Maybe(..) ) -import Util ( panic, panic#, assertPanic ) +import Argv +import Constants -- Default values for some flags +import Maybes ( assocMaybe, firstJust, maybeToBool ) +import Util ( startsWith, panic, panic#, assertPanic ) \end{code} A command-line {\em switch} is (generally) either on or off; e.g., the @@ -62,8 +169,6 @@ data CoreToDo -- These are diff core-to-core passes, | CoreDoStaticArgs | CoreDoStrictness | CoreDoSpecialising - | CoreDoDeforest - | CoreDoAutoCostCentres | CoreDoFoldrBuildWorkerWrapper | CoreDoFoldrBuildWWAnal \end{code} @@ -100,7 +205,6 @@ data SimplifierSwitch | IgnoreINLINEPragma | SimplDoLambdaEtaExpansion - | SimplDoEtaReduction | EssentialUnfoldingsOnly -- never mind the thresholds, only -- do unfoldings that *must* be done @@ -110,9 +214,6 @@ data SimplifierSwitch | MaxSimplifierIterations Int - | SimplUnfoldingUseThreshold Int -- per-simplification variants - | SimplUnfoldingCreationThreshold Int - | KeepSpecPragmaIds -- We normally *toss* Ids we can do without | KeepUnusedBindings @@ -130,6 +231,12 @@ 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 \end{code} %************************************************************************ @@ -139,108 +246,134 @@ data SimplifierSwitch %************************************************************************ \begin{code} -lookup :: FAST_STRING -> Bool -lookup_int :: FAST_STRING -> Maybe Int -lookup_str :: FAST_STRING -> Maybe FAST_STRING +lookUp :: FAST_STRING -> Bool +lookup_int :: String -> Maybe Int +lookup_def_int :: String -> Int -> Int +lookup_str :: String -> Maybe String -lookup sw = maybeToBool (assoc_opts sw) +lookUp sw = maybeToBool (assoc_opts sw) -lookup_str sw = let - unpk_sw = _UNPK_ sw - in - case (firstJust (map (starts_with unpk_sw) unpacked_opts)) of - Nothing -> Nothing - Just xx -> Just (_PK_ xx) +lookup_str sw = firstJust (map (startsWith sw) unpacked_opts) lookup_int sw = case (lookup_str sw) of Nothing -> Nothing - Just xx -> Just (read (_UNPK_ xx)) + Just xx -> Just (read xx) + +lookup_def_int 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 +\end{code} -starts_with :: String -> String -> Maybe String - -starts_with [] str = Just str -starts_with (c:cs) (s:ss) - = if c /= s then Nothing else starts_with cs ss +\begin{code} +opt_AllDemanded = lookUp SLIT("-fall-demanded") +opt_AllStrict = lookUp SLIT("-fall-strict") +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_deriv = lookUp SLIT("-ddump-deriv") +opt_D_dump_ds = lookUp SLIT("-ddump-ds") +opt_D_dump_flatC = lookUp SLIT("-ddump-flatC") +opt_D_dump_occur_anal = lookUp SLIT("-ddump-occur-anal") +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_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") +--UNUSED:opt_Haskell_1_3 = lookUp SLIT("-fhaskell-1.3") +opt_HiMap = lookup_str "-himap=" -- file saying where to look for .hi files +opt_IgnoreIfacePragmas = lookUp SLIT("-fignore-interface-pragmas") +opt_IgnoreStrictnessPragmas = lookUp SLIT("-fignore-strictness-pragmas") +opt_IrrefutableEverything = lookUp SLIT("-firrefutable-everything") +opt_IrrefutableTuples = lookUp SLIT("-firrefutable-tuples") +opt_NoImplicitPrelude = lookUp SLIT("-fno-implicit-prelude") +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_ReturnInRegsThreshold = lookup_int "-freturn-in-regs-threshold" +opt_SccGroup = lookup_str "-G=" +opt_Verbose = lookUp SLIT("-v") + +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_WarnNameShadowing = lookUp SLIT("-fwarn-name-shadowing") +opt_WarnIncompletePatterns = not (lookUp SLIT("-fno-warn-incomplete-patterns")) +opt_WarnOverlappedPatterns = not (lookUp SLIT("-fno-warn-overlapped-patterns")) +opt_WarnUnusedNames = lookUp SLIT("-fwarn-unused-names") +opt_PruneTyDecls = not (lookUp SLIT("-fno-prune-tydecls")) +opt_PruneInstDecls = not (lookUp SLIT("-fno-prune-instdecls")) +opt_D_show_unused_imports = lookUp SLIT("-dshow-unused-imports") +opt_D_show_rn_stats = lookUp SLIT("-dshow-rn-stats") + +-- opt_UnfoldingOverrideThreshold = lookup_int "-funfolding-override-threshold" \end{code} + \begin{code} -opt_AllDemanded = lookup SLIT("-fall-demanded") -opt_AllStrict = lookup SLIT("-fall-strict") -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_CompilingPrelude = lookup SLIT("-prelude") -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") -opt_D_dump_occur_anal = lookup SLIT("-ddump-occur-anal") -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_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_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_DoSemiTagging = lookup SLIT("-fsemi-tagging") -opt_DoTickyProfiling = lookup SLIT("-fticky-ticky") -opt_EmitArityChecks = lookup SLIT("-darity-checks") -opt_FoldrBuildOn = lookup SLIT("-ffoldr-build-on") -opt_FoldrBuildTrace = lookup SLIT("-ffoldr-build-trace") -opt_ForConcurrent = lookup SLIT("-fconcurrent") -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_IrrefutableTuples = lookup SLIT("-firrefutable-tuples") -opt_NameShadowingNotOK = lookup SLIT("-fname-shadowing-not-ok") -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_OmitReexportedInstances = lookup SLIT("-fomit-reexported-instances") -opt_PprStyle_All = lookup SLIT("-dppr-all") -opt_PprStyle_Debug = lookup SLIT("-dppr-debug") -opt_PprStyle_User = lookup SLIT("-dppr-user") -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_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_UseGetMentionedVars = lookup SLIT("-fuse-get-mentioned-vars") -opt_Verbose = lookup SLIT("-v") -opt_AsmTarget = lookup_str SLIT("-fasm-") -opt_SccGroup = lookup_str SLIT("-G") -opt_ProduceC = lookup_str SLIT("-C") -opt_ProduceS = lookup_str SLIT("-S") -opt_ProduceHi = lookup_str SLIT("-hi") -opt_EnsureSplittableC = lookup_str SLIT("-fglobalise-toplev-names") -opt_UnfoldingUseThreshold = lookup_int SLIT("-funfolding-use-threshold") -opt_UnfoldingCreationThreshold = lookup_int SLIT("-funfolding-creation-threshold") -opt_UnfoldingOverrideThreshold = lookup_int SLIT("-funfolding-override-threshold") -opt_ReturnInRegsThreshold = lookup_int SLIT("-freturn-in-regs-threshold") +all_toplev_ids_visible :: Bool +all_toplev_ids_visible = + not opt_OmitInterfacePragmas || -- Pragmas can make them visible + opt_EnsureSplittableC || -- Splitting requires visiblilty + opt_AutoSccsOnAllToplevs -- ditto for profiling + -- (ToDo: fix up the auto-annotation + -- pass in the desugarer to avoid having + -- to do this) + \end{code} + + \begin{code} classifyOpts :: ([CoreToDo], -- Core-to-Core processing spec [StgToDo]) -- STG-to-STG processing spec @@ -265,7 +398,7 @@ classifyOpts = sep argv [] [] -- accumulators... ',' : _ -> IGNORE_ARG() -- 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) @@ -276,8 +409,6 @@ classifyOpts = sep argv [] [] -- accumulators... "-fstatic-args" -> CORE_TD(CoreDoStaticArgs) "-fstrictness" -> CORE_TD(CoreDoStrictness) "-fspecialise" -> CORE_TD(CoreDoSpecialising) - "-fdeforest" -> CORE_TD(CoreDoDeforest) - "-fadd-auto-sccs" -> CORE_TD(CoreDoAutoCostCentres) "-ffoldr-build-worker-wrapper" -> CORE_TD(CoreDoFoldrBuildWorkerWrapper) "-ffoldr-build-ww-anal" -> CORE_TD(CoreDoFoldrBuildWWAnal) @@ -305,13 +436,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 @@ -325,7 +455,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) @@ -333,6 +462,7 @@ 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) @@ -345,17 +475,9 @@ classifyOpts = sep argv [] [] -- accumulators... "-fno-let-from-strict-let" -> SIMPL_SW(SimplNoLetFromStrictLet) 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 = starts_with "-fsimpl-uf-use-threshold" o - maybe_suct = starts_with "-fsimpl-uf-creation-threshold" o - maybe_msi = starts_with "-fmax-simplifier-iterations" o - starts_with_suut = maybeToBool maybe_suut - starts_with_suct = maybeToBool maybe_suct + maybe_msi = startsWith "-fmax-simplifier-iterations" o 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 @@ -394,23 +516,23 @@ 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 KeepSpecPragmaIds = ILIT(25) +tagOf_SimplSwitch KeepUnusedBindings = ILIT(26) +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) + -- 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 SimplCaseScrutinee) \end{code} %************************************************************************ @@ -420,11 +542,30 @@ lAST_SIMPL_SWITCH_TAG = IBOX(tagOf_SimplSwitch SimplDontFoldBackAppend) %************************************************************************ \begin{code} +#if __GLASGOW_HASKELL__ == 201 +# define ARRAY Array +# define LIFT GHCbase.Lift +# define SET_TO =: +(=:) a b = (a,b) +#elif __GLASGOW_HASKELL__ >= 202 +# define ARRAY Array +# define LIFT 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 @@ -432,25 +573,22 @@ isAmongSimpl on_switches all_undefined) // defined_elems - all_undefined = [ i := SwBool False | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ] + all_undefined = [ i SET_TO 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) := SwInt lvl - mk_assoc_elem k@(SimplUnfoldingUseThreshold i) = IBOX(tagOf_SimplSwitch k) := SwInt i - mk_assoc_elem k@(SimplUnfoldingCreationThreshold i) = IBOX(tagOf_SimplSwitch k) := SwInt i + mk_assoc_elem k@(MaxSimplifierIterations lvl) = IBOX(tagOf_SimplSwitch k) SET_TO SwInt lvl - mk_assoc_elem k = IBOX(tagOf_SimplSwitch k) := SwBool True -- I'm here, Mom! + mk_assoc_elem k = IBOX(tagOf_SimplSwitch k) SET_TO 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 @@ -461,6 +599,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}