X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FDynFlags.hs;h=9e2d24b07d9bb91d51f5c2b9d819d61169919e1a;hp=14842b1551124fd3f6f0662de5b15a32c0f39a83;hb=84dc1adf521191e1c171e684c7cd28f03475125e;hpb=54280054ee1848698d4462ff8f85f3b46bf0a26d diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 14842b1..9e2d24b 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -1,14 +1,12 @@ ------------------------------------------------------------------------------ --- +-- | -- Dynamic flags -- -- -- (c) The University of Glasgow 2005 -- ------------------------------------------------------------------------------ --- | Most flags are dynamic flags, which means they can change from +-- Most flags are dynamic flags, which means they can change from -- compilation to compilation using @OPTIONS_GHC@ pragmas, and in a -- multi-session GHC each session can be using different dynamic -- flags. Dynamic flags can also be set at the prompt in GHCi. @@ -23,7 +21,7 @@ module DynFlags ( Option(..), DynLibLoader(..), fFlags, xFlags, - DPHBackend(..), + dphPackage, -- ** Manipulating DynFlags defaultDynFlags, -- DynFlags @@ -83,7 +81,7 @@ import Panic import UniqFM ( UniqFM ) import Util import Maybes ( orElse ) -import SrcLoc ( SrcSpan ) +import SrcLoc import FastString import Outputable import {-# SOURCE #-} ErrUtils ( Severity(..), Message, mkLocMessage ) @@ -202,7 +200,7 @@ data DynFlag | Opt_TemplateHaskell | Opt_QuasiQuotes | Opt_ImplicitParams - | Opt_Generics + | Opt_Generics -- "Derivable type classes" | Opt_ImplicitPrelude | Opt_ScopedTypeVariables | Opt_UnboxedTuples @@ -310,7 +308,7 @@ data DynFlags = DynFlags { stgToDo :: Maybe [StgToDo], -- similarly hscTarget :: HscTarget, hscOutName :: String, -- ^ Name of the output file - extCoreName :: String, -- ^ Name of the .core output file + extCoreName :: String, -- ^ Name of the .hcr output file verbosity :: Int, -- ^ Verbosity level: see "DynFlags#verbosity_levels" optLevel :: Int, -- ^ Optimisation level simplPhases :: Int, -- ^ Number of simplifier phases @@ -331,7 +329,7 @@ data DynFlags = DynFlags { dphBackend :: DPHBackend, - thisPackage :: PackageId, + thisPackage :: PackageId, -- ^ name of package currently being compiled -- ways wayNames :: [WayName], -- ^ Way flags from the command line @@ -578,7 +576,7 @@ defaultDynFlags = ghcUsagePath = panic "defaultDynFlags: No ghciUsagePath", ghciUsagePath = panic "defaultDynFlags: No ghciUsagePath", topDir = panic "defaultDynFlags: No topDir", - systemPackageConfig = panic "defaultDynFlags: No systemPackageConfig", + systemPackageConfig = panic "no systemPackageConfig: call GHC.setSessionDynFlags", pgm_L = panic "defaultDynFlags: No pgm_L", pgm_P = panic "defaultDynFlags: No pgm_P", pgm_F = panic "defaultDynFlags: No pgm_F", @@ -803,7 +801,16 @@ optLevelFlags , ([2], Opt_LiberateCase) , ([2], Opt_SpecConstr) - , ([2], Opt_StaticArgumentTransformation) + +-- , ([2], Opt_StaticArgumentTransformation) +-- Max writes: I think it's probably best not to enable SAT with -O2 for the +-- 6.10 release. The version of SAT in HEAD at the moment doesn't incorporate +-- several improvements to the heuristics, and I'm concerned that without +-- those changes SAT will interfere with some attempts to write "high +-- performance Haskell", as we saw in some posts on Haskell-Cafe earlier +-- this year. In particular, the version in HEAD lacks the tail call +-- criterion, so many things that look like reasonable loops will be +-- turned into functions with extra (unneccesary) thunk creation. , ([0,1,2], Opt_DoLambdaEtaExpansion) -- This one is important for a tiresome reason: @@ -885,7 +892,7 @@ data CoreToDo -- These are diff core-to-core passes, | CoreCSE | CoreDoRuleCheck Int{-CompilerPhase-} String -- Check for non-application of rules -- matching this string - | CoreDoVectorisation DPHBackend + | CoreDoVectorisation PackageId | CoreDoNothing -- Useful when building up | CoreDoPasses [CoreToDo] -- lists of these things @@ -940,7 +947,7 @@ getCoreToDo dflags vectorisation = runWhen (dopt Opt_Vectorise dflags) - $ CoreDoPasses [ simpl_gently, CoreDoVectorisation (dphBackend dflags) ] + $ CoreDoPasses [ simpl_gently, CoreDoVectorisation (dphPackage dflags) ] -- By default, we have 2 phases before phase 0. @@ -1428,10 +1435,13 @@ dynamic_flags = [ ------ DPH flags ---------------------------------------------------- , Flag "fdph-seq" - (NoArg (upd (setDPHBackend DPHSeq))) + (NoArg (setDPHBackend DPHSeq)) Supported , Flag "fdph-par" - (NoArg (upd (setDPHBackend DPHPar))) + (NoArg (setDPHBackend DPHPar)) + Supported + , Flag "fdph-this" + (NoArg (setDPHBackend DPHThis)) Supported ------ Compiler flags ----------------------------------------------- @@ -1645,12 +1655,13 @@ xFlags = [ ( "PackageImports", Opt_PackageImports, const Supported ) ] -impliedFlags :: [(DynFlag, [DynFlag])] -impliedFlags = [ - ( Opt_GADTs, [Opt_RelaxedPolyRec] ) -- We want type-sig variables to - -- be completely rigid for GADTs - , ( Opt_ScopedTypeVariables, [Opt_RelaxedPolyRec] ) -- Ditto for scoped type variables; see - -- Note [Scoped tyvars] in TcBinds +impliedFlags :: [(DynFlag, DynFlag)] +impliedFlags + = [ (Opt_GADTs, Opt_RelaxedPolyRec) -- We want type-sig variables to + -- be completely rigid for GADTs + + , (Opt_ScopedTypeVariables, Opt_RelaxedPolyRec) -- Ditto for scoped type variables; see + -- Note [Scoped tyvars] in TcBinds ] glasgowExtsFlags :: [DynFlag] @@ -1690,7 +1701,15 @@ glasgowExtsFlags = [ -- ----------------------------------------------------------------------------- -- Parsing the dynamic flags. -parseDynamicFlags :: DynFlags -> [String] -> IO (DynFlags, [String], [String]) +-- | Parse dynamic flags from a list of command line argument. Returns the +-- the parsed 'DynFlags', the left-over arguments, and a list of warnings. +-- Throws a 'UsageError' if errors occurred during parsing (such as unknown +-- flags or missing arguments). +parseDynamicFlags :: Monad m => + DynFlags -> [Located String] + -> m (DynFlags, [Located String], [Located String]) + -- ^ Updated 'DynFlags', left-over arguments, and + -- list of warnings. parseDynamicFlags dflags args = do -- XXX Legacy support code -- We used to accept things like @@ -1699,14 +1718,13 @@ parseDynamicFlags dflags args = do -- optdep -f -optdepdepend -- optdep -f -optdep depend -- but the spaces trip up proper argument handling. So get rid of them. - let f ("-optdep" : x : xs) = ("-optdep" ++ x) : f xs + let f (L p "-optdep" : L _ x : xs) = (L p ("-optdep" ++ x)) : f xs f (x : xs) = x : f xs f xs = xs args' = f args let ((leftover, errs, warns), dflags') = runCmdLine (processArgs dynamic_flags args') dflags - when (not (null errs)) $ do - ghcError (UsageError (unlines errs)) + when (not (null errs)) $ ghcError $ errorsToGhcException errs return (dflags', leftover, warns) type DynP = CmdLineP DynFlags @@ -1718,10 +1736,13 @@ upd f = do -------------------------- setDynFlag, unSetDynFlag :: DynFlag -> DynP () -setDynFlag f = upd (\dfs -> foldl dopt_set (dopt_set dfs f) deps) +setDynFlag f = do { upd (\dfs -> dopt_set dfs f) + ; mapM_ setDynFlag deps } where - deps = [ d | (f', ds) <- impliedFlags, f' == f, d <- ds ] + deps = [ d | (f', d) <- impliedFlags, f' == f ] -- When you set f, set the ones it implies + -- NB: use setDynFlag recursively, in case the implied flags + -- implies further flags -- When you un-set f, however, we don't un-set the things it implies -- (except for -fno-glasgow-exts, which is treated specially) @@ -1842,20 +1863,36 @@ setOptLevel n dflags -- -fdicts-cheap always inline dictionaries -- -fmax-simplifier-iterations20 this is necessary sometimes -- -fno-spec-constr-threshold run SpecConstr even for big loops +-- -fno-spec-constr-count SpecConstr as much as possible -- setDPHOpt :: DynFlags -> DynFlags setDPHOpt dflags = setOptLevel 2 (dflags { maxSimplIterations = 20 , specConstrThreshold = Nothing + , specConstrCount = Nothing }) `dopt_set` Opt_DictsCheap `dopt_unset` Opt_MethodSharing data DPHBackend = DPHPar | DPHSeq - -setDPHBackend :: DPHBackend -> DynFlags -> DynFlags -setDPHBackend backend dflags = dflags { dphBackend = backend } - + | DPHThis + deriving(Eq, Ord, Enum, Show) + +setDPHBackend :: DPHBackend -> DynP () +setDPHBackend backend + = do + upd $ \dflags -> dflags { dphBackend = backend } + mapM_ exposePackage (dph_packages backend) + where + dph_packages DPHThis = [] + dph_packages DPHPar = ["dph-prim-par", "dph-par"] + dph_packages DPHSeq = ["dph-prim-seq", "dph-seq"] + +dphPackage :: DynFlags -> PackageId +dphPackage dflags = case dphBackend dflags of + DPHPar -> dphParPackageId + DPHSeq -> dphSeqPackageId + DPHThis -> thisPackage dflags setMainIs :: String -> DynP () setMainIs arg