X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FCmdLineOpts.lhs;h=348831a1553dc02ada03a6b3f2eb4aef5e25e6d9;hb=f98aaf1088d0b654ebf6c887c7dbebe5bb6f5f5f;hp=9af5db22f742b0db5aec0ca5eae974a477934b90;hpb=152107ddf0ccfdd52a1df3c0882fe90f4b68b66b;p=ghc-hetmet.git diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 9af5db2..348831a 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -1,135 +1,139 @@ % -% (c) The AQUA Project, Glasgow University, 1996 +% (c) The University of Glasgow, 1996-2000 % \section[CmdLineOpts]{Things to do with command-line options} \begin{code} -#include "HsVersions.h" module CmdLineOpts ( CoreToDo(..), - SimplifierSwitch(..), + SimplifierSwitch(..), isAmongSimpl, StgToDo(..), SwitchResult(..), - classifyOpts, + HscLang(..), + DynFlag(..), -- needed non-abstractly by DriverFlags + DynFlags(..), intSwitchSet, switchIsOn, + isStaticHscFlag, - maybe_CompilingGhcInternals, - opt_AllDemanded, - opt_AllStrict, + opt_PprStyle_NoPrags, + opt_PprUserLength, + opt_PprStyle_Debug, + + dopt, + + -- other dynamic flags + dopt_CoreToDo, + dopt_StgToDo, + dopt_HscLang, + dopt_OutName, + + -- profiling opts opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs, opt_AutoSccsOnIndividualCafs, - opt_CompilingGhcInternals, - opt_D_dump_absC, - opt_D_dump_asm, - opt_D_dump_deforest, - 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_AutoSccsOnDicts, + opt_SccProfilingOn, opt_DoTickyProfiling, - opt_EnsureSplittableC, + + -- language opts + opt_AllStrict, + opt_DictsStrict, + opt_MaxContextReductionDepth, + opt_IrrefutableTuples, + opt_NumbersStrict, + opt_Parallel, + opt_SMP, + + -- optimisation opts + opt_DoSemiTagging, opt_FoldrBuildOn, - opt_FoldrBuildTrace, - opt_ForConcurrent, - opt_GlasgowExts, + opt_LiberateCaseThreshold, + opt_StgDoLetNoEscapes, + opt_UnfoldCasms, + opt_UsageSPOn, + opt_UnboxStrictFields, + opt_SimplNoPreInlining, + opt_SimplDoEtaReduction, + opt_SimplDoLambdaEtaExpansion, + opt_SimplCaseOfCase, + opt_SimplCaseMerge, + opt_SimplPedanticBottoms, + opt_SimplExcessPrecision, + + -- Unfolding control + opt_UF_HiFileThreshold, + opt_UF_CreationThreshold, + opt_UF_UseThreshold, + opt_UF_FunAppDiscount, + opt_UF_KeenessFactor, + opt_UF_UpdateInPlace, + opt_UF_CheapOp, + opt_UF_DearOp, + + -- misc opts + opt_InPackage, + opt_EmitCExternDecls, + opt_EnsureSplittableC, opt_GranMacros, - opt_Haskell_1_3, - opt_HiMap, + opt_HiVersion, + opt_HistorySize, + opt_IgnoreAsserts, opt_IgnoreIfacePragmas, - opt_IgnoreStrictnessPragmas, - opt_IrrefutableEverything, - opt_IrrefutableTuples, - opt_LiberateCaseThreshold, + opt_NoHiCheck, opt_NoImplicitPrelude, - opt_NumbersStrict, opt_OmitBlackHoling, - opt_OmitDefaultInstanceMethods, opt_OmitInterfacePragmas, - opt_PprStyle_All, - opt_PprStyle_Debug, - opt_PprStyle_User, - 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 + opt_NoPruneTyDecls, + opt_NoPruneDecls, + opt_Static, + opt_Unregisterised, + opt_Verbose ) where -IMPORT_1_3(Array(array, (//))) -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -import PreludeGlaST -- bad bad bad boy, Will (_Array internals) -#else +#include "HsVersions.h" + +import Array ( array, (//) ) import GlaExts -import ArrBase --- 2.04 and later exports Lift from GlaExts -#if __GLASGOW_HASKELL__ < 204 -import PrelBase (Lift(..)) -#endif -#endif import Argv - -CHK_Ubiq() -- debugging consistency check - import Constants -- Default values for some flags +import Util +import FastTypes -import Maybes ( assocMaybe, firstJust, maybeToBool ) -import Util ( startsWith, panic, panic#, assertPanic ) +import Maybes ( firstJust ) +import 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 -``verbose'' (-v) switch is either on or off. (The \tr{-G} -switch is an exception; it's set to a string, or nothing.) +%************************************************************************ +%* * +\subsection{Command-line options} +%* * +%************************************************************************ + +The hsc command-line options are split into two categories: + + - static flags + - dynamic flags + +Static flags are represented by top-level values of type Bool or Int, +for example. They therefore have the same value throughout the +invocation of hsc. + +Dynamic flags are represented by an abstract type, DynFlags, which is +passed into hsc by the compilation manager for every compilation. +Dynamic flags are those that change on a per-compilation basis, +perhaps because they may be present in the OPTIONS pragma at the top +of a module. + +Other flag-related blurb: 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 @@ -163,24 +167,25 @@ 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 - | CoreDoFoldrBuildWorkerWrapper - | CoreDoFoldrBuildWWAnal + | CoreDoUSPInf + | CoreDoCPResult + | CoreDoGlomBinds + | CoreCSE + + | CoreDoNothing -- useful when building up lists of these things \end{code} \begin{code} data StgToDo = StgDoStaticArgs - | StgDoUpdateAnalysis | StgDoLambdaLift | StgDoMassageForProfiling -- should be (next to) last -- There's also setStgVarInfo, but its absolute "lastness" @@ -190,57 +195,115 @@ 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 - - | 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 - - | 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) - - | 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} + +%************************************************************************ +%* * +\subsection{Dynamic command-line options} +%* * +%************************************************************************ + +\begin{code} +data DynFlag + + -- debugging flags + = Opt_D_dump_all + | Opt_D_dump_most + | Opt_D_dump_absC + | Opt_D_dump_asm + | Opt_D_dump_cpranal + | 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_simpl + | Opt_D_dump_simpl_iterations + | Opt_D_dump_spec + | Opt_D_dump_stg + | Opt_D_dump_stranal + | Opt_D_dump_tc + | Opt_D_dump_types + | Opt_D_dump_rules + | Opt_D_dump_usagesp + | Opt_D_dump_cse + | 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_dump_simpl_stats + | Opt_D_source_stats + | Opt_D_verbose_core2core + | Opt_D_verbose_stg2stg + | Opt_D_dump_hi_diffs + | Opt_D_dump_minimal_imports + | Opt_DoCoreLinting + | Opt_DoStgLinting + | Opt_DoUSPLinting + + | 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 + + -- language opts + | Opt_AllowOverlappingInstances + | Opt_AllowUndecidableInstances + | Opt_GlasgowExts + | Opt_Generics + + -- misc + | Opt_ReportCompile + deriving (Eq) + +data DynFlags = DynFlags { + coreToDo :: CoreToDo, + stgToDo :: StgToDo, + hscLang :: HscLang, + hscOutName :: String, -- name of the file in which to place output + flags :: [DynFlag] + } + +dopt :: DynFlag -> DynFlags -> Bool +dopt f dflags = f `elem` (flags dflags) + +dopt_CoreToDo :: DynFlags -> CoreToDo +dopt_CoreToDo = coreToDo + +dopt_StgToDo :: DynFlags -> StgToDo +dopt_StgToDo = stgToDo + +dopt_OutName :: DynFlags -> String +dopt_OutName = hscOutName + +data HscLang + = HscC + | HscAsm + | HscJava + | HscInterpreter + +dopt_HscLang :: DynFlags -> HscLang +dopt_HscLang = hscLang \end{code} %************************************************************************ @@ -250,12 +313,13 @@ data SimplifierSwitch %************************************************************************ \begin{code} -lookUp :: FAST_STRING -> Bool -lookup_int :: String -> Maybe Int -lookup_def_int :: String -> Int -> 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 = sw `elem` argv lookup_str sw = firstJust (map (startsWith sw) unpacked_opts) @@ -267,227 +331,183 @@ 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 ] +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 + 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. + +unpacked_opts :: [String] +unpacked_opts = + concat $ + map (expandAts) $ + map _UNPK_ argv + where + expandAts ('@':fname) = words (unsafePerformIO (readFile fname)) + expandAts l = [l] +-} \end{code} +%************************************************************************ +%* * +\subsection{Static options} +%* * +%************************************************************************ + \begin{code} -opt_AllDemanded = lookUp SLIT("-fall-demanded") -opt_AllStrict = lookUp SLIT("-fall-strict") +-- debugging opts +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 + +-- 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_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") -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_AutoSccsOnDicts = lookUp SLIT("-fauto-sccs-on-dicts") +opt_SccProfilingOn = lookUp SLIT("-fscc-profiling") opt_DoTickyProfiling = lookUp SLIT("-fticky-ticky") -opt_DoEtaReduction = lookUp SLIT("-fdo-eta-reduction") -opt_EnsureSplittableC = lookUp SLIT("-fglobalise-toplev-names") + +-- language opts +opt_AllStrict = lookUp SLIT("-fall-strict") +opt_DictsStrict = lookUp SLIT("-fdicts-strict") +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_DoSemiTagging = lookUp SLIT("-fsemi-tagging") opt_FoldrBuildOn = lookUp SLIT("-ffoldr-build-on") -opt_FoldrBuildTrace = lookUp SLIT("-ffoldr-build-trace") -opt_ForConcurrent = lookUp SLIT("-fconcurrent") +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") + +{- + The optional '-inpackage=P' flag tells what package + we are compiling this module for. + The Prelude, for example is compiled with '-package prelude' +-} +opt_InPackage = case lookup_str "-inpackage=" of + Just p -> _PK_ p + Nothing -> SLIT("Main") -- The package name if none is specified + +opt_EmitCExternDecls = lookUp SLIT("-femit-extern-decls") +opt_EnsureSplittableC = lookUp SLIT("-fglobalise-toplev-names") opt_GranMacros = lookUp SLIT("-fgransim") -opt_GlasgowExts = lookUp SLIT("-fglasgow-exts") -opt_Haskell_1_3 = lookUp SLIT("-fhaskell-1.3") -opt_HiMap = lookup_str "-himap=" -- file saying where to look for .hi files +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_IgnoreStrictnessPragmas = lookUp SLIT("-fignore-strictness-pragmas") -opt_IrrefutableEverything = lookUp SLIT("-firrefutable-everything") -opt_IrrefutableTuples = lookUp SLIT("-firrefutable-tuples") +opt_NoHiCheck = lookUp SLIT("-fno-hi-version-check") 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} -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) +-- 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") +opt_SimplExcessPrecision = lookUp SLIT("-fexcess-precision") + +-- 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_FunAppDiscount = lookup_def_int "-funfolding-fun-discount" (6::Int) -- It's great to inline a fn +opt_UF_KeenessFactor = lookup_def_float "-funfolding-keeness-factor" (1.5::Float) +opt_UF_UpdateInPlace = lookUp SLIT("-funfolding-update-in-place") + +opt_UF_CheapOp = ( 1 :: Int) -- Only one instruction; and the args are charged for +opt_UF_DearOp = ( 4 :: Int) + +opt_NoPruneDecls = lookUp SLIT("-fno-prune-decls") +opt_NoPruneTyDecls = lookUp SLIT("-fno-prune-tydecls") +opt_Static = lookUp SLIT("-static") +opt_Unregisterised = lookUp SLIT("-funregisterised") +opt_Verbose = lookUp SLIT("-v") \end{code} - +%************************************************************************ +%* * +\subsection{List of static hsc flags} +%* * +%************************************************************************ \begin{code} -classifyOpts :: ([CoreToDo], -- Core-to-Core processing spec - [StgToDo]) -- STG-to-STG processing spec - -classifyOpts = sep argv [] [] -- accumulators... - where - sep :: [FAST_STRING] -- cmd-line opts (input) - -> [CoreToDo] -> [StgToDo] -- to_do accumulators - -> ([CoreToDo], [StgToDo]) -- result - - sep [] core_td stg_td -- all done! - = (reverse core_td, reverse stg_td) - -# 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 - - "-fsimplify" -> -- gather up SimplifierSwitches specially... - 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) - "-fliberate-case" -> CORE_TD(CoreLiberateCase) - "-fprint-core" -> CORE_TD(CoreDoPrintCore) - "-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) - - "-fstg-static-args" -> STG_TD(StgDoStaticArgs) - "-fupdate-analysis" -> STG_TD(StgDoUpdateAnalysis) - "-dstg-stats" -> STG_TD(D_stg_stats) - "-flambda-lift" -> STG_TD(StgDoLambdaLift) - "-fmassage-stg-for-profiling" -> STG_TD(StgDoMassageForProfiling) - - _ -> -- NB: the driver is really supposed to handle bad options - IGNORE_ARG() - - ---------------- - - 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. - -#ifdef DEBUG - simpl_sep input@[] simpl_sw core_td stg_td - = panic "simpl_sep []" -#endif - - -- The SimplifierSwitches should be delimited by "(" and ")". - - simpl_sep (opt1:opts) simpl_sw core_td stg_td - = case (_UNPK_ opt1) of - "(" -> 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-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) - "-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) - - o | starts_with_msi -> SIMPL_SW(MaxSimplifierIterations (read after_msi)) - where - maybe_msi = startsWith "-fmax-simplifier-iterations" o - starts_with_msi = maybeToBool maybe_msi - (Just after_msi) = maybe_msi - - _ -> -- NB: the driver is really supposed to handle bad options - simpl_sep opts simpl_sw core_td stg_td +isStaticHscFlag f = + f `elem` [ + "-fauto-sccs-on-all-toplevs", + "-fauto-sccs-on-exported-toplevs", + "-fauto-sccs-on-individual-cafs", + "-fauto-sccs-on-dicts", + "-fscc-profiling", + "-fticky-ticky", + "-fall-strict", + "-fdicts-strict", + "-fgenerics", + "-firrefutable-tuples", + "-fnumbers-strict", + "-fparallel", + "-fsmp", + "-fsemi-tagging", + "-ffoldr-build-on", + "-flet-no-escape", + "-funfold-casms-in-hi-file", + "-fusagesp-on", + "-funbox-strict-fields", + "-femit-extern-decls", + "-fglobalise-toplev-names", + "-fgransim", + "-fignore-asserts", + "-fignore-interface-pragmas", + "-fno-hi-version-check", + "-fno-implicit-prelude", + "-dno-black-holing", + "-fomit-interface-pragmas", + "-fno-pre-inlining", + "-fdo-eta-reduction", + "-fdo-lambda-eta-expansion", + "-fcase-of-case", + "-fcase-merge", + "-fpedantic-bottoms", + "-fexcess-precision", + "-funfolding-update-in-place", + "-freport-compile", + "-fno-prune-decls", + "-fno-prune-tydecls", + "-static", + "-funregisterised", + "-v" ] + || any (flip prefixMatch f) [ + "-fcontext-stack", + "-fliberate-case-threshold", + "-fhi-version=", + "-fhistory-size", + "-funfolding-interface-threshold", + "-funfolding-creation-threshold", + "-funfolding-use-threshold", + "-funfolding-fun-discount", + "-funfolding-keeness-factor" + ] \end{code} %************************************************************************ @@ -496,49 +516,26 @@ classifyOpts = sep argv [] [] -- accumulators... %* * %************************************************************************ -In spite of the @Produce*@ and @SccGroup@ constructors, these things -behave just like enumeration types. +These things behave just like enumeration types. \begin{code} instance Eq SimplifierSwitch where - a == b = tagOf_SimplSwitch a _EQ_ tagOf_SimplSwitch b + a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b 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 EssentialUnfoldingsOnly = ILIT(19) -tagOf_SimplSwitch ShowSimplifierProgress = ILIT(20) -tagOf_SimplSwitch (MaxSimplifierIterations _) = ILIT(21) -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) + a < b = tagOf_SimplSwitch a <# tagOf_SimplSwitch b + a <= b = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b --- 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) + +-- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too! -lAST_SIMPL_SWITCH_TAG = IBOX(tagOf_SimplSwitch SimplCaseScrutinee) +lAST_SIMPL_SWITCH_TAG = 5 \end{code} %************************************************************************ @@ -548,24 +545,7 @@ lAST_SIMPL_SWITCH_TAG = IBOX(tagOf_SimplSwitch SimplCaseScrutinee) %************************************************************************ \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 -- Switches mentioned later occur *earlier* -- in the list; defaults right at the end. = let @@ -574,25 +554,37 @@ isAmongSimpl on_switches -- Switches mentioned later occur *earlier* -- 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 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 -> +#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) SET_TO SwInt lvl - - mk_assoc_elem k = IBOX(tagOf_SimplSwitch k) SET_TO 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 @@ -601,15 +593,14 @@ isAmongSimpl on_switches -- Switches mentioned later occur *earlier* else switch : switches_so_far where sw `is_elem` [] = False - sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) _EQ_ (tagOf_SimplSwitch s) + sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s) || sw `is_elem` ss \end{code} Default settings for simplifier switches \begin{code} -defaultSimplSwitches = [MaxSimplifierIterations 1 - ] +defaultSimplSwitches = [MaxSimplifierIterations 1] \end{code} %************************************************************************ @@ -627,15 +618,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 @@ -645,3 +627,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}