\begin{code}
module CmdLineOpts (
- CoreToDo(..),
- SimplifierSwitch(..), isAmongSimpl,
- StgToDo(..),
- SwitchResult(..),
+ CoreToDo(..), buildCoreToDo, StgToDo(..),
+ SimplifierSwitch(..),
+ SimplifierMode(..), FloatOutSwitches(..),
- HscLang(..),
+ HscTarget(..),
DynFlag(..), -- needed non-abstractly by DriverFlags
DynFlags(..),
+ PackageFlag(..),
v_Static_hsc_opts,
- intSwitchSet,
- switchIsOn,
isStaticHscFlag,
-- Manipulating DynFlags
dopt_set, dopt_unset, -- DynFlags -> DynFlag -> DynFlags
dopt_CoreToDo, -- DynFlags -> [CoreToDo]
dopt_StgToDo, -- DynFlags -> [StgToDo]
- dopt_HscLang, -- DynFlags -> HscLang
+ dopt_HscTarget, -- DynFlags -> HscTarget
dopt_OutName, -- DynFlags -> String
-
- -- Manipulating the DynFlags state
- getDynFlags, -- IO DynFlags
- setDynFlags, -- DynFlags -> IO ()
- updDynFlags, -- (DynFlags -> DynFlags) -> IO ()
- dynFlag, -- (DynFlags -> a) -> IO a
- setDynFlag, unSetDynFlag, -- DynFlag -> IO ()
- saveDynFlags, -- IO ()
- restoreDynFlags, -- IO DynFlags
+ getOpts, -- (DynFlags -> [a]) -> IO [a]
+ getVerbFlag,
+ updOptLevel,
-- sets of warning opts
- standardWarnings,
minusWOpts,
minusWallOpts,
-- Output style options
- opt_PprStyle_NoPrags,
- opt_PprStyle_RawTypes,
opt_PprUserLength,
opt_PprStyle_Debug,
opt_AutoSccsOnAllToplevs,
opt_AutoSccsOnExportedToplevs,
opt_AutoSccsOnIndividualCafs,
- opt_AutoSccsOnDicts,
opt_SccProfilingOn,
opt_DoTickyProfiling,
-- language opts
- opt_AllStrict,
opt_DictsStrict,
opt_MaxContextReductionDepth,
opt_IrrefutableTuples,
- opt_NumbersStrict,
opt_Parallel,
opt_SMP,
- opt_NoMonomorphismRestriction,
opt_RuntimeTypes,
+ opt_Flatten,
-- optimisation opts
- opt_NoMethodSharing,
- opt_DoSemiTagging,
- opt_FoldrBuildOn,
+ opt_NoMethodSharing,
+ opt_NoStateHack,
opt_LiberateCaseThreshold,
- opt_StgDoLetNoEscapes,
- opt_UnfoldCasms,
- opt_UsageSPOn,
- opt_UnboxStrictFields,
+ opt_CprOff,
+ opt_RulesOff,
opt_SimplNoPreInlining,
- opt_SimplDoEtaReduction,
- opt_SimplDoLambdaEtaExpansion,
- opt_SimplCaseMerge,
opt_SimplExcessPrecision,
opt_MaxWorkerArgs,
opt_UF_FunAppDiscount,
opt_UF_KeenessFactor,
opt_UF_UpdateInPlace,
- opt_UF_CheapOp,
opt_UF_DearOp,
-- misc opts
- opt_InPackage,
+ opt_ErrorSpans,
opt_EmitCExternDecls,
opt_EnsureSplittableC,
opt_GranMacros,
opt_HiVersion,
opt_HistorySize,
- opt_IgnoreAsserts,
- opt_IgnoreIfacePragmas,
- opt_NoHiCheck,
opt_OmitBlackHoling,
- opt_OmitInterfacePragmas,
- opt_NoPruneTyDecls,
- opt_NoPruneDecls,
opt_Static,
opt_Unregisterised,
- opt_EmitExternalCore
+ opt_EmitExternalCore,
+ opt_PIC
) where
#include "HsVersions.h"
-import Array ( array, (//) )
-import GlaExts
-import IOExts ( IORef, readIORef, writeIORef )
+import {-# SOURCE #-} Packages (PackageState)
+import DriverPhases ( HscTarget(..) )
import Constants -- Default values for some flags
import Util
-import FastTypes
+import FastString ( FastString, mkFastString )
import Config
-
import Maybes ( firstJust )
-import Panic ( panic )
-#if __GLASGOW_HASKELL__ < 301
-import ArrBase ( Array(..) )
-#else
-import PrelArr ( Array(..) )
-#endif
+import Panic ( ghcError, GhcException(UsageError) )
+import GLAEXTS
+import DATA_IOREF ( IORef, readIORef )
+import UNSAFE_IO ( unsafePerformIO )
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-data SwitchResult
- = SwBool Bool -- on/off
- | SwString FAST_STRING -- nothing or a String
- | SwInt Int -- nothing or an Int
-\end{code}
-
-\begin{code}
data CoreToDo -- These are diff core-to-core passes,
-- which may be invoked in any order,
-- as many times as you like.
= CoreDoSimplify -- The core-to-core simplifier.
- (SimplifierSwitch -> SwitchResult)
+ SimplifierMode
+ [SimplifierSwitch]
-- Each run of the simplifier can take a different
-- set of simplifier-specific flags.
| CoreDoFloatInwards
- | CoreDoFloatOutwards Bool -- True <=> float lambdas to top level
+ | CoreDoFloatOutwards FloatOutSwitches
| CoreLiberateCase
| CoreDoPrintCore
| CoreDoStaticArgs
| CoreDoWorkerWrapper
| CoreDoSpecialising
| CoreDoSpecConstr
- | CoreDoUSPInf
- | CoreDoCPResult
+ | CoreDoOldStrictness
| CoreDoGlomBinds
| CoreCSE
+ | CoreDoRuleCheck Int{-CompilerPhase-} String -- Check for non-application of rules
+ -- matching this string
| CoreDoNothing -- useful when building up lists of these things
\end{code}
\end{code}
\begin{code}
+data SimplifierMode -- See comments in SimplMonad
+ = SimplGently
+ | SimplPhase Int
+
data SimplifierSwitch
= MaxSimplifierIterations Int
- | SimplInlinePhase Int
- | DontApplyRules
| NoCaseOfCase
- | SimplLetToCase
+
+data FloatOutSwitches
+ = FloatOutSw Bool -- True <=> float lambdas to top level
+ Bool -- True <=> float constants to top level,
+ -- even if they do not escape a lambda
\end{code}
%************************************************************************
data DynFlag
-- debugging flags
- = Opt_D_dump_absC
+ = Opt_D_dump_cmm
| Opt_D_dump_asm
| Opt_D_dump_cpranal
| Opt_D_dump_deriv
| 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_sat
+ | Opt_D_dump_prep
| 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_dump_rn_trace
| Opt_D_dump_rn_stats
- | Opt_D_dump_stix
+ | Opt_D_dump_opt_cmm
| Opt_D_dump_simpl_stats
| Opt_D_dump_tc_trace
+ | Opt_D_dump_if_trace
+ | Opt_D_dump_splices
| Opt_D_dump_BCOs
+ | Opt_D_dump_vect
| Opt_D_source_stats
| Opt_D_verbose_core2core
| Opt_D_verbose_stg2stg
| Opt_D_dump_minimal_imports
| Opt_DoCoreLinting
| Opt_DoStgLinting
- | Opt_DoUSPLinting
+ | Opt_DoCmmLinting
+ | Opt_WarnIsError -- -Werror; makes warnings fatal
| Opt_WarnDuplicateExports
| Opt_WarnHiShadows
| Opt_WarnIncompletePatterns
+ | Opt_WarnIncompletePatternsRecUpd
| Opt_WarnMissingFields
| Opt_WarnMissingMethods
| Opt_WarnMissingSigs
| Opt_WarnUnusedImports
| Opt_WarnUnusedMatches
| Opt_WarnDeprecations
- | Opt_WarnMisc
+ | Opt_WarnDodgyImports
+ | Opt_WarnOrphans
-- language opts
| Opt_AllowOverlappingInstances
| Opt_AllowUndecidableInstances
+ | Opt_AllowIncoherentInstances
+ | Opt_MonomorphismRestriction
| Opt_GlasgowExts
+ | Opt_FFI
+ | Opt_PArr -- syntactic support for parallel arrays
+ | Opt_Arrows -- Arrow-notation syntax
+ | Opt_TH
+ | Opt_ImplicitParams
| Opt_Generics
- | Opt_NoImplicitPrelude
+ | Opt_ImplicitPrelude
+ | Opt_ScopedTypeVariables
+
+ -- optimisation opts
+ | Opt_Strictness
+ | Opt_FullLaziness
+ | Opt_CSE
+ | Opt_IgnoreInterfacePragmas
+ | Opt_OmitInterfacePragmas
+ | Opt_DoLambdaEtaExpansion
+ | Opt_IgnoreAsserts
+ | Opt_DoEtaReduction
+ | Opt_CaseMerge
+ | Opt_UnboxStrictFields
deriving (Eq)
data DynFlags = DynFlags {
- coreToDo :: [CoreToDo],
+ coreToDo :: Maybe [CoreToDo], -- reserved for use with -Ofile
stgToDo :: [StgToDo],
- hscLang :: HscLang,
+ hscTarget :: HscTarget,
hscOutName :: String, -- name of the output file
hscStubHOutName :: String, -- name of the .stub_h output file
hscStubCOutName :: String, -- name of the .stub_c output file
extCoreName :: String, -- name of the .core output file
verbosity :: Int, -- verbosity level
+ optLevel :: Int, -- optimisation level
+ maxSimplIterations :: Int, -- max simplifier iterations
+ ruleCheck :: Maybe String,
cppFlag :: Bool, -- preprocess with cpp?
+ ppFlag :: Bool, -- preprocess with a Haskell Pp?
+ recompFlag :: Bool, -- True <=> recompilation checker is on
stolen_x86_regs :: Int,
cmdlineHcIncludes :: [String], -- -#includes
+ importPaths :: [FilePath],
-- options for particular phases
opt_L :: [String],
opt_P :: [String],
+ opt_F :: [String],
opt_c :: [String],
opt_a :: [String],
opt_m :: [String],
opt_i :: [String],
#endif
+ -- ** Package flags
+ extraPkgConfs :: [FilePath],
+ -- The -package-conf flags given on the command line, in the order
+ -- they appeared.
+
+ readUserPkgConf :: Bool,
+ -- Whether or not to read the user package database
+ -- (-no-user-package-conf).
+
+ packageFlags :: [PackageFlag],
+ -- The -package and -hide-package flags from the command-line
+
+ -- ** Package state
+ pkgState :: PackageState,
+
-- hsc dynamic flags
flags :: [DynFlag]
}
-data HscLang
- = HscC
- | HscAsm
- | HscJava
- | HscILX
- | HscInterpreted
- deriving (Eq, Show)
+data PackageFlag
+ = ExposePackage String
+ | HidePackage String
+ | IgnorePackage String
+
+defaultHscTarget
+#if defined(i386_TARGET_ARCH) || defined(sparc_TARGET_ARCH) || defined(powerpc_TARGET_ARCH)
+ | cGhcWithNativeCodeGen == "YES" = HscAsm
+#endif
+ | otherwise = HscC
defaultDynFlags = DynFlags {
- coreToDo = [], stgToDo = [],
- hscLang = HscC,
+ coreToDo = Nothing, stgToDo = [],
+ hscTarget = defaultHscTarget,
hscOutName = "",
hscStubHOutName = "", hscStubCOutName = "",
extCoreName = "",
- verbosity = 0,
+ verbosity = 0,
+ optLevel = 0,
+ maxSimplIterations = 4,
+ ruleCheck = Nothing,
cppFlag = False,
+ ppFlag = False,
+ recompFlag = True,
stolen_x86_regs = 4,
cmdlineHcIncludes = [],
+ importPaths = ["."],
opt_L = [],
opt_P = [],
+ opt_F = [],
opt_c = [],
opt_a = [],
opt_m = [],
opt_I = [],
opt_i = [],
#endif
- flags = standardWarnings,
+
+ extraPkgConfs = [],
+ readUserPkgConf = True,
+ packageFlags = [],
+ pkgState = error "pkgState",
+
+ flags = [
+ Opt_ImplicitPrelude,
+ Opt_MonomorphismRestriction,
+ Opt_Strictness,
+ -- strictness is on by default, but this only
+ -- applies to -O.
+ Opt_CSE, -- similarly for CSE.
+ Opt_FullLaziness, -- ...and for full laziness
+
+ Opt_DoLambdaEtaExpansion,
+ -- This one is important for a tiresome reason:
+ -- we want to make sure that the bindings for data
+ -- constructors are eta-expanded. This is probably
+ -- a good thing anyway, but it seems fragile.
+
+ -- and the default no-optimisation options:
+ Opt_IgnoreInterfacePragmas,
+ Opt_OmitInterfacePragmas
+
+ ] ++ standardWarnings
}
{-
dopt :: DynFlag -> DynFlags -> Bool
dopt f dflags = f `elem` (flags dflags)
-dopt_CoreToDo :: DynFlags -> [CoreToDo]
+dopt_CoreToDo :: DynFlags -> Maybe [CoreToDo]
dopt_CoreToDo = coreToDo
dopt_StgToDo :: DynFlags -> [StgToDo]
dopt_OutName :: DynFlags -> String
dopt_OutName = hscOutName
-dopt_HscLang :: DynFlags -> HscLang
-dopt_HscLang = hscLang
+dopt_HscTarget :: DynFlags -> HscTarget
+dopt_HscTarget = hscTarget
dopt_set :: DynFlags -> DynFlag -> DynFlags
dopt_set dfs f = dfs{ flags = f : flags dfs }
dopt_unset :: DynFlags -> DynFlag -> DynFlags
dopt_unset dfs f = dfs{ flags = filter (/= f) (flags dfs) }
-\end{code}
------------------------------------------------------------------------------
--- Mess about with the mutable variables holding the dynamic arguments
-
--- v_InitDynFlags
--- is the "baseline" dynamic flags, initialised from
--- the defaults and command line options, and updated by the
--- ':s' command in GHCi.
---
--- v_DynFlags
--- is the dynamic flags for the current compilation. It is reset
--- to the value of v_InitDynFlags before each compilation, then
--- updated by reading any OPTIONS pragma in the current module.
+getOpts :: DynFlags -> (DynFlags -> [a]) -> [a]
+ -- We add to the options from the front, so we need to reverse the list
+getOpts dflags opts = reverse (opts dflags)
-\begin{code}
-GLOBAL_VAR(v_InitDynFlags, defaultDynFlags, DynFlags)
-GLOBAL_VAR(v_DynFlags, defaultDynFlags, DynFlags)
+getVerbFlag dflags
+ | verbosity dflags >= 3 = "-v"
+ | otherwise = ""
-setDynFlags :: DynFlags -> IO ()
-setDynFlags dfs = writeIORef v_DynFlags dfs
-
-saveDynFlags :: IO ()
-saveDynFlags = do dfs <- readIORef v_DynFlags
- writeIORef v_InitDynFlags dfs
+-----------------------------------------------------------------------------
+-- Setting the optimisation level
+
+updOptLevel :: Int -> DynFlags -> DynFlags
+-- Set dynflags appropriate to the optimisation level
+updOptLevel n dfs
+ = if (n >= 1)
+ then dfs2{ hscTarget = HscC, optLevel = n } -- turn on -fvia-C with -O
+ else dfs2{ optLevel = n }
+ where
+ dfs1 = foldr (flip dopt_unset) dfs remove_dopts
+ dfs2 = foldr (flip dopt_set) dfs1 extra_dopts
-restoreDynFlags :: IO DynFlags
-restoreDynFlags = do dfs <- readIORef v_InitDynFlags
- writeIORef v_DynFlags dfs
- return dfs
+ extra_dopts
+ | n == 0 = opt_0_dopts
+ | otherwise = opt_1_dopts
-getDynFlags :: IO DynFlags
-getDynFlags = readIORef v_DynFlags
+ remove_dopts
+ | n == 0 = opt_1_dopts
+ | otherwise = opt_0_dopts
+
+opt_0_dopts = [
+ Opt_IgnoreInterfacePragmas,
+ Opt_OmitInterfacePragmas
+ ]
+
+opt_1_dopts = [
+ Opt_IgnoreAsserts,
+ Opt_DoEtaReduction,
+ Opt_CaseMerge
+ ]
-updDynFlags :: (DynFlags -> DynFlags) -> IO ()
-updDynFlags f = do dfs <- readIORef v_DynFlags
- writeIORef v_DynFlags (f dfs)
+-- Core-to-core phases:
-dynFlag :: (DynFlags -> a) -> IO a
-dynFlag f = do dflags <- readIORef v_DynFlags; return (f dflags)
+buildCoreToDo :: DynFlags -> [CoreToDo]
+buildCoreToDo dflags = core_todo
+ where
+ opt_level = optLevel dflags
+ max_iter = maxSimplIterations dflags
+ strictness = dopt Opt_Strictness dflags
+ full_laziness = dopt Opt_FullLaziness dflags
+ cse = dopt Opt_CSE dflags
+ rule_check = ruleCheck dflags
+
+ core_todo =
+ if opt_level == 0 then
+ [
+ CoreDoSimplify (SimplPhase 0) [
+ MaxSimplifierIterations max_iter
+ ]
+ ]
-setDynFlag, unSetDynFlag :: DynFlag -> IO ()
-setDynFlag f = updDynFlags (\dfs -> dopt_set dfs f)
-unSetDynFlag f = updDynFlags (\dfs -> dopt_unset dfs f)
+ else {- opt_level >= 1 -} [
+
+ -- initial simplify: mk specialiser happy: minimum effort please
+ CoreDoSimplify SimplGently [
+ -- Simplify "gently"
+ -- Don't inline anything till full laziness has bitten
+ -- In particular, inlining wrappers inhibits floating
+ -- e.g. ...(case f x of ...)...
+ -- ==> ...(case (case x of I# x# -> fw x#) of ...)...
+ -- ==> ...(case x of I# x# -> case fw x# of ...)...
+ -- and now the redex (f x) isn't floatable any more
+ -- Similarly, don't apply any rules until after full
+ -- laziness. Notably, list fusion can prevent floating.
+
+ NoCaseOfCase,
+ -- Don't do case-of-case transformations.
+ -- This makes full laziness work better
+ MaxSimplifierIterations max_iter
+ ],
+
+ -- Specialisation is best done before full laziness
+ -- so that overloaded functions have all their dictionary lambdas manifest
+ CoreDoSpecialising,
+
+ if full_laziness then CoreDoFloatOutwards (FloatOutSw False False)
+ else CoreDoNothing,
+
+ CoreDoFloatInwards,
+
+ CoreDoSimplify (SimplPhase 2) [
+ -- Want to run with inline phase 2 after the specialiser to give
+ -- maximum chance for fusion to work before we inline build/augment
+ -- in phase 1. This made a difference in 'ansi' where an
+ -- overloaded function wasn't inlined till too late.
+ MaxSimplifierIterations max_iter
+ ],
+ case rule_check of { Just pat -> CoreDoRuleCheck 2 pat; Nothing -> CoreDoNothing },
+
+ CoreDoSimplify (SimplPhase 1) [
+ -- Need inline-phase2 here so that build/augment get
+ -- inlined. I found that spectral/hartel/genfft lost some useful
+ -- strictness in the function sumcode' if augment is not inlined
+ -- before strictness analysis runs
+ MaxSimplifierIterations max_iter
+ ],
+ case rule_check of { Just pat -> CoreDoRuleCheck 1 pat; Nothing -> CoreDoNothing },
+
+ CoreDoSimplify (SimplPhase 0) [
+ -- Phase 0: allow all Ids to be inlined now
+ -- This gets foldr inlined before strictness analysis
+
+ MaxSimplifierIterations 3
+ -- At least 3 iterations because otherwise we land up with
+ -- huge dead expressions because of an infelicity in the
+ -- simpifier.
+ -- let k = BIG in foldr k z xs
+ -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs
+ -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs
+ -- Don't stop now!
+
+ ],
+ case rule_check of { Just pat -> CoreDoRuleCheck 0 pat; Nothing -> CoreDoNothing },
+
+#ifdef OLD_STRICTNESS
+ CoreDoOldStrictness
+#endif
+ if strictness then CoreDoStrictness else CoreDoNothing,
+ CoreDoWorkerWrapper,
+ CoreDoGlomBinds,
+
+ CoreDoSimplify (SimplPhase 0) [
+ MaxSimplifierIterations max_iter
+ ],
+
+ if full_laziness then
+ CoreDoFloatOutwards (FloatOutSw False -- Not lambdas
+ True) -- Float constants
+ else CoreDoNothing,
+ -- nofib/spectral/hartel/wang doubles in speed if you
+ -- do full laziness late in the day. It only happens
+ -- after fusion and other stuff, so the early pass doesn't
+ -- catch it. For the record, the redex is
+ -- f_el22 (f_el21 r_midblock)
+
+
+ -- We want CSE to follow the final full-laziness pass, because it may
+ -- succeed in commoning up things floated out by full laziness.
+ -- CSE used to rely on the no-shadowing invariant, but it doesn't any more
+
+ if cse then CoreCSE else CoreDoNothing,
+
+ CoreDoFloatInwards,
+
+-- Case-liberation for -O2. This should be after
+-- strictness analysis and the simplification which follows it.
+
+ case rule_check of { Just pat -> CoreDoRuleCheck 0 pat; Nothing -> CoreDoNothing },
+
+ if opt_level >= 2 then
+ CoreLiberateCase
+ else
+ CoreDoNothing,
+ if opt_level >= 2 then
+ CoreDoSpecConstr
+ else
+ CoreDoNothing,
+
+ -- Final clean-up simplification:
+ CoreDoSimplify (SimplPhase 0) [
+ MaxSimplifierIterations max_iter
+ ]
+ ]
\end{code}
-
%************************************************************************
%* *
\subsection{Warnings}
Opt_WarnUnusedMatches,
Opt_WarnUnusedImports,
Opt_WarnIncompletePatterns,
- Opt_WarnMisc
+ Opt_WarnDodgyImports
]
minusWallOpts
[ Opt_WarnTypeDefaults,
Opt_WarnNameShadowing,
Opt_WarnMissingSigs,
- Opt_WarnHiShadows
+ Opt_WarnHiShadows,
+ Opt_WarnOrphans
]
\end{code}
-- main/DriverState.
GLOBAL_VAR(v_Static_hsc_opts, [], [String])
-lookUp :: FAST_STRING -> Bool
-lookup_int :: String -> Maybe Int
+lookUp :: FastString -> Bool
lookup_def_int :: String -> Int -> Int
lookup_def_float :: String -> Float -> Float
lookup_str :: String -> Maybe String
unpacked_static_opts = unsafePerformIO (readIORef v_Static_hsc_opts)
-packed_static_opts = map _PK_ unpacked_static_opts
+packed_static_opts = map mkFastString unpacked_static_opts
lookUp sw = sw `elem` packed_static_opts
-lookup_str sw = firstJust (map (startsWith sw) unpacked_static_opts)
-
-lookup_int sw = case (lookup_str sw) of
- Nothing -> Nothing
- Just xx -> Just (read xx)
+-- (lookup_str "foo") looks for the flag -foo=X or -fooX,
+-- and returns the string X
+lookup_str sw
+ = case firstJust (map (startsWith sw) unpacked_static_opts) of
+ Just ('=' : str) -> Just str
+ Just str -> Just str
+ Nothing -> Nothing
lookup_def_int sw def = case (lookup_str sw) of
Nothing -> def -- Use default
- Just xx -> read xx
+ Just xx -> try_read sw xx
lookup_def_float sw def = case (lookup_str sw) of
Nothing -> def -- Use default
- Just xx -> read xx
+ Just xx -> try_read sw xx
+
+
+try_read :: Read a => String -> String -> a
+-- (try_read sw str) tries to read s; if it fails, it
+-- bleats about flag sw
+try_read sw str
+ = case reads str of
+ ((x,_):_) -> x -- Be forgiving: ignore trailing goop, and alternative parses
+ [] -> ghcError (UsageError ("Malformed argument " ++ str ++ " for flag " ++ sw))
+ -- ToDo: hack alert. We should really parse the arugments
+ -- and announce errors in a more civilised way.
{-
unpacked_opts =
concat $
map (expandAts) $
- map _UNPK_ argv -- NOT ARGV any more: v_Static_hsc_opts
+ map unpackFS argv -- NOT ARGV any more: v_Static_hsc_opts
where
expandAts ('@':fname) = words (unsafePerformIO (readFile fname))
expandAts l = [l]
\begin{code}
-- debugging opts
-opt_PprStyle_NoPrags = lookUp SLIT("-dppr-noprags")
-opt_PprStyle_Debug = lookUp SLIT("-dppr-debug")
-opt_PprStyle_RawTypes = lookUp SLIT("-dppr-rawtypes")
+opt_PprStyle_Debug = lookUp FSLIT("-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_AutoSccsOnDicts = lookUp SLIT("-fauto-sccs-on-dicts")
-opt_SccProfilingOn = lookUp SLIT("-fscc-profiling")
-opt_DoTickyProfiling = lookUp SLIT("-fticky-ticky")
+opt_AutoSccsOnAllToplevs = lookUp FSLIT("-fauto-sccs-on-all-toplevs")
+opt_AutoSccsOnExportedToplevs = lookUp FSLIT("-fauto-sccs-on-exported-toplevs")
+opt_AutoSccsOnIndividualCafs = lookUp FSLIT("-fauto-sccs-on-individual-cafs")
+opt_SccProfilingOn = lookUp FSLIT("-fscc-profiling")
+opt_DoTickyProfiling = lookUp FSLIT("-fticky-ticky")
-- language opts
-opt_AllStrict = lookUp SLIT("-fall-strict")
-opt_NoMonomorphismRestriction = lookUp SLIT("-fno-monomorphism-restriction")
-opt_DictsStrict = lookUp SLIT("-fdicts-strict")
-opt_IrrefutableTuples = lookUp SLIT("-firrefutable-tuples")
+opt_DictsStrict = lookUp FSLIT("-fdicts-strict")
+opt_IrrefutableTuples = lookUp FSLIT("-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")
+opt_Parallel = lookUp FSLIT("-fparallel")
+opt_SMP = lookUp FSLIT("-fsmp")
+opt_Flatten = lookUp FSLIT("-fflatten")
-- optimisation opts
-opt_NoMethodSharing = lookUp SLIT("-fno-method-sharing")
-opt_DoSemiTagging = lookUp SLIT("-fsemi-tagging")
-opt_FoldrBuildOn = lookUp SLIT("-ffoldr-build-on")
+opt_NoStateHack = lookUp FSLIT("-fno-state-hack")
+opt_NoMethodSharing = lookUp FSLIT("-fno-method-sharing")
+opt_CprOff = lookUp FSLIT("-fcpr-off")
+opt_RulesOff = lookUp FSLIT("-frules-off")
+ -- Switch off CPR analysis in the new demand analyser
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")
opt_MaxWorkerArgs = lookup_def_int "-fmax-worker-args" (10::Int)
-{-
- The optional '-inpackage=P' flag tells what package
- we are compiling this module for.
- The Prelude, for example is compiled with '-inpackage std'
--}
-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 = read cProjectVersionInt :: Int
+opt_EmitCExternDecls = lookUp FSLIT("-femit-extern-decls")
+opt_EnsureSplittableC = lookUp FSLIT("-fglobalise-toplev-names")
+opt_GranMacros = lookUp FSLIT("-fgransim")
+opt_HiVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Int
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_OmitBlackHoling = lookUp SLIT("-dno-black-holing")
-opt_OmitInterfacePragmas = lookUp SLIT("-fomit-interface-pragmas")
-opt_RuntimeTypes = lookUp SLIT("-fruntime-types")
+opt_OmitBlackHoling = lookUp FSLIT("-dno-black-holing")
+opt_RuntimeTypes = lookUp FSLIT("-fruntime-types")
-- Simplifier switches
-opt_SimplNoPreInlining = lookUp SLIT("-fno-pre-inlining")
+opt_SimplNoPreInlining = lookUp FSLIT("-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_SimplCaseMerge = lookUp SLIT("-fcase-merge")
-opt_SimplExcessPrecision = lookUp SLIT("-fexcess-precision")
+opt_SimplExcessPrecision = lookUp FSLIT("-fexcess-precision")
-- Unfolding control
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_UpdateInPlace = lookUp FSLIT("-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_EmitExternalCore = lookUp SLIT("-fext-core")
+opt_Static = lookUp FSLIT("-static")
+opt_Unregisterised = lookUp FSLIT("-funregisterised")
+opt_EmitExternalCore = lookUp FSLIT("-fext-core")
+
+-- Include full span info in error messages, instead of just the start position.
+opt_ErrorSpans = lookUp FSLIT("-ferror-spans")
+
+opt_PIC = lookUp FSLIT("-fPIC")
\end{code}
%************************************************************************
"fall-strict",
"fdicts-strict",
"firrefutable-tuples",
- "fnumbers-strict",
"fparallel",
"fsmp",
+ "fflatten",
"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",
"dno-black-holing",
"fno-method-sharing",
- "fno-monomorphism-restriction",
- "fomit-interface-pragmas",
+ "fno-state-hack",
"fruntime-types",
"fno-pre-inlining",
- "fdo-eta-reduction",
- "fdo-lambda-eta-expansion",
- "fcase-merge",
"fexcess-precision",
"funfolding-update-in-place",
- "fno-prune-decls",
- "fno-prune-tydecls",
"static",
"funregisterised",
- "fext-core"
+ "fext-core",
+ "frule-check",
+ "frules-off",
+ "fcpr-off",
+ "ferror-spans",
+ "fPIC"
]
|| any (flip prefixMatch f) [
"fcontext-stack",
%************************************************************************
%* *
-\subsection{Switch ordering}
-%* *
-%************************************************************************
-
-These things behave just like enumeration types.
-
-\begin{code}
-instance Eq SimplifierSwitch where
- a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b
-
-instance Ord SimplifierSwitch where
- a < b = tagOf_SimplSwitch a <# tagOf_SimplSwitch b
- a <= b = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b
-
-
-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 = 5
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Switch lookup}
-%* *
-%************************************************************************
-
-\begin{code}
-isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
-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 ] ]
-
- defined_elems = map mk_assoc_elem tidied_on_switches
- in
- -- (avoid some unboxing, bounds checking, and other horrible things:)
-#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
-#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@(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_SimplSwitch sw) ==# (tagOf_SimplSwitch s)
- || sw `is_elem` ss
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{Misc functions for command-line options}
%* *
%************************************************************************
-\begin{code}
-switchIsOn :: (switch -> SwitchResult) -> switch -> Bool
-
-switchIsOn lookup_fn switch
- = case (lookup_fn switch) of
- SwBool False -> False
- _ -> True
-
-intSwitchSet :: (switch -> SwitchResult)
- -> (Int -> switch)
- -> Maybe Int
-
-intSwitchSet lookup_fn switch
- = case (lookup_fn (switch (panic "intSwitchSet"))) of
- SwInt int -> Just int
- _ -> Nothing
-\end{code}
\begin{code}
startsWith :: String -> String -> Maybe String
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}
projects / ghc-hetmet.git / blobdiff