X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FCmdLineOpts.lhs;h=d0e8859e31dd8df3587cffe517cba9724d400df8;hb=2b4d4dcc7f2bb1e90a7c06f111c8460b6348920a;hp=104a7e5e93baca1671684761061dc580cbfd4ce2;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 104a7e5..d0e8859 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -1,39 +1,200 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The University of Glasgow, 1996-2000 % \section[CmdLineOpts]{Things to do with command-line options} \begin{code} -#include "HsVersions.h" module CmdLineOpts ( - CmdLineInfo(..), SwitchResult(..), - GlobalSwitch(..), SimplifierSwitch(..), CoreToDo(..), + SimplifierSwitch(..), isAmongSimpl, StgToDo(..), -#ifdef DPH - PodizeToDo(..), -#endif {- Data Parallel Haskell -} - - classifyOpts, - switchIsOn, stringSwitchSet, intSwitchSet, - - -- to make the interface self-sufficient - Maybe, MainIO(..) + SwitchResult(..), + HscLang(..), + DynFlag(..), -- needed non-abstractly by DriverFlags + DynFlags(..), + + intSwitchSet, + switchIsOn, + isStaticHscFlag, + + -- debugging opts + dopt_D_dump_absC, + dopt_D_dump_asm, + dopt_D_dump_cpranal, + dopt_D_dump_cse, + dopt_D_dump_deriv, + dopt_D_dump_ds, + dopt_D_dump_flatC, + dopt_D_dump_foreign, + dopt_D_dump_hi_diffs, + dopt_D_dump_inlinings, + dopt_D_dump_occur_anal, + dopt_D_dump_parsed, + dopt_D_dump_realC, + dopt_D_dump_rn, + dopt_D_dump_rules, + dopt_D_dump_simpl, + dopt_D_dump_simpl_iterations, + dopt_D_dump_simpl_stats, + dopt_D_dump_spec, + dopt_D_dump_stg, + dopt_D_dump_stranal, + dopt_D_dump_tc, + dopt_D_dump_types, + dopt_D_dump_usagesp, + dopt_D_dump_worker_wrapper, + dopt_D_show_passes, + dopt_D_dump_rn_trace, + dopt_D_dump_rn_stats, + dopt_D_dump_stix, + dopt_D_dump_minimal_imports, + dopt_D_source_stats, + dopt_D_verbose_core2core, + dopt_D_verbose_stg2stg, + dopt_DoCoreLinting, + dopt_DoStgLinting, + dopt_DoUSPLinting, + + opt_PprStyle_NoPrags, + opt_PprUserLength, + opt_PprStyle_Debug, + + -- other dynamic flags + dopt_CoreToDo, + dopt_StgToDo, + + -- 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, + dopt_AllowOverlappingInstances, + dopt_AllowUndecidableInstances, + dopt_GlasgowExts, + opt_Generics, + opt_IrrefutableTuples, + opt_NumbersStrict, + opt_Parallel, + opt_SMP, + + -- optimisation opts + 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, + 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_HiVersion, + opt_HistorySize, + opt_IgnoreAsserts, + opt_IgnoreIfacePragmas, + opt_NoHiCheck, + opt_NoImplicitPrelude, + opt_OmitBlackHoling, + opt_OmitInterfacePragmas, + opt_NoPruneTyDecls, + opt_NoPruneDecls, + opt_ReportCompile, + opt_Static, + opt_Unregisterised, + opt_Verbose, + + -- Code generation + opt_UseVanillaRegs, + opt_UseFloatRegs, + opt_UseDoubleRegs, + opt_UseLongRegs ) where -import MainMonad -import Maybes ( maybeToBool, Maybe(..) ) -import Outputable +#include "HsVersions.h" + +import Array ( array, (//) ) +import GlaExts +import Argv +import Constants -- Default values for some flags import Util -#ifdef __GLASGOW_HASKELL__ -import PreludeGlaST -- bad bad bad boy, Will +import FastTypes + +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 @@ -45,31 +206,17 @@ 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}). -We use function @classifyOpts@ to take raw command-line arguments from -@GetArgs@ and get back the @CmdLineInfo@, which is what we really -want. - %************************************************************************ %* * -\subsection[CmdLineOpts-datatype]{Datatypes associated with command-line options} +\subsection{Datatypes associated with command-line options} %* * %************************************************************************ \begin{code} -type CmdLineInfo - = (GlobalSwitch -> SwitchResult, -- Switch lookup function - [CoreToDo], -- Core-to-core spec -#ifdef DPH - [PodizeToDo], -- Podizer spec - [CoreToDo], -- post podized Core-to-core spec -#endif - [StgToDo] -- Stg-to-stg spec - ) - data SwitchResult - = SwBool Bool -- on/off - | SwString String -- nothing or a String - | SwInt Int -- nothing or an Int + = SwBool Bool -- on/off + | SwString FAST_STRING -- nothing or a String + | SwInt Int -- nothing or an Int \end{code} \begin{code} @@ -81,30 +228,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. - - | CoreDoArityAnalysis -- UNUSED right now - | CoreDoCalcInlinings1 - | CoreDoCalcInlinings2 | CoreDoFloatInwards - | CoreDoFullLaziness + | CoreDoFloatOutwards Bool -- True <=> float lambdas to top level | CoreLiberateCase | CoreDoPrintCore | CoreDoStaticArgs | CoreDoStrictness + | CoreDoWorkerWrapper | CoreDoSpecialising - | CoreDoDeforest - | CoreDoAutoCostCentres - | CoreDoFoldrBuildWorkerWrapper - | CoreDoFoldrBuildWWAnal --- ANDY: ---| CoreDoHaskPrint ---| CoreDoHaskLetlessPrint + | 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" @@ -113,830 +255,479 @@ data StgToDo \end{code} \begin{code} -#ifdef DPH -data PodizeToDo - = PodizeNeeded Int -- Which dimensioned PODs need vectorizing -#endif {- Data Parallel Haskell -} +data SimplifierSwitch + = MaxSimplifierIterations Int + | SimplInlinePhase Int + | DontApplyRules + | NoCaseOfCase + | SimplLetToCase \end{code} -@GlobalSwitches@ may be visible everywhere in the compiler. -@SimplifierSwitches@ (which follow) are visible only in the main -Core-to-Core simplifier. +%************************************************************************ +%* * +\subsection{Dynamic command-line options} +%* * +%************************************************************************ \begin{code} -data GlobalSwitch - = ProduceC String -- generate C output into this file - | ProduceS String -- generate native-code assembler into this file - | ProduceHi String -- generate .hi interface into this file ---UNUSED: | ProduceHu String -- generate .hu usage-info into this file - - | AsmTarget String -- architecture we are generating code for - | ForConcurrent - - | Haskell_1_3 -- if set => Haskell 1.3; else 1.2 - | GlasgowExts -- Glasgow Haskell extensions allowed - | CompilingPrelude -- Compiling prelude source - - | HideBuiltinNames -- fiddle builtin namespace; used for compiling Prelude - | HideMostBuiltinNames - | EnsureSplittableC String -- (by globalising all top-level Ids w/ this String) - - | Verbose - | PprStyle_User -- printing "level" (mostly for debugging) - | PprStyle_Debug - | PprStyle_All - - | DoCoreLinting -- paranoia flags - | EmitArityChecks - - | OmitInterfacePragmas - | OmitDerivedRead - | OmitReexportedInstances - - | UnfoldingUseThreshold Int -- global one; see also SimplUnf... - | UnfoldingCreationThreshold Int -- ditto - | UnfoldingOverrideThreshold Int - - | ReportWhyUnfoldingsDisallowed - | UseGetMentionedVars - | ShowPragmaNameErrs - | NameShadowingNotOK - | SigsRequired - - | SccProfilingOn - | AutoSccsOnExportedToplevs - | AutoSccsOnAllToplevs - | AutoSccsOnIndividualCafs ---UNUSED: | AutoSccsOnIndividualDicts - | SccGroup String -- name of "group" for this cost centres in this module - - | DoTickyProfiling - - | DoSemiTagging - - -- ToDo: turn these into SimplifierSwitches? - | FoldrBuildOn -- If foldr/build-style transformations are on. - -- See also SimplDoFoldrBuild, which is used - -- inside the simplifier. - | FoldrBuildTrace -- show all foldr/build optimisations. - - | SpecialiseImports -- Treat non-essential spec requests as errors - | ShowImportSpecs -- Output spec requests for non-essential specs - | OmitUnspecialisedCode -- ToDo? (Patrick) - | SpecialiseOverloaded - | SpecialiseUnboxed - | SpecialiseAll - | SpecialiseTrace - - -- this batch of flags is for particular experiments; - -- v unlikely to be used in any other circumstance ---UNUSED: | OmitStkChecks - | OmitBlackHoling - | StgDoLetNoEscapes - | IgnoreStrictnessPragmas -- ToDo: still useful? - | IrrefutableTuples -- We inject extra "LazyPat"s in the typechecker - | IrrefutableEverything -- (TcPat); doing it any earlier would mean that - -- deriving-generated code wouldn't be irrefutablified. - | AllStrict - | AllDemanded - --- NOT REALLY USED: | D_dump_type_info -- for Robin Popplestone stuff - - | D_dump_rif2hs -- debugging: print out various things - | D_dump_rn4 - | D_dump_tc - | D_dump_deriv - | D_dump_ds - | D_dump_occur_anal - | D_dump_simpl - | D_dump_spec - | D_dump_stranal - | D_dump_deforest - | D_dump_stg - | D_dump_absC - | D_dump_flatC - | D_dump_realC - | D_dump_asm - | D_dump_core_passes -- A Gill-ism - | D_dump_core_passes_info -- Yet another Gill-ism - - | D_verbose_core2core - | D_verbose_stg2stg - | D_simplifier_stats - -{- ???? - | Extra__Flag1 - | Extra__Flag2 - | Extra__Flag3 - | Extra__Flag4 - | Extra__Flag5 - | Extra__Flag6 - | Extra__Flag7 - | Extra__Flag8 - | Extra__Flag9 --} - -#ifdef DPH - | PodizeIntelligent - | PodizeAggresive - | PodizeVeryAggresive - | PodizeExtremelyAggresive - | D_dump_pod - | D_dump_psimpl - | D_dump_nextC -#endif {- Data Parallel Haskell -} +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 + + -- language opts + | Opt_AllowOverlappingInstances + | Opt_AllowUndecidableInstances + | Opt_GlasgowExts + deriving (Eq) + +data DynFlags = DynFlags { + coreToDo :: CoreToDo, + stgToDo :: StgToDo, + hscLang :: HscLang, + flags :: [DynFlag] + } + +boolOpt :: DynFlag -> DynFlags -> Bool +boolOpt f dflags = f `elem` (flags dflags) + +dopt_D_dump_all = boolOpt Opt_D_dump_all +dopt_D_dump_most = boolOpt Opt_D_dump_most +dopt_D_dump_absC = boolOpt Opt_D_dump_absC +dopt_D_dump_asm = boolOpt Opt_D_dump_asm +dopt_D_dump_cpranal = boolOpt Opt_D_dump_cpranal +dopt_D_dump_deriv = boolOpt Opt_D_dump_deriv +dopt_D_dump_ds = boolOpt Opt_D_dump_ds +dopt_D_dump_flatC = boolOpt Opt_D_dump_flatC +dopt_D_dump_foreign = boolOpt Opt_D_dump_foreign +dopt_D_dump_inlinings = boolOpt Opt_D_dump_inlinings +dopt_D_dump_occur_anal = boolOpt Opt_D_dump_occur_anal +dopt_D_dump_parsed = boolOpt Opt_D_dump_parsed +dopt_D_dump_realC = boolOpt Opt_D_dump_realC +dopt_D_dump_rn = boolOpt Opt_D_dump_rn +dopt_D_dump_simpl = boolOpt Opt_D_dump_simpl +dopt_D_dump_simpl_iterations = boolOpt Opt_D_dump_simpl_iterations +dopt_D_dump_spec = boolOpt Opt_D_dump_spec +dopt_D_dump_stg = boolOpt Opt_D_dump_stg +dopt_D_dump_stranal = boolOpt Opt_D_dump_stranal +dopt_D_dump_tc = boolOpt Opt_D_dump_tc +dopt_D_dump_types = boolOpt Opt_D_dump_types +dopt_D_dump_rules = boolOpt Opt_D_dump_rules +dopt_D_dump_usagesp = boolOpt Opt_D_dump_usagesp +dopt_D_dump_cse = boolOpt Opt_D_dump_cse +dopt_D_dump_worker_wrapper = boolOpt Opt_D_dump_worker_wrapper +dopt_D_show_passes = boolOpt Opt_D_show_passes +dopt_D_dump_rn_trace = boolOpt Opt_D_dump_rn_trace +dopt_D_dump_rn_stats = boolOpt Opt_D_dump_rn_stats +dopt_D_dump_stix = boolOpt Opt_D_dump_stix +dopt_D_dump_simpl_stats = boolOpt Opt_D_dump_simpl_stats +dopt_D_source_stats = boolOpt Opt_D_source_stats +dopt_D_verbose_core2core = boolOpt Opt_D_verbose_core2core +dopt_D_verbose_stg2stg = boolOpt Opt_D_verbose_stg2stg +dopt_D_dump_hi_diffs = boolOpt Opt_D_dump_hi_diffs +dopt_D_dump_minimal_imports = boolOpt Opt_D_dump_minimal_imports +dopt_DoCoreLinting = boolOpt Opt_DoCoreLinting +dopt_DoStgLinting = boolOpt Opt_DoStgLinting +dopt_DoUSPLinting = boolOpt Opt_DoUSPLinting + +dopt_AllowOverlappingInstances = boolOpt Opt_AllowOverlappingInstances +dopt_AllowUndecidableInstances = boolOpt Opt_AllowUndecidableInstances +dopt_GlasgowExts = boolOpt Opt_GlasgowExts + +dopt_CoreToDo :: DynFlags -> CoreToDo +dopt_CoreToDo = coreToDo + +dopt_StgToDo :: DynFlags -> StgToDo +dopt_StgToDo = stgToDo + +data HscLang + = HscC + | HscAsm + | HscJava + deriving Eq + +dopt_HscLang :: DynFlags -> HscLang +dopt_HscLang = hscLang \end{code} -\begin{code} -data SimplifierSwitch - = SimplOkToDupCode - | SimplFloatLetsExposingWHNF - | SimplOkToFloatPrimOps - | SimplAlwaysFloatLetsFromLets - | SimplDoCaseElim - | SimplReuseCon - | SimplCaseOfCase - | SimplLetToCase ---UNUSED: | SimplOkToInlineInLambdas - | 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. - | SimplDoNewOccurAnal -- use the *new*, all singing, Occurance analysis - | SimplDoInlineFoldrBuild - -- inline foldr/build (*after* f/b rule is used) +%************************************************************************ +%* * +\subsection{Classifying command-line options} +%* * +%************************************************************************ - | IgnoreINLINEPragma - | SimplDoLambdaEtaExpansion ---UNUSED: | SimplDoMonadEtaExpansion +\begin{code} +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 - | SimplDoEtaReduction +lookUp sw = sw `elem` argv + +lookup_str sw = firstJust (map (startsWith sw) unpacked_opts) - | EssentialUnfoldingsOnly -- never mind the thresholds, only - -- do unfoldings that *must* be done - -- (to saturate constructors and primitives) +lookup_int sw = case (lookup_str sw) of + Nothing -> Nothing + Just xx -> Just (read xx) - | ShowSimplifierProgress -- report counts on every interation +lookup_def_int sw def = case (lookup_str sw) of + Nothing -> def -- Use default + Just xx -> read xx - | MaxSimplifierIterations Int +lookup_def_char sw def = case (lookup_str sw) of + Just (xx:_) -> xx + _ -> def -- Use default - | SimplUnfoldingUseThreshold Int -- per-simplification variants - | SimplUnfoldingCreationThreshold Int +lookup_def_float sw def = case (lookup_str sw) of + Nothing -> def -- Use default + Just xx -> read xx - | KeepSpecPragmaIds -- We normally *toss* Ids we can do without - | KeepUnusedBindings +unpacked_opts = map _UNPK_ argv {- - | Extra__SimplFlag1 - | Extra__SimplFlag2 - | Extra__SimplFlag3 - | Extra__SimplFlag4 - | Extra__SimplFlag5 - | Extra__SimplFlag6 - | Extra__SimplFlag7 - | Extra__SimplFlag8 + 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[CmdLineOpts-classify]{Classifying command-line options} +\subsection{Static options} %* * %************************************************************************ \begin{code} -classifyOpts :: [String] -- cmd-line args, straight from GetArgs - -> MainIO CmdLineInfo --- The MainIO bit is because we might find an unknown flag --- in which case we print an error message - -#ifndef DPH -classifyOpts opts - = sep opts [] [] [] -- accumulators... - where - sep :: [String] -- cmd-line opts (input) - -> [GlobalSwitch] -- switch accumulator - -> [CoreToDo] -> [StgToDo] -- to_do accumulators - -> MainIO CmdLineInfo -- result - - sep [] glob_sw core_td stg_td - = returnMn ( - isAmong glob_sw, - reverse core_td, - reverse stg_td - ) - - sep (opt1:opts) glob_sw core_td stg_td - -#else {- Data Parallel Haskell -} -classifyOpts opts - = sep opts [] [] [] [] [] -- accumulators... - where - sep :: [String] -- cmd-line opts (input) - -> [GlobalSwitch] -- switch accumulator - -> [CoreToDo] -> [PodizeToDo] -- to_do accumulators - -> [CoreToDo] -> [StgToDo] - -> MainIO CmdLineInfo -- result - - -- see also the related "simpl_sep" function, used - -- to collect up the SimplifierSwitches for a "-fsimplify". - - sep [] glob_sw core_td pod_td pcore_td stg_td - = returnMn ( - isAmong glob_sw, - reverse core_td, - reverse pod_td, - reverse pcore_td, - reverse stg_td - ) - - sep (opt1:opts) glob_sw core_td pod_td pcore_td stg_td -#endif {- Data Parallel Haskell -} - -#ifndef DPH -#define GLOBAL_SW(switch) sep opts (switch:glob_sw) core_td stg_td -#define CORE_TD(to_do) sep opts glob_sw (to_do:core_td) stg_td -#define POD_TD(to_do) sep opts glob_sw core_td stg_td -#define PAR_CORE_TD(to_do) sep opts glob_sw core_td stg_td -#define BOTH_CORE_TD(to_do) sep opts glob_sw (to_do:core_td) stg_td -#define STG_TD(to_do) sep opts glob_sw core_td (to_do:stg_td) -#define IGNORE_ARG() sep opts glob_sw core_td stg_td - -#else - -#define GLOBAL_SW(switch) sep opts (switch:glob_sw) core_td pod_td pcore_td stg_td -#define CORE_TD(to_do) sep opts glob_sw (to_do:core_td) pod_td pcore_td stg_td -#define POD_TD(to_do) sep opts glob_sw core_td (to_do:pod_td) pcore_td stg_td -#define PAR_CORE_TD(do) sep opts glob_sw core_td pod_td (do:pcore_td) stg_td -#define BOTH_CORE_TD(do) sep opts glob_sw (do:core_td) pod_td (do:pcore_td) stg_td -#define STG_TD(to_do) sep opts glob_sw core_td pod_td pcore_td (to_do:stg_td) -#define IGNORE_ARG() sep opts glob_sw core_td pod_td pcore_td stg_td - -#endif {- Data Parallel Haskell -} - --- ToDo: DPH-ify -#define GLOBAL_SIMPL_SW(switch) simpl_sep opts (switch:simpl_sw) glob_sw core_td stg_td - - = let - maybe_fasm = starts_with "-fasm-" opt1 - maybe_G = starts_with "-G" opt1 - maybe_C = starts_with "-C" opt1 - maybe_S = starts_with "-S" opt1 - maybe_hi = starts_with "-hi" opt1 - maybe_hu = starts_with "-hu" opt1 - maybe_uut = starts_with "-funfolding-use-threshold" opt1 - maybe_uct = starts_with "-funfolding-creation-threshold" opt1 - maybe_uot = starts_with "-funfolding-override-threshold" opt1 - maybe_gtn = starts_with "-fglobalise-toplev-names" opt1 - starts_with_fasm = maybeToBool maybe_fasm - starts_with_G = maybeToBool maybe_G - starts_with_C = maybeToBool maybe_C - starts_with_S = maybeToBool maybe_S - starts_with_hi = maybeToBool maybe_hi - starts_with_hu = maybeToBool maybe_hu - starts_with_uut = maybeToBool maybe_uut - starts_with_uct = maybeToBool maybe_uct - starts_with_uot = maybeToBool maybe_uot - starts_with_gtn = maybeToBool maybe_gtn - (Just after_fasm) = maybe_fasm - (Just after_G) = maybe_G - (Just after_C) = maybe_C - (Just after_S) = maybe_S - (Just after_hi) = maybe_hi - (Just after_hu) = maybe_hu - (Just after_uut) = maybe_uut - (Just after_uct) = maybe_uct - (Just after_uot) = maybe_uot - (Just after_gtn) = maybe_gtn - in - case opt1 of -- the non-"just match a string" options are at the end... - ',' : _ -> IGNORE_ARG() -- it is for the parser - "-ddump-rif2hs" -> GLOBAL_SW(D_dump_rif2hs) - "-ddump-rn4" -> GLOBAL_SW(D_dump_rn4) - "-ddump-tc" -> GLOBAL_SW(D_dump_tc) - "-ddump-deriv" -> GLOBAL_SW(D_dump_deriv) - "-ddump-ds" -> GLOBAL_SW(D_dump_ds) - "-ddump-stranal" -> GLOBAL_SW(D_dump_stranal) - "-ddump-deforest"-> GLOBAL_SW(D_dump_deforest) - "-ddump-spec" -> GLOBAL_SW(D_dump_spec) - "-ddump-simpl" -> GLOBAL_SW(D_dump_simpl) - "-ddump-occur-anal" -> GLOBAL_SW(D_dump_occur_anal) --- NOT REALLY USED: "-ddump-type-info" -> GLOBAL_SW(D_dump_type_info) -#ifdef DPH - "-ddump-pod" -> GLOBAL_SW(D_dump_pod) - "-ddump-psimpl"-> GLOBAL_SW(D_dump_psimpl) - "-ddump-nextC" -> GLOBAL_SW(D_dump_nextC) -#endif {- Data Parallel Haskell -} - - "-ddump-stg" -> GLOBAL_SW(D_dump_stg) - "-ddump-absC" -> GLOBAL_SW(D_dump_absC) - "-ddump-flatC"-> GLOBAL_SW(D_dump_flatC) - "-ddump-realC"-> GLOBAL_SW(D_dump_realC) - "-ddump-asm" -> GLOBAL_SW(D_dump_asm) - - "-ddump-core-passes" -> GLOBAL_SW(D_dump_core_passes) --- ANDY: "-ddump-haskell" -> GLOBAL_SW(D_dump_core_passes_info) - "-dsimplifier-stats" -> GLOBAL_SW(D_simplifier_stats) - - "-dverbose-simpl" ->GLOBAL_SW(D_verbose_core2core) - "-dverbose-stg" -> GLOBAL_SW(D_verbose_stg2stg) - - "-fuse-get-mentioned-vars" -> GLOBAL_SW(UseGetMentionedVars) - - "-fhaskell-1.3" -> GLOBAL_SW(Haskell_1_3) - "-dcore-lint" -> GLOBAL_SW(DoCoreLinting) - "-fomit-interface-pragmas" -> GLOBAL_SW(OmitInterfacePragmas) - "-fignore-strictness-pragmas" -> GLOBAL_SW(IgnoreStrictnessPragmas) - "-firrefutable-tuples" -> GLOBAL_SW(IrrefutableTuples) - "-firrefutable-everything" -> GLOBAL_SW(IrrefutableEverything) - "-fall-strict" -> GLOBAL_SW(AllStrict) - "-fall-demanded" -> GLOBAL_SW(AllDemanded) - - "-fsemi-tagging" -> GLOBAL_SW(DoSemiTagging) - - "-fsimplify" -> -- gather up SimplifierSwitches specially... - simpl_sep opts [] glob_sw core_td stg_td - ---UNUSED: "-farity-analysis" -> CORE_TD(CoreDoArityAnalysis) - "-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) - "-fadd-auto-sccs" -> CORE_TD(CoreDoAutoCostCentres) - "-ffoldr-build-worker-wrapper" -> CORE_TD(CoreDoFoldrBuildWorkerWrapper) - "-ffoldr-build-ww-anal" -> CORE_TD(CoreDoFoldrBuildWWAnal) ---ANDY: "-fprint-haskell-core" -> CORE_TD(CoreDoHaskPrint) --- "-fprint-haskell-letless-core" -> CORE_TD(CoreDoHaskLetlessPrint) - - "-fspecialise-overloaded" -> GLOBAL_SW(SpecialiseOverloaded) - "-fspecialise-unboxed" -> GLOBAL_SW(SpecialiseUnboxed) - "-fspecialise-all" -> GLOBAL_SW(SpecialiseAll) - "-fspecialise-imports" -> GLOBAL_SW(SpecialiseImports) - "-fshow-import-specs" -> GLOBAL_SW(ShowImportSpecs) - "-ftrace-specialisation" -> GLOBAL_SW(SpecialiseTrace) - - "-freport-disallowed-unfoldings" - -> GLOBAL_SW(ReportWhyUnfoldingsDisallowed) - - "-fomit-derived-read" -> GLOBAL_SW(OmitDerivedRead) - - "-ffoldr-build-on" -> GLOBAL_SW(FoldrBuildOn) - "-ffoldr-build-trace" -> GLOBAL_SW(FoldrBuildTrace) - - "-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) - - "-flet-no-escape" -> GLOBAL_SW(StgDoLetNoEscapes) - -#ifdef DPH - "-fpodize-vector" -> POD_TD(PodizeNeeded 1) - "-fpodize-matrix" -> POD_TD(PodizeNeeded 2) - "-fpodize-cube" -> POD_TD(PodizeNeeded 3) - "-fpodize-intelligent" -> GLOBAL_SW(PodizeIntelligent) - "-fpodize-aggresive" -> GLOBAL_SW(PodizeAggresive) - "-fpodize-very-aggresive" -> GLOBAL_SW(PodizeVeryAggresive) - "-fpodize-extremely-aggresive" -> GLOBAL_SW(PodizeExtremelyAggresive) -#endif {- Data Parallel Haskell -} - - "-v" -> GLOBAL_SW(Verbose) - - "-fglasgow-exts" -> GLOBAL_SW(GlasgowExts) - "-prelude" -> GLOBAL_SW(CompilingPrelude) - - "-fscc-profiling" -> GLOBAL_SW(SccProfilingOn) - "-fauto-sccs-on-exported-toplevs" -> GLOBAL_SW(AutoSccsOnExportedToplevs) - "-fauto-sccs-on-all-toplevs" -> GLOBAL_SW(AutoSccsOnAllToplevs) - "-fauto-sccs-on-individual-cafs" -> GLOBAL_SW(AutoSccsOnIndividualCafs) ---UNUSED: "-fauto-sccs-on-individual-dicts" -> GLOBAL_SW(AutoSccsOnIndividualDicts) - - "-fstg-reduction-counts" -> GLOBAL_SW(DoTickyProfiling) - - "-dppr-user" -> GLOBAL_SW(PprStyle_User) - "-dppr-debug" -> GLOBAL_SW(PprStyle_Debug) - "-dppr-all" -> GLOBAL_SW(PprStyle_All) - - "-fhide-builtin-names"-> GLOBAL_SW(HideBuiltinNames) - "-fmin-builtin-names" -> GLOBAL_SW(HideMostBuiltinNames) - - "-fconcurrent" -> GLOBAL_SW(ForConcurrent) - - "-fomit-unspecialised-code" -> GLOBAL_SW(OmitUnspecialisedCode) - "-fshow-pragma-name-errs" -> GLOBAL_SW(ShowPragmaNameErrs) - "-fname-shadowing-not-ok" -> GLOBAL_SW(NameShadowingNotOK) - "-fsignatures-required" -> GLOBAL_SW(SigsRequired) - "-fomit-reexported-instances" -> GLOBAL_SW(OmitReexportedInstances) - "-darity-checks" -> GLOBAL_SW(EmitArityChecks) ---UNUSED: "-dno-stk-chks" -> GLOBAL_SW(OmitStkChecks) - "-dno-black-holing"-> GLOBAL_SW(OmitBlackHoling) - - _ | starts_with_fasm -> GLOBAL_SW(AsmTarget after_fasm) - | starts_with_G -> GLOBAL_SW(SccGroup after_G) -- profiling "group" - | starts_with_C -> GLOBAL_SW(ProduceC after_C) -- main C output - | starts_with_S -> GLOBAL_SW(ProduceS after_S) -- main .s output - | starts_with_hi -> GLOBAL_SW(ProduceHi after_hi) -- interface ---UNUSED: | starts_with_hu -> GLOBAL_SW(ProduceHu after_hu) -- usage info - - | starts_with_uut -> GLOBAL_SW(UnfoldingUseThreshold (read after_uut)) - | starts_with_uct -> GLOBAL_SW(UnfoldingCreationThreshold (read after_uct)) - | starts_with_uot -> GLOBAL_SW(UnfoldingOverrideThreshold (read after_uot)) - - | starts_with_gtn -> GLOBAL_SW(EnsureSplittableC after_gtn) - - _ -> writeMn stderr ("*** WARNING: bad option: "++opt1++"\n") `thenMn` ( \ _ -> - -- NB: the driver is really supposed to handle bad options - IGNORE_ARG() ) - - ---------------- - - 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 - - ---------------- - - -- ToDo: DPH-ify "simpl_sep"! - - simpl_sep :: [String] -- cmd-line opts (input) - -> [SimplifierSwitch] -- simplifier-switch accumulator - -> [GlobalSwitch] -- switch accumulator - -> [CoreToDo] -> [StgToDo] -- to_do accumulators - -> MainIO CmdLineInfo -- result +-- 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 + +-- 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_Generics = lookUp SLIT("-fgenerics") +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_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") - -- "simpl_sep" tailcalls "sep" once it's seen one set - -- of SimplifierSwitches for a CoreDoSimplify. +{- + 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_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") + +-- 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_ReportCompile = lookUp SLIT("-freport-compile") +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") + +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} -#ifdef DEBUG - simpl_sep input@[] simpl_sw glob_sw core_td stg_td - = panic "simpl_sep []" -#endif +%************************************************************************ +%* * +\subsection{List of static hsc flags} +%* * +%************************************************************************ - -- The SimplifierSwitches should be delimited by "(" and ")". - - simpl_sep ("(":opts) [{-better be empty-}] glob_sw core_td stg_td - = simpl_sep opts [] glob_sw core_td stg_td - - simpl_sep (")":opts) simpl_sw glob_sw core_td stg_td - = let - this_CoreDoSimplify = CoreDoSimplify (isAmongSimpl simpl_sw) - in - sep opts glob_sw (this_CoreDoSimplify : core_td) stg_td - - simpl_sep (opt1:opts) simpl_sw glob_sw core_td stg_td - = let - maybe_suut = starts_with "-fsimpl-uf-use-threshold" opt1 - maybe_suct = starts_with "-fsimpl-uf-creation-threshold" opt1 - maybe_msi = starts_with "-fmax-simplifier-iterations" opt1 - 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 - in - case opt1 of -- the non-"just match a string" options are at the end... - "-fshow-simplifier-progress" -> GLOBAL_SIMPL_SW(ShowSimplifierProgress) - - "-fcode-duplication-ok" -> GLOBAL_SIMPL_SW(SimplOkToDupCode) - "-ffloat-lets-exposing-whnf" -> GLOBAL_SIMPL_SW(SimplFloatLetsExposingWHNF) - "-ffloat-primops-ok" -> GLOBAL_SIMPL_SW(SimplOkToFloatPrimOps) - "-falways-float-lets-from-lets" -> GLOBAL_SIMPL_SW(SimplAlwaysFloatLetsFromLets) - "-fdo-case-elim" -> GLOBAL_SIMPL_SW(SimplDoCaseElim) - "-fdo-eta-reduction" -> GLOBAL_SIMPL_SW(SimplDoEtaReduction) - "-fdo-lambda-eta-expansion" -> GLOBAL_SIMPL_SW(SimplDoLambdaEtaExpansion) ---UNUSED: "-fdo-monad-eta-expansion" -> GLOBAL_SIMPL_SW(SimplDoMonadEtaExpansion) - "-fdo-foldr-build" -> GLOBAL_SIMPL_SW(SimplDoFoldrBuild) - "-fdo-new-occur-anal" -> GLOBAL_SIMPL_SW(SimplDoNewOccurAnal) - "-fdo-arity-expand" -> GLOBAL_SIMPL_SW(SimplDoArityExpand) - "-fdo-inline-foldr-build" -> GLOBAL_SIMPL_SW(SimplDoInlineFoldrBuild) - "-freuse-con" -> GLOBAL_SIMPL_SW(SimplReuseCon) - "-fcase-of-case" -> GLOBAL_SIMPL_SW(SimplCaseOfCase) - "-flet-to-case" -> GLOBAL_SIMPL_SW(SimplLetToCase) - "-fpedantic-bottoms" -> GLOBAL_SIMPL_SW(SimplPedanticBottoms) - "-fkeep-spec-pragma-ids" -> GLOBAL_SIMPL_SW(KeepSpecPragmaIds) - "-fkeep-unused-bindings" -> GLOBAL_SIMPL_SW(KeepUnusedBindings) ---UNUSED: "-finline-in-lambdas-ok" -> GLOBAL_SIMPL_SW(SimplOkToInlineInLambdas) - "-fmay-delete-conjurable-ids" -> GLOBAL_SIMPL_SW(SimplMayDeleteConjurableIds) - "-fessential-unfoldings-only" -> GLOBAL_SIMPL_SW(EssentialUnfoldingsOnly) - "-fignore-inline-pragma" -> GLOBAL_SIMPL_SW(IgnoreINLINEPragma) - - _ | starts_with_msi -> GLOBAL_SIMPL_SW(MaxSimplifierIterations (read after_msi)) - | starts_with_suut -> GLOBAL_SIMPL_SW(SimplUnfoldingUseThreshold (read after_suut)) - | starts_with_suct -> GLOBAL_SIMPL_SW(SimplUnfoldingCreationThreshold (read after_suct)) - - _ -> writeMn stderr ("*** WARNING: bad simplifier option: "++opt1++"\n") `thenMn` ( \ _ -> - -- NB: the driver is really supposed to handle bad options - simpl_sep opts simpl_sw glob_sw core_td stg_td ) +\begin{code} +isStaticHscFlag f = + f `elem` [ + "-fwarn-duplicate-exports", + "-fwarn-hi-shadowing", + "-fwarn-incomplete-patterns", + "-fwarn-missing-fields", + "-fwarn-missing-methods", + "-fwarn-missing-signatures", + "-fwarn-name-shadowing", + "-fwarn-overlapping-patterns", + "-fwarn-simple-patterns", + "-fwarn-type-defaults", + "-fwarn-unused-binds", + "-fwarn-unused-imports", + "-fwarn-unused-matches", + "-fwarn-deprecations", + "-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} %************************************************************************ %* * -\subsection[CmdLineOpts-order]{Switch ordering} +\subsection{Switch ordering} %* * %************************************************************************ -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 GlobalSwitch where - a == b = tagOf_Switch a _EQ_ tagOf_Switch b - -instance Ord GlobalSwitch where - a < b = tagOf_Switch a _LT_ tagOf_Switch b - a <= b = tagOf_Switch a _LE_ tagOf_Switch b - 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_Switch (ProduceC _) =(ILIT(0) :: FAST_INT) -tagOf_Switch (ProduceS _) = ILIT(1) -tagOf_Switch (ProduceHi _) = ILIT(2) ---UNUSED:tagOf_Switch (ProduceHu _) = ILIT(3) -tagOf_Switch (AsmTarget _) = ILIT(4) ---UNUSED:tagOf_Switch ForParallel = ILIT(5) -tagOf_Switch ForConcurrent = ILIT(6) ---UNUSED:tagOf_Switch ForGRIP = ILIT(7) -tagOf_Switch Haskell_1_3 = ILIT(8) -tagOf_Switch GlasgowExts = ILIT(9) -tagOf_Switch CompilingPrelude = ILIT(10) -tagOf_Switch HideBuiltinNames = ILIT(11) -tagOf_Switch HideMostBuiltinNames = ILIT(12) -tagOf_Switch (EnsureSplittableC _) = ILIT(13) -tagOf_Switch Verbose = ILIT(14) -tagOf_Switch PprStyle_User = ILIT(15) -tagOf_Switch PprStyle_Debug = ILIT(16) -tagOf_Switch PprStyle_All = ILIT(17) -tagOf_Switch DoCoreLinting = ILIT(18) -tagOf_Switch EmitArityChecks = ILIT(19) -tagOf_Switch OmitInterfacePragmas = ILIT(20) -tagOf_Switch OmitDerivedRead = ILIT(21) -tagOf_Switch OmitReexportedInstances = ILIT(22) -tagOf_Switch (UnfoldingUseThreshold _) = ILIT(23) -tagOf_Switch (UnfoldingCreationThreshold _) = ILIT(24) -tagOf_Switch (UnfoldingOverrideThreshold _) = ILIT(25) -tagOf_Switch ReportWhyUnfoldingsDisallowed = ILIT(26) -tagOf_Switch UseGetMentionedVars = ILIT(27) -tagOf_Switch ShowPragmaNameErrs = ILIT(28) -tagOf_Switch NameShadowingNotOK = ILIT(29) -tagOf_Switch SigsRequired = ILIT(30) -tagOf_Switch SccProfilingOn = ILIT(31) -tagOf_Switch AutoSccsOnExportedToplevs = ILIT(32) -tagOf_Switch AutoSccsOnAllToplevs = ILIT(33) -tagOf_Switch AutoSccsOnIndividualCafs = ILIT(34) ---UNUSED:tagOf_Switch AutoSccsOnIndividualDicts = ILIT(35) -tagOf_Switch (SccGroup _) = ILIT(36) -tagOf_Switch DoTickyProfiling = ILIT(37) -tagOf_Switch DoSemiTagging = ILIT(38) -tagOf_Switch FoldrBuildOn = ILIT(39) -tagOf_Switch FoldrBuildTrace = ILIT(40) -tagOf_Switch SpecialiseImports = ILIT(41) -tagOf_Switch ShowImportSpecs = ILIT(42) -tagOf_Switch OmitUnspecialisedCode = ILIT(43) -tagOf_Switch SpecialiseOverloaded = ILIT(44) -tagOf_Switch SpecialiseUnboxed = ILIT(45) -tagOf_Switch SpecialiseAll = ILIT(46) -tagOf_Switch SpecialiseTrace = ILIT(47) ---UNUSED:tagOf_Switch OmitStkChecks = ILIT(48) -tagOf_Switch OmitBlackHoling = ILIT(49) -tagOf_Switch StgDoLetNoEscapes = ILIT(50) -tagOf_Switch IgnoreStrictnessPragmas = ILIT(51) -tagOf_Switch IrrefutableTuples = ILIT(52) -tagOf_Switch IrrefutableEverything = ILIT(53) -tagOf_Switch AllStrict = ILIT(54) -tagOf_Switch AllDemanded = ILIT(55) --- NOT REALLY USED: tagOf_Switch D_dump_type_info = ILIT(56) -tagOf_Switch D_dump_rif2hs = ILIT(57) -tagOf_Switch D_dump_rn4 = ILIT(58) -tagOf_Switch D_dump_tc = ILIT(59) -tagOf_Switch D_dump_deriv = ILIT(60) -tagOf_Switch D_dump_ds = ILIT(61) -tagOf_Switch D_dump_simpl = ILIT(62) -tagOf_Switch D_dump_spec = ILIT(63) -tagOf_Switch D_dump_occur_anal = ILIT(64) -tagOf_Switch D_dump_stranal = ILIT(65) -tagOf_Switch D_dump_stg = ILIT(66) -tagOf_Switch D_dump_absC = ILIT(67) -tagOf_Switch D_dump_flatC = ILIT(68) -tagOf_Switch D_dump_realC = ILIT(69) -tagOf_Switch D_dump_asm = ILIT(70) -tagOf_Switch D_dump_core_passes = ILIT(71) -tagOf_Switch D_dump_core_passes_info = ILIT(72) -tagOf_Switch D_verbose_core2core = ILIT(73) -tagOf_Switch D_verbose_stg2stg = ILIT(74) -tagOf_Switch D_simplifier_stats = ILIT(75) {-note below-} - -{- -tagOf_Switch Extra__Flag1 = ILIT(76) -tagOf_Switch Extra__Flag2 = ILIT(77) -tagOf_Switch Extra__Flag3 = ILIT(78) -tagOf_Switch Extra__Flag4 = ILIT(79) -tagOf_Switch Extra__Flag5 = ILIT(80) -tagOf_Switch Extra__Flag6 = ILIT(81) -tagOf_Switch Extra__Flag7 = ILIT(82) -tagOf_Switch Extra__Flag8 = ILIT(83) -tagOf_Switch Extra__Flag9 = ILIT(84) --} - -#ifndef DPH -tagOf_Switch _ = case (panic "tagOf_Switch") of -- BUG avoidance - s -> tagOf_Switch s + a < b = tagOf_SimplSwitch a <# tagOf_SimplSwitch b + a <= b = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b -lAST_SWITCH_TAG = IBOX(tagOf_Switch D_simplifier_stats) -#else {- Data Parallel Haskell -} +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) -tagOf_Switch PodizeIntelligent = ILIT(90) -tagOf_Switch PodizeAggresive = ILIT(91) -tagOf_Switch PodizeVeryAggresive = ILIT(92) -tagOf_Switch PodizeExtremelyAggresive = ILIT(93) -tagOf_Switch D_dump_pod = ILIT(94) -tagOf_Switch D_dump_psimpl = ILIT(95) -tagOf_Switch D_dump_nextC = ILIT(96) +-- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too! -tagOf_Switch _ = case (panic "tagOf_Switch") of -- BUG avoidance - s -> tagOf_Switch s - -lAST_SWITCH_TAG = IBOX(tagOf_Switch D_dump_nextC) - -#endif {- Data Parallel Haskell -} -\end{code} - -(Note For Will): Could you please leave a little extra room between -your last option and @D_dump_spec@... Thanks... jon... - -\begin{code} -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) ---UNUSED:tagOf_SimplSwitch SimplOkToInlineInLambdas = ILIT(8) -tagOf_SimplSwitch SimplMayDeleteConjurableIds = ILIT(9) -tagOf_SimplSwitch SimplPedanticBottoms = ILIT(10) -tagOf_SimplSwitch SimplDoArityExpand = ILIT(11) -tagOf_SimplSwitch SimplDoFoldrBuild = ILIT(12) -tagOf_SimplSwitch SimplDoNewOccurAnal = ILIT(13) -tagOf_SimplSwitch SimplDoInlineFoldrBuild = ILIT(14) -tagOf_SimplSwitch IgnoreINLINEPragma = ILIT(15) -tagOf_SimplSwitch SimplDoLambdaEtaExpansion = ILIT(16) ---UNUSED:tagOf_SimplSwitch SimplDoMonadEtaExpansion = ILIT(17) -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 Extra__SimplFlag1 = ILIT(26) -tagOf_SimplSwitch Extra__SimplFlag2 = ILIT(27) -tagOf_SimplSwitch Extra__SimplFlag3 = ILIT(28) -tagOf_SimplSwitch Extra__SimplFlag4 = ILIT(29) -tagOf_SimplSwitch Extra__SimplFlag5 = ILIT(30) -tagOf_SimplSwitch Extra__SimplFlag6 = ILIT(31) -tagOf_SimplSwitch Extra__SimplFlag8 = ILIT(32) --} - -tagOf_SimplSwitch _ = case (panic "tagOf_SimplSwitch") of -- BUG avoidance - s -> tagOf_SimplSwitch s - -lAST_SIMPL_SWITCH_TAG = IBOX(tagOf_SimplSwitch KeepUnusedBindings) +lAST_SIMPL_SWITCH_TAG = 5 \end{code} %************************************************************************ %* * -\subsection[CmdLineOpts-lookup]{Switch lookup} +\subsection{Switch lookup} %* * %************************************************************************ \begin{code} -isAmong :: [GlobalSwitch] -> GlobalSwitch -> SwitchResult isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult - -isAmong 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_SWITCH_TAG) -- bounds... + sw_tbl = (array (0, lAST_SIMPL_SWITCH_TAG) -- bounds... all_undefined) // defined_elems - all_undefined = [ i := SwBool False | i <- [0 .. lAST_SWITCH_TAG ] ] + all_undefined = [ (i, SwBool False) | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ] defined_elems = map mk_assoc_elem tidied_on_switches in -#ifndef __GLASGOW_HASKELL__ - \ switch -> sw_tbl ! IBOX((tagOf_Switch switch)) -- but this is fast! -#else - -- and this is faster! -- (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_Switch switch)) of - _Lift v -> v - } + case (indexArray# stuff (tagOf_SimplSwitch switch)) of +#if __GLASGOW_HASKELL__ < 400 + Lift v -> v +#elif __GLASGOW_HASKELL__ < 403 + (# _, v #) -> v +#else + (# v #) -> v #endif + } where - mk_assoc_elem k@(ProduceC str) = IBOX(tagOf_Switch k) := SwString str - mk_assoc_elem k@(ProduceS str) = IBOX(tagOf_Switch k) := SwString str - mk_assoc_elem k@(ProduceHi str) = IBOX(tagOf_Switch k) := SwString str ---UNUSED: mk_assoc_elem k@(ProduceHu str) = IBOX(tagOf_Switch k) := SwString str - mk_assoc_elem k@(SccGroup str) = IBOX(tagOf_Switch k) := SwString str - mk_assoc_elem k@(AsmTarget str) = IBOX(tagOf_Switch k) := SwString str - mk_assoc_elem k@(EnsureSplittableC str) = IBOX(tagOf_Switch k) := SwString str - - mk_assoc_elem k@(UnfoldingUseThreshold lvl) = IBOX(tagOf_Switch k) := SwInt lvl - mk_assoc_elem k@(UnfoldingCreationThreshold lvl) = IBOX(tagOf_Switch k) := SwInt lvl - mk_assoc_elem k@(UnfoldingOverrideThreshold lvl) = IBOX(tagOf_Switch k) := SwInt lvl - - mk_assoc_elem k = IBOX(tagOf_Switch 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 else switch : switches_so_far where sw `is_elem` [] = False - sw `is_elem` (s:ss) = (tagOf_Switch sw) _EQ_ (tagOf_Switch s) + sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s) || sw `is_elem` ss \end{code} -Same thing for @SimplifierSwitches@; for efficiency reasons, we -probably do {\em not} want something overloaded. - \begin{code} -isAmongSimpl on_switches - = let - tidied_on_switches = foldl rm_dups [] on_switches +Default settings for simplifier switches - 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 ] ] - - defined_elems = map mk_assoc_elem tidied_on_switches - in -#ifndef __GLASGOW_HASKELL__ - \ switch -> sw_tbl ! IBOX((tagOf_SimplSwitch switch)) -- but this is fast! -#else - -- and this is faster! - -- (avoid some unboxing, bounds checking, and other horrible things:) - case sw_tbl of { _Array bounds_who_needs_'em stuff -> - \ switch -> - case (indexArray# stuff (tagOf_SimplSwitch switch)) of - _Lift 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! - - -- 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 - 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` ss +\begin{code} +defaultSimplSwitches = [MaxSimplifierIterations 1] \end{code} %************************************************************************ %* * -\subsection[CmdLineOpts-misc]{Misc functions for command-line options} +\subsection{Misc functions for command-line options} %* * %************************************************************************ @@ -949,15 +740,6 @@ switchIsOn lookup_fn switch SwBool False -> False _ -> True -stringSwitchSet :: (switch -> SwitchResult) - -> (String -> switch) - -> Maybe String - -stringSwitchSet lookup_fn switch - = case (lookup_fn (switch (panic "stringSwitchSet"))) of - SwString str -> Just str - _ -> Nothing - intSwitchSet :: (switch -> SwitchResult) -> (Int -> switch) -> Maybe Int @@ -967,3 +749,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}