X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FCmdLineOpts.lhs;h=5594ece5797444b4f0d005405ec7d4ca7f89bbcb;hb=111cee3f1ad93816cb828e38b38521d85c3bcebb;hp=d2ed9f70f34b19040f372998cd5f88852e828776;hpb=ae45ff0e9831a0dc862a5d68d03e355d7e323c62;p=ghc-hetmet.git diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index d2ed9f7..5594ece 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -1,25 +1,176 @@ % -% (c) The AQUA Project, Glasgow University, 1996 +% (c) The AQUA Project, Glasgow University, 1996-98 % \section[CmdLineOpts]{Things to do with command-line options} \begin{code} -#include "HsVersions.h" +module CmdLineOpts ( + CoreToDo(..), + SimplifierSwitch(..), + StgToDo(..), + SwitchResult(..), + classifyOpts, + + intSwitchSet, + switchIsOn, + + src_filename, + + -- debugging opts + opt_D_dump_absC, + opt_D_dump_asm, + opt_D_dump_cpranal, + opt_D_dump_cse, + opt_D_dump_deriv, + opt_D_dump_ds, + opt_D_dump_flatC, + opt_D_dump_foreign, + opt_D_dump_inlinings, + opt_D_dump_occur_anal, + opt_D_dump_parsed, + opt_D_dump_realC, + opt_D_dump_rn, + opt_D_dump_rules, + opt_D_dump_simpl, + opt_D_dump_simpl_iterations, + opt_D_dump_simpl_stats, + opt_D_dump_spec, + opt_D_dump_stg, + opt_D_dump_stranal, + opt_D_dump_tc, + opt_D_dump_usagesp, + opt_D_dump_worker_wrapper, + opt_D_show_passes, + opt_D_dump_rn_trace, + opt_D_dump_rn_stats, + opt_D_dump_stix, + opt_D_source_stats, + opt_D_verbose_core2core, + opt_D_verbose_stg2stg, + opt_DoCoreLinting, + opt_DoStgLinting, + opt_DoUSPLinting, + opt_PprStyle_Debug, + opt_PprStyle_NoPrags, + opt_PprUserLength, + + -- warning opts + opt_WarnDuplicateExports, + opt_WarnHiShadows, + opt_WarnIncompletePatterns, + opt_WarnMissingFields, + opt_WarnMissingMethods, + opt_WarnMissingSigs, + opt_WarnNameShadowing, + opt_WarnOverlappingPatterns, + opt_WarnSimplePatterns, + opt_WarnTypeDefaults, + opt_WarnUnusedBinds, + opt_WarnUnusedImports, + opt_WarnUnusedMatches, + opt_WarnDeprecations, + + -- profiling opts + opt_AutoSccsOnAllToplevs, + opt_AutoSccsOnExportedToplevs, + opt_AutoSccsOnIndividualCafs, + opt_AutoSccsOnDicts, + opt_SccProfilingOn, + opt_DoTickyProfiling, + + -- language opts + opt_AllStrict, + opt_DictsStrict, + opt_MaxContextReductionDepth, + opt_AllowOverlappingInstances, + opt_AllowUndecidableInstances, + opt_GlasgowExts, + opt_IrrefutableTuples, + opt_NumbersStrict, + opt_Parallel, + opt_SMP, + + -- optimisation opts + opt_DoEtaReduction, + opt_DoSemiTagging, + opt_FoldrBuildOn, + opt_LiberateCaseThreshold, + opt_StgDoLetNoEscapes, + opt_UnfoldCasms, + opt_UsageSPOn, + opt_UnboxStrictFields, + opt_SimplNoPreInlining, + opt_SimplDoEtaReduction, + opt_SimplDoLambdaEtaExpansion, + opt_SimplCaseOfCase, + opt_SimplCaseMerge, + opt_SimplPedanticBottoms, + + -- Unfolding control + opt_UF_HiFileThreshold, + opt_UF_CreationThreshold, + opt_UF_UseThreshold, + opt_UF_ScrutConDiscount, + opt_UF_FunAppDiscount, + opt_UF_PrimArgDiscount, + opt_UF_KeenessFactor, + opt_UF_CheapOp, + opt_UF_DearOp, + + -- misc opts + opt_CompilingPrelude, + opt_EmitCExternDecls, + opt_EnsureSplittableC, + opt_GranMacros, + opt_HiMap, + opt_HiMapSep, + opt_HiVersion, + opt_HistorySize, + opt_IgnoreAsserts, + opt_IgnoreIfacePragmas, + opt_NoHiCheck, + opt_NoImplicitPrelude, + opt_OmitBlackHoling, + opt_OmitInterfacePragmas, + opt_ProduceC, + opt_ProduceExportCStubs, + opt_ProduceExportHStubs, + opt_ProduceHi, + opt_ProduceS, + opt_NoPruneDecls, + opt_ReportCompile, + opt_SourceUnchanged, + opt_Static, + opt_Unregisterised, + opt_Verbose, + + -- Code generation + opt_UseVanillaRegs, + opt_UseFloatRegs, + opt_UseDoubleRegs, + opt_UseLongRegs + ) where -module CmdLineOpts where +#include "HsVersions.h" -import PreludeGlaST -- bad bad bad boy, Will (_Array internals) +import Array ( array, (//) ) +import GlaExts import Argv +import Constants -- Default values for some flags -CHK_Ubiq() -- debugging consistency check +import FastString ( headFS ) +import Maybes ( assocMaybe, firstJust, maybeToBool ) +import Panic ( panic, panic# ) -import Maybes ( assocMaybe, firstJust, maybeToBool, Maybe(..) ) -import Util ( startsWith, panic, panic#, assertPanic ) +#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 -``verbose'' (-v) switch is either on or off. (The \tr{-G} -switch is an exception; it's set to a string, or nothing.) +``verbose'' (-v) switch is either on or off. A list of {\em ToDo}s is things to be done in a particular part of processing. A (fictitious) example for the Core-to-Core simplifier @@ -31,6 +182,7 @@ main loop (\tr{main/Main.lhs}), in the Core-to-Core processing loop (\tr{simplCore/SimplCore.lhs), and in the STG-to-STG processing loop (\tr{simplStg/SimplStg.lhs}). + %************************************************************************ %* * \subsection{Datatypes associated with command-line options} @@ -53,19 +205,17 @@ data CoreToDo -- These are diff core-to-core passes, (SimplifierSwitch -> SwitchResult) -- Each run of the simplifier can take a different -- set of simplifier-specific flags. - | CoreDoCalcInlinings1 - | CoreDoCalcInlinings2 | CoreDoFloatInwards - | CoreDoFullLaziness + | CoreDoFloatOutwards Bool -- True <=> float lambdas to top level | CoreLiberateCase | CoreDoPrintCore | CoreDoStaticArgs | CoreDoStrictness + | CoreDoWorkerWrapper | CoreDoSpecialising - | CoreDoDeforest - | CoreDoAutoCostCentres - | CoreDoFoldrBuildWorkerWrapper - | CoreDoFoldrBuildWWAnal + | CoreDoUSPInf + | CoreDoCPResult + | CoreCSE \end{code} \begin{code} @@ -81,55 +231,11 @@ data StgToDo \begin{code} data SimplifierSwitch - = SimplOkToDupCode - | SimplFloatLetsExposingWHNF - | SimplOkToFloatPrimOps - | SimplAlwaysFloatLetsFromLets - | SimplDoCaseElim - | SimplReuseCon - | SimplCaseOfCase + = MaxSimplifierIterations Int + | SimplInlinePhase Int + | DontApplyRules + | NoCaseOfCase | SimplLetToCase - | SimplMayDeleteConjurableIds - | SimplPedanticBottoms -- see Simplifier for an explanation - | SimplDoArityExpand -- expand arity of bindings - | SimplDoFoldrBuild -- This is the per-simplification flag; - -- see also FoldrBuildOn, used elsewhere - -- in the compiler. - | SimplDoInlineFoldrBuild - -- inline foldr/build (*after* f/b rule is used) - - | IgnoreINLINEPragma - | SimplDoLambdaEtaExpansion - | SimplDoEtaReduction - - | EssentialUnfoldingsOnly -- never mind the thresholds, only - -- do unfoldings that *must* be done - -- (to saturate constructors and primitives) - - | ShowSimplifierProgress -- report counts on every interation - - | 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 - - | SimplDontFoldBackAppend - -- we fold `foldr (:)' back into flip (++), - -- but we *don't* want to do it when compiling - -- List.hs, otherwise - -- xs ++ ys = foldr (:) ys xs - -- {- via our loopback -} - -- xs ++ ys = xs ++ ys - -- Oops! - -- So only use this flag inside List.hs - -- (Sigh, what a HACK, Andy. WDP 96/01) \end{code} %************************************************************************ @@ -139,11 +245,13 @@ 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) +lookUp sw = maybeToBool (assoc_opts sw) lookup_str sw = firstJust (map (startsWith sw) unpacked_opts) @@ -151,85 +259,200 @@ 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_char sw def = case (lookup_str sw) of + Just (xx:_) -> xx + _ -> def -- Use default + +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_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_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_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_IrrefutableTuples = lookup SLIT("-firrefutable-tuples") -opt_WarnNameShadowing = lookup SLIT("-fwarn-name-shadowing") -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_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_Verbose = lookup SLIT("-v") -opt_CompilingPrelude = maybeToBool maybe_CompilingPrelude -maybe_CompilingPrelude = lookup_str "-fcompiling-prelude=" -opt_SccGroup = lookup_str "-G=" +src_filename :: FAST_STRING +src_filename = case argv of + filename : rest | headFS filename /= '-' -> filename + otherwise -> panic "no filename" +\end{code} + +\begin{code} +-- debugging opts +opt_D_dump_all {- do not -} = lookUp SLIT("-ddump-all") +opt_D_dump_most {- export -} = opt_D_dump_all || lookUp SLIT("-ddump-most") + +opt_D_dump_absC = opt_D_dump_all || lookUp SLIT("-ddump-absC") +opt_D_dump_asm = opt_D_dump_all || lookUp SLIT("-ddump-asm") +opt_D_dump_cpranal = opt_D_dump_most || lookUp SLIT("-ddump-cpranal") +opt_D_dump_deriv = opt_D_dump_most || lookUp SLIT("-ddump-deriv") +opt_D_dump_ds = opt_D_dump_most || lookUp SLIT("-ddump-ds") +opt_D_dump_flatC = opt_D_dump_all || lookUp SLIT("-ddump-flatC") +opt_D_dump_foreign = opt_D_dump_most || lookUp SLIT("-ddump-foreign-stubs") +opt_D_dump_inlinings = opt_D_dump_all || lookUp SLIT("-ddump-inlinings") +opt_D_dump_occur_anal = opt_D_dump_all || lookUp SLIT("-ddump-occur-anal") +opt_D_dump_parsed = opt_D_dump_most || lookUp SLIT("-ddump-parsed") +opt_D_dump_realC = opt_D_dump_all || lookUp SLIT("-ddump-realC") +opt_D_dump_rn = opt_D_dump_most || lookUp SLIT("-ddump-rn") +opt_D_dump_simpl = opt_D_dump_most || lookUp SLIT("-ddump-simpl") +opt_D_dump_simpl_iterations = opt_D_dump_all || lookUp SLIT("-ddump-simpl-iterations") +opt_D_dump_spec = opt_D_dump_most || lookUp SLIT("-ddump-spec") +opt_D_dump_stg = opt_D_dump_most || lookUp SLIT("-ddump-stg") +opt_D_dump_stranal = opt_D_dump_most || lookUp SLIT("-ddump-stranal") +opt_D_dump_tc = opt_D_dump_most || lookUp SLIT("-ddump-tc") +opt_D_dump_rules = opt_D_dump_most || lookUp SLIT("-ddump-rules") +opt_D_dump_usagesp = opt_D_dump_most || lookUp SLIT("-ddump-usagesp") +opt_D_dump_cse = opt_D_dump_most || lookUp SLIT("-ddump-cse") +opt_D_dump_worker_wrapper = opt_D_dump_most || lookUp SLIT("-ddump-workwrap") +opt_D_show_passes = opt_D_dump_most || lookUp SLIT("-dshow-passes") +opt_D_dump_rn_trace = opt_D_dump_all || lookUp SLIT("-ddump-rn-trace") +opt_D_dump_rn_stats = opt_D_dump_most || lookUp SLIT("-ddump-rn-stats") +opt_D_dump_stix = opt_D_dump_all || lookUp SLIT("-ddump-stix") +opt_D_dump_simpl_stats = opt_D_dump_most || lookUp SLIT("-ddump-simpl-stats") +opt_D_source_stats = opt_D_dump_most || lookUp SLIT("-dsource-stats") +opt_D_verbose_core2core = opt_D_dump_all || lookUp SLIT("-dverbose-simpl") +opt_D_verbose_stg2stg = opt_D_dump_all || lookUp SLIT("-dverbose-stg") + +opt_DoCoreLinting = lookUp SLIT("-dcore-lint") +opt_DoStgLinting = lookUp SLIT("-dstg-lint") +opt_DoUSPLinting = lookUp SLIT("-dusagesp-lint") +opt_PprStyle_NoPrags = lookUp SLIT("-dppr-noprags") +opt_PprStyle_Debug = lookUp SLIT("-dppr-debug") +opt_PprUserLength = lookup_def_int "-dppr-user-length" 5 --ToDo: give this a name + +-- warning opts +opt_WarnDuplicateExports = lookUp SLIT("-fwarn-duplicate-exports") +opt_WarnHiShadows = lookUp SLIT("-fwarn-hi-shadowing") +opt_WarnIncompletePatterns = lookUp SLIT("-fwarn-incomplete-patterns") +opt_WarnMissingFields = lookUp SLIT("-fwarn-missing-fields") +opt_WarnMissingMethods = lookUp SLIT("-fwarn-missing-methods") +opt_WarnMissingSigs = lookUp SLIT("-fwarn-missing-signatures") +opt_WarnNameShadowing = lookUp SLIT("-fwarn-name-shadowing") +opt_WarnOverlappingPatterns = lookUp SLIT("-fwarn-overlapping-patterns") +opt_WarnSimplePatterns = lookUp SLIT("-fwarn-simple-patterns") +opt_WarnTypeDefaults = lookUp SLIT("-fwarn-type-defaults") +opt_WarnUnusedBinds = lookUp SLIT("-fwarn-unused-binds") +opt_WarnUnusedImports = lookUp SLIT("-fwarn-unused-imports") +opt_WarnUnusedMatches = lookUp SLIT("-fwarn-unused-matches") +opt_WarnDeprecations = lookUp SLIT("-fwarn-deprecations") + +-- profiling opts +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_AutoSccsOnDicts = lookUp SLIT("-fauto-sccs-on-dicts") +opt_SccProfilingOn = lookUp SLIT("-fscc-profiling") +opt_DoTickyProfiling = lookUp SLIT("-fticky-ticky") + +-- language opts +opt_AllStrict = lookUp SLIT("-fall-strict") +opt_DictsStrict = lookUp SLIT("-fdicts-strict") +opt_AllowOverlappingInstances = lookUp SLIT("-fallow-overlapping-instances") +opt_AllowUndecidableInstances = lookUp SLIT("-fallow-undecidable-instances") +opt_GlasgowExts = lookUp SLIT("-fglasgow-exts") +opt_IrrefutableTuples = lookUp SLIT("-firrefutable-tuples") +opt_MaxContextReductionDepth = lookup_def_int "-fcontext-stack" mAX_CONTEXT_REDUCTION_DEPTH +opt_NumbersStrict = lookUp SLIT("-fnumbers-strict") +opt_Parallel = lookUp SLIT("-fparallel") +opt_SMP = lookUp SLIT("-fsmp") + +-- optimisation opts +opt_DoEtaReduction = lookUp SLIT("-fdo-eta-reduction") +opt_DoSemiTagging = lookUp SLIT("-fsemi-tagging") +opt_FoldrBuildOn = lookUp SLIT("-ffoldr-build-on") +opt_LiberateCaseThreshold = lookup_def_int "-fliberate-case-threshold" (10::Int) +opt_StgDoLetNoEscapes = lookUp SLIT("-flet-no-escape") +opt_UnfoldCasms = lookUp SLIT("-funfold-casms-in-hi-file") +opt_UsageSPOn = lookUp SLIT("-fusagesp-on") +opt_UnboxStrictFields = lookUp SLIT("-funbox-strict-fields") + + {- + It's a bit unfortunate to have to re-introduce this chap, but on Win32 + platforms we do need a way of distinguishing between the case when we're + compiling a static version of the Prelude and one that's going to be + put into a DLL. Why? Because the compiler's wired in modules need to + be attributed as either coming from a DLL or not. + -} +opt_CompilingPrelude = lookUp SLIT("-fcompiling-prelude") +opt_EmitCExternDecls = lookUp SLIT("-femit-extern-decls") +opt_EnsureSplittableC = lookUp SLIT("-fglobalise-toplev-names") +opt_GranMacros = lookUp SLIT("-fgransim") +opt_HiMap = lookup_str "-himap=" -- file saying where to look for .hi files +opt_HiMapSep = lookup_def_char "-himap-sep=" ':' +opt_HiVersion = lookup_def_int "-fhi-version=" 0 -- what version we're compiling. +opt_HistorySize = lookup_def_int "-fhistory-size" 20 +opt_IgnoreAsserts = lookUp SLIT("-fignore-asserts") +opt_IgnoreIfacePragmas = lookUp SLIT("-fignore-interface-pragmas") +opt_NoHiCheck = lookUp SLIT("-fno-hi-version-check") +opt_NoImplicitPrelude = lookUp SLIT("-fno-implicit-prelude") +opt_OmitBlackHoling = lookUp SLIT("-dno-black-holing") +opt_OmitInterfacePragmas = lookUp SLIT("-fomit-interface-pragmas") opt_ProduceC = lookup_str "-C=" -opt_ProduceS = lookup_str "-S=" +opt_ProduceExportCStubs = lookup_str "-F=" +opt_ProduceExportHStubs = lookup_str "-FH=" 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_NoImplicitPrelude = lookup SLIT("-fno-implicit-prelude") -opt_IgnoreIfacePragmas = lookup SLIT("-fignore-interface-pragmas") + +-- Simplifier switches +opt_SimplNoPreInlining = lookUp SLIT("-fno-pre-inlining") + -- NoPreInlining is there just to see how bad things + -- get if you don't do it! +opt_SimplDoEtaReduction = lookUp SLIT("-fdo-eta-reduction") +opt_SimplDoLambdaEtaExpansion = lookUp SLIT("-fdo-lambda-eta-expansion") +opt_SimplCaseOfCase = lookUp SLIT("-fcase-of-case") +opt_SimplCaseMerge = lookUp SLIT("-fcase-merge") +opt_SimplPedanticBottoms = lookUp SLIT("-fpedantic-bottoms") + +-- Unfolding control +opt_UF_HiFileThreshold = lookup_def_int "-funfolding-interface-threshold" (45::Int) +opt_UF_CreationThreshold = lookup_def_int "-funfolding-creation-threshold" (45::Int) +opt_UF_UseThreshold = lookup_def_int "-funfolding-use-threshold" (8::Int) -- Discounts can be big +opt_UF_ScrutConDiscount = lookup_def_int "-funfolding-con-discount" (2::Int) +opt_UF_FunAppDiscount = lookup_def_int "-funfolding-fun-discount" (6::Int) -- It's great to inline a fn +opt_UF_PrimArgDiscount = lookup_def_int "-funfolding-prim-discount" (1::Int) +opt_UF_KeenessFactor = lookup_def_float "-funfolding-keeness-factor" (1.0::Float) + +opt_UF_CheapOp = ( 1 :: Int) -- Only one instruction; and the args are charged for +opt_UF_DearOp = ( 4 :: Int) + +opt_ProduceS = lookup_str "-S=" +opt_ReportCompile = lookUp SLIT("-freport-compile") +opt_NoPruneDecls = lookUp SLIT("-fno-prune-decls") +opt_SourceUnchanged = lookUp SLIT("-fsource-unchanged") +opt_Static = lookUp SLIT("-static") +opt_Unregisterised = lookUp SLIT("-funregisterised") +opt_Verbose = lookUp SLIT("-v") + +opt_UseVanillaRegs | opt_Unregisterised = 0 + | otherwise = mAX_Real_Vanilla_REG +opt_UseFloatRegs | opt_Unregisterised = 0 + | otherwise = mAX_Real_Float_REG +opt_UseDoubleRegs | opt_Unregisterised = 0 + | otherwise = mAX_Real_Double_REG +opt_UseLongRegs | opt_Unregisterised = 0 + | otherwise = mAX_Real_Long_REG \end{code} \begin{code} @@ -238,7 +461,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 @@ -247,30 +470,26 @@ 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) "-ffloat-inwards" -> CORE_TD(CoreDoFloatInwards) - "-ffull-laziness" -> CORE_TD(CoreDoFullLaziness) + "-ffloat-outwards" -> CORE_TD(CoreDoFloatOutwards False) + "-ffloat-outwards-full" -> CORE_TD(CoreDoFloatOutwards True) "-fliberate-case" -> CORE_TD(CoreLiberateCase) + "-fcse" -> CORE_TD(CoreCSE) "-fprint-core" -> CORE_TD(CoreDoPrintCore) "-fstatic-args" -> CORE_TD(CoreDoStaticArgs) "-fstrictness" -> CORE_TD(CoreDoStrictness) + "-fworker-wrapper" -> CORE_TD(CoreDoWorkerWrapper) "-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) + "-fusagesp" -> CORE_TD(CoreDoUSPInf) + "-fcpr-analyse" -> CORE_TD(CoreDoCPResult) "-fstg-static-args" -> STG_TD(StgDoStaticArgs) "-fupdate-analysis" -> STG_TD(StgDoUpdateAnalysis) @@ -279,14 +498,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. @@ -296,61 +515,36 @@ 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 -# define SIMPL_SW(sw) simpl_sep opts (sw:simpl_sw) core_td stg_td - - -- the non-"just match a string" options are at the end... - "-fshow-simplifier-progress" -> SIMPL_SW(ShowSimplifierProgress) - "-fcode-duplication-ok" -> SIMPL_SW(SimplOkToDupCode) - "-ffloat-lets-exposing-whnf" -> SIMPL_SW(SimplFloatLetsExposingWHNF) - "-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) - "-fdo-arity-expand" -> SIMPL_SW(SimplDoArityExpand) - "-fdo-inline-foldr-build" -> SIMPL_SW(SimplDoInlineFoldrBuild) - "-freuse-con" -> SIMPL_SW(SimplReuseCon) - "-fcase-of-case" -> SIMPL_SW(SimplCaseOfCase) - "-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) - - 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 - simpl_sep opts simpl_sw core_td stg_td + opt -> case matchSimplSw opt of + Just sw -> simpl_sep opts (sw:simpl_sw) core_td stg_td + Nothing -> simpl_sep opts simpl_sw core_td stg_td + +matchSimplSw opt + = firstJust [ matchSwInt opt "-fmax-simplifier-iterations" MaxSimplifierIterations + , matchSwInt opt "-finline-phase" SimplInlinePhase + , matchSwBool opt "-fno-rules" DontApplyRules + , matchSwBool opt "-fno-case-of-case" NoCaseOfCase + , matchSwBool opt "-flet-to-case" SimplLetToCase + ] + +matchSwBool :: String -> String -> a -> Maybe a +matchSwBool opt str sw | opt == str = Just sw + | otherwise = Nothing + +matchSwInt :: String -> String -> (Int -> a) -> Maybe a +matchSwInt opt str sw = case startsWith str opt of + Just opt_left -> Just (sw (read opt_left)) + Nothing -> Nothing \end{code} %************************************************************************ @@ -359,8 +553,8 @@ classifyOpts = sep argv [] [] -- accumulators... %* * %************************************************************************ -In spite of the @Produce*@ and @SccGroup@ constructors, these things -behave just like enumeration types. +In spite of the @Produce*@ constructor, these things behave just like +enumeration types. \begin{code} instance Eq SimplifierSwitch where @@ -370,38 +564,16 @@ instance Ord SimplifierSwitch where a < b = tagOf_SimplSwitch a _LT_ tagOf_SimplSwitch b a <= b = tagOf_SimplSwitch a _LE_ tagOf_SimplSwitch b -tagOf_SimplSwitch SimplOkToDupCode =(ILIT(0) :: FAST_INT) -tagOf_SimplSwitch SimplFloatLetsExposingWHNF = ILIT(1) -tagOf_SimplSwitch SimplOkToFloatPrimOps = ILIT(2) -tagOf_SimplSwitch SimplAlwaysFloatLetsFromLets = ILIT(3) -tagOf_SimplSwitch SimplDoCaseElim = ILIT(4) -tagOf_SimplSwitch SimplReuseCon = ILIT(5) -tagOf_SimplSwitch SimplCaseOfCase = ILIT(6) -tagOf_SimplSwitch SimplLetToCase = ILIT(7) -tagOf_SimplSwitch SimplMayDeleteConjurableIds = ILIT(9) -tagOf_SimplSwitch SimplPedanticBottoms = ILIT(10) -tagOf_SimplSwitch SimplDoArityExpand = ILIT(11) -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) --- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too! -tagOf_SimplSwitch _ = panic# "tagOf_SimplSwitch" +tagOf_SimplSwitch (SimplInlinePhase _) = ILIT(1) +tagOf_SimplSwitch (MaxSimplifierIterations _) = ILIT(2) +tagOf_SimplSwitch DontApplyRules = ILIT(3) +tagOf_SimplSwitch SimplLetToCase = ILIT(4) +tagOf_SimplSwitch NoCaseOfCase = ILIT(5) -lAST_SIMPL_SWITCH_TAG = IBOX(tagOf_SimplSwitch SimplDontFoldBackAppend) +-- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too! + +lAST_SIMPL_SWITCH_TAG = 5 \end{code} %************************************************************************ @@ -413,35 +585,44 @@ lAST_SIMPL_SWITCH_TAG = IBOX(tagOf_SimplSwitch SimplDontFoldBackAppend) \begin{code} 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 - sw_tbl = (array (0, lAST_SIMPL_SWITCH_TAG) -- bounds... all_undefined) // defined_elems - all_undefined = [ i := 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 -> +#if __GLASGOW_HASKELL__ < 405 + case sw_tbl of { Array bounds_who_needs_'em stuff -> +#else + case sw_tbl of { Array _ _ stuff -> +#endif \ switch -> case (indexArray# stuff (tagOf_SimplSwitch switch)) of - _Lift v -> v +#if __GLASGOW_HASKELL__ < 400 + Lift v -> v +#elif __GLASGOW_HASKELL__ < 403 + (# _, v #) -> v +#else + (# v #) -> v +#endif } 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 = IBOX(tagOf_SimplSwitch k) := SwBool True -- I'm here, Mom! + mk_assoc_elem k@(MaxSimplifierIterations lvl) = (IBOX(tagOf_SimplSwitch k), SwInt lvl) + mk_assoc_elem k@(SimplInlinePhase n) = (IBOX(tagOf_SimplSwitch k), SwInt n) + 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 @@ -452,6 +633,12 @@ 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} @@ -467,15 +654,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 @@ -485,3 +663,19 @@ intSwitchSet lookup_fn switch SwInt int -> Just int _ -> Nothing \end{code} + +\begin{code} +startsWith :: String -> String -> Maybe String +-- startsWith pfx (pfx++rest) = Just rest + +startsWith [] str = Just str +startsWith (c:cs) (s:ss) + = if c /= s then Nothing else startsWith cs ss +startsWith _ [] = Nothing + +endsWith :: String -> String -> Maybe String +endsWith cs ss + = case (startsWith (reverse cs) (reverse ss)) of + Nothing -> Nothing + Just rs -> Just (reverse rs) +\end{code}