From: simonmar Date: Tue, 23 Sep 2003 14:33:05 +0000 (+0000) Subject: [project @ 2003-09-23 14:32:57 by simonmar] X-Git-Tag: Approx_11550_changesets_converted~431 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=abbc5a0be1df84a33015470319062ed7a3aa3153;p=ghc-hetmet.git [project @ 2003-09-23 14:32:57 by simonmar] - Convert many of the optimisation options into dynamic options (that is, they can be mentioned in {-# OPTIONS #-} pragmas). - Add a new way to specify constructor-field unboxing on a selective basis. To tell the compiler to unbox a constructor field, do this: data T = T !!Int and GHC will store that field unboxed if possible. If it isn't possible (say, because the field has a sum type) then the annotation is ignored. The -funbox-strict-fields flag is now a dynamic flag, and has the same effect as replacing all the '!' annotations with '!!'. --- diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs index 1f74e7f..de65b85 100644 --- a/ghc/compiler/basicTypes/BasicTypes.lhs +++ b/ghc/compiler/basicTypes/BasicTypes.lhs @@ -402,6 +402,7 @@ e.g. data T = MkT !Int !(Bool,Bool) \begin{code} data StrictnessMark = MarkedUserStrict -- "!" in a source decl + | MarkedUserUnboxed -- "!!" in a source decl | MarkedStrict -- "!" in an interface decl: strict but not unboxed | MarkedUnboxed -- "!!" in an interface decl: unboxed | NotMarkedStrict -- No annotation at all diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs index 93aef42..c2e5176 100644 --- a/ghc/compiler/basicTypes/DataCon.lhs +++ b/ghc/compiler/basicTypes/DataCon.lhs @@ -41,7 +41,6 @@ import FieldLabel ( FieldLabel ) import BasicTypes ( Arity, StrictnessMark(..) ) import Outputable import Unique ( Unique, Uniquable(..) ) -import CmdLineOpts ( opt_UnboxStrictFields ) import Maybes ( orElse ) import ListSetOps ( assoc ) import Util ( zipEqual, zipWithEqual, notNull ) @@ -555,12 +554,13 @@ chooseBoxingStrategy :: TyCon -> Type -> StrictnessMark -> StrictnessMark -- Transforms any MarkedUserStricts into MarkUnboxed or MarkedStrict chooseBoxingStrategy tycon arg_ty strict = case strict of - MarkedUserStrict - | opt_UnboxStrictFields - && unbox arg_ty -> MarkedUnboxed + MarkedUserStrict -> MarkedStrict + MarkedUserUnboxed + | can_unbox -> MarkedUnboxed | otherwise -> MarkedStrict other -> strict where + can_unbox = unbox arg_ty -- beware: repType will go into a loop if we try this on a recursive -- type (for reasons unknown...), hence the check for recursion below. unbox ty = diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index 713d026..9a77075 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -22,7 +22,7 @@ import CoreSyn import DsMonad -- the monadery used in the desugarer import DsUtils -import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_RulesOff ) +import CmdLineOpts ( DynFlag(..), dopt, opt_RulesOff ) import CoreUtils ( exprType, mkIfThenElse ) import Id ( idType ) import Var ( Id ) @@ -51,17 +51,19 @@ dsListComp :: [TypecheckedStmt] -> DsM CoreExpr dsListComp quals elt_ty - | opt_RulesOff || opt_IgnoreIfacePragmas -- Either rules are switched off, or - -- we are ignoring what there are; - -- Either way foldr/build won't happen, so - -- use the more efficient Wadler-style desugaring - || isParallelComp quals -- Foldr-style desugaring can't handle - -- parallel list comprehensions - = deListComp quals (mkNilExpr elt_ty) - - | otherwise -- Foldr/build should be enabled, so desugar - -- into foldrs and builds - = newTyVarsDs [alphaTyVar] `thenDs` \ [n_tyvar] -> + = getDOptsDs `thenDs` \dflags -> + if opt_RulesOff || dopt Opt_IgnoreInterfacePragmas dflags + -- Either rules are switched off, or we are ignoring what there are; + -- Either way foldr/build won't happen, so use the more efficient + -- Wadler-style desugaring + || isParallelComp quals + -- Foldr-style desugaring can't handle + -- parallel list comprehensions + then deListComp quals (mkNilExpr elt_ty) + + else -- Foldr/build should be enabled, so desugar + -- into foldrs and builds + newTyVarsDs [alphaTyVar] `thenDs` \ [n_tyvar] -> let n_ty = mkTyVarTy n_tyvar c_ty = mkFunTys [elt_ty, n_ty] n_ty diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index 4b179f5..51edae1 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -113,7 +113,7 @@ dsReify (ReifyOut ReifyType name) dsReify r@(ReifyOut ReifyDecl name) = do { thing <- dsLookupGlobal name ; - mb_d <- repTyClD (ifaceTyThing thing) ; + mb_d <- repTyClD (ifaceTyThing True{-omit pragmas-} thing) ; case mb_d of Just (MkC d) -> return d Nothing -> pprPanic "dsReify" (ppr r) diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index fceb192..6d1aa58 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,6 +1,6 @@ {-# OPTIONS -#include "Linker.h" #-} ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.159 2003/09/04 11:08:46 simonmar Exp $ +-- $Id: InteractiveUI.hs,v 1.160 2003/09/23 14:32:58 simonmar Exp $ -- -- GHC Interactive User Interface -- @@ -492,7 +492,7 @@ info s = do showThing (ty_thing, fixity) = vcat [ text "-- " <> showTyThing ty_thing, showFixity fixity (getName ty_thing), - ppr (ifaceTyThing ty_thing) ] + ppr (ifaceTyThing True{-omit prags-} ty_thing) ] showFixity fix name | fix == defaultFixity = empty @@ -723,10 +723,10 @@ browseModule m exports_only = do thing_names = map getName things - thingDecl thing@(AnId id) = ifaceTyThing thing + thingDecl thing@(AnId id) = ifaceTyThing True{-omit prags-} thing thingDecl thing@(AClass c) = - let rn_decl = ifaceTyThing thing in + let rn_decl = ifaceTyThing True{-omit prags-} thing in case rn_decl of ClassDecl { tcdSigs = cons } -> rn_decl{ tcdSigs = filter methodIsVisible cons } @@ -735,7 +735,7 @@ browseModule m exports_only = do methodIsVisible (ClassOpSig n _ _ _) = n `elem` thing_names thingDecl thing@(ATyCon t) = - let rn_decl = ifaceTyThing thing in + let rn_decl = ifaceTyThing True{-omit prags-} thing in case rn_decl of TyData { tcdCons = DataCons cons } -> rn_decl{ tcdCons = DataCons (filter conIsVisible cons) } @@ -747,8 +747,6 @@ browseModule m exports_only = do vcat (map (ppr . thingDecl) things'))) ) - where - ----------------------------------------------------------------------------- -- Setting the module context @@ -963,7 +961,7 @@ showBindings = do cms <- getCmState let unqual = cmGetPrintUnqual cms - showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b))) + showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing True{-omit prags-} b))) io (mapM_ showBinding (cmGetBindings cms)) return () diff --git a/ghc/compiler/main/BinIface.hs b/ghc/compiler/main/BinIface.hs index a2c8249..c507f2e 100644 --- a/ghc/compiler/main/BinIface.hs +++ b/ghc/compiler/main/BinIface.hs @@ -28,7 +28,7 @@ import Module ( moduleName ) import OccName ( OccName ) import RnHsSyn import DriverState ( v_Build_tag ) -import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_HiVersion ) +import CmdLineOpts ( opt_HiVersion ) import Panic import SrcLoc import Binary @@ -170,9 +170,7 @@ instance (Binary name) => Binary (TyClDecl name) where name <- get bh ty <- lazyGet bh idinfo <- lazyGet bh - let idinfo' | opt_IgnoreIfacePragmas = [] - | otherwise = idinfo - return (IfaceSig name ty idinfo' noSrcLoc) + return (IfaceSig name ty idinfo noSrcLoc) 1 -> error "Binary.get(TyClDecl): ForeignType" 2 -> do n_or_d <- get bh diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 6de5b11..b520eee 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -6,7 +6,7 @@ \begin{code} module CmdLineOpts ( - CoreToDo(..), StgToDo(..), + CoreToDo(..), buildCoreToDo, StgToDo(..), SimplifierSwitch(..), SimplifierMode(..), FloatOutSwitches(..), @@ -30,6 +30,7 @@ module CmdLineOpts ( getOpts, -- (DynFlags -> [a]) -> IO [a] setLang, getVerbFlag, + setOptLevel, -- Manipulating the DynFlags state getDynFlags, -- IO DynFlags @@ -74,14 +75,9 @@ module CmdLineOpts ( opt_NoMethodSharing, opt_DoSemiTagging, opt_LiberateCaseThreshold, - opt_StgDoLetNoEscapes, opt_CprOff, opt_RulesOff, - opt_UnboxStrictFields, opt_SimplNoPreInlining, - opt_SimplDoEtaReduction, - opt_SimplDoLambdaEtaExpansion, - opt_SimplCaseMerge, opt_SimplExcessPrecision, opt_MaxWorkerArgs, @@ -101,11 +97,8 @@ module CmdLineOpts ( opt_GranMacros, opt_HiVersion, opt_HistorySize, - opt_IgnoreAsserts, - opt_IgnoreIfacePragmas, opt_NoHiCheck, opt_OmitBlackHoling, - opt_OmitInterfacePragmas, opt_NoPruneDecls, opt_Static, opt_Unregisterised, @@ -297,10 +290,21 @@ data DynFlag | Opt_Generics | Opt_NoImplicitPrelude + -- optimisation opts + | Opt_Strictness + | 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, hscOutName :: String, -- name of the output file @@ -308,6 +312,9 @@ data DynFlags = DynFlags { 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? stolen_x86_regs :: Int, @@ -346,12 +353,15 @@ defaultHscLang | otherwise = HscC defaultDynFlags = DynFlags { - coreToDo = [], stgToDo = [], + coreToDo = Nothing, stgToDo = [], hscLang = defaultHscLang, hscOutName = "", hscStubHOutName = "", hscStubCOutName = "", extCoreName = "", - verbosity = 0, + verbosity = 0, + optLevel = 0, + maxSimplIterations = 4, + ruleCheck = Nothing, cppFlag = False, ppFlag = False, stolen_x86_regs = 4, @@ -366,9 +376,21 @@ defaultDynFlags = DynFlags { opt_I = [], opt_i = [], #endif - flags = [Opt_Generics] ++ standardWarnings, - -- Generating the helper-functions for - -- generics is now on by default + flags = [ + Opt_Generics, + -- Generating the helper-functions for + -- generics is now on by default + Opt_Strictness, + -- strictness is on by default, but this only + -- applies to -O. + Opt_CSE, + -- similarly for CSE. + 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. + ] ++ standardWarnings, } {- @@ -385,7 +407,7 @@ defaultDynFlags = DynFlags { 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] @@ -418,9 +440,173 @@ setLang l = updDynFlags (\ dfs -> case hscLang dfs of getVerbFlag = do verb <- dynFlag verbosity if verb >= 3 then return "-v" else return "" -\end{code} ----------------------------------------------------------------------------- +-- Setting the optimisation level + +setOptLevel :: Int -> IO () +setOptLevel n + = do dflags <- getDynFlags + if hscLang dflags == HscInterpreted && n > 0 + then putStr "warning: -O conflicts with --interactive; -O ignored.\n" + else updDynFlags (setOptLevel' n) + +setOptLevel' n dfs + = if (n >= 1) + then dfs2{ hscLang = 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 + + extra_dopts + | n == 0 = opt_0_dopts + | otherwise = opt_1_dopts + + 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 + ] + +-- Core-to-core phases: + +buildCoreToDo :: DynFlags -> [CoreToDo] +buildCoreToDo dflags = core_todo + where + opt_level = optLevel dflags + max_iter = maxSimplIterations dflags + strictness = dopt Opt_Strictness dflags + cse = dopt Opt_CSE dflags + rule_check = ruleCheck dflags + + core_todo = + if opt_level == 0 then + [ + CoreDoSimplify (SimplPhase 0) [ + MaxSimplifierIterations max_iter + ] + ] + + 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, + + CoreDoFloatOutwards (FloatOutSw False False), + 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 + ], + + CoreDoFloatOutwards (FloatOutSw False -- Not lambdas + True), -- Float constants + -- 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 + ] + ] + +-- -------------------------------------------------------------------------- -- Mess about with the mutable variables holding the dynamic arguments -- v_InitDynFlags @@ -433,7 +619,6 @@ getVerbFlag = do -- to the value of v_InitDynFlags before each compilation, then -- updated by reading any OPTIONS pragma in the current module. -\begin{code} GLOBAL_VAR(v_InitDynFlags, defaultDynFlags, DynFlags) GLOBAL_VAR(v_DynFlags, defaultDynFlags, DynFlags) @@ -590,8 +775,6 @@ 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 FSLIT("-flet-no-escape") -opt_UnboxStrictFields = lookUp FSLIT("-funbox-strict-fields") opt_MaxWorkerArgs = lookup_def_int "-fmax-worker-args" (10::Int) {- @@ -608,20 +791,14 @@ 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 FSLIT("-fignore-asserts") -opt_IgnoreIfacePragmas = lookUp FSLIT("-fignore-interface-pragmas") opt_NoHiCheck = lookUp FSLIT("-fno-hi-version-check") opt_OmitBlackHoling = lookUp FSLIT("-dno-black-holing") -opt_OmitInterfacePragmas = lookUp FSLIT("-fomit-interface-pragmas") opt_RuntimeTypes = lookUp FSLIT("-fruntime-types") -- Simplifier switches 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 FSLIT("-fdo-eta-reduction") -opt_SimplDoLambdaEtaExpansion = lookUp FSLIT("-fdo-lambda-eta-expansion") -opt_SimplCaseMerge = lookUp FSLIT("-fcase-merge") opt_SimplExcessPrecision = lookUp FSLIT("-fexcess-precision") -- Unfolding control @@ -664,21 +841,14 @@ isStaticHscFlag f = "fflatten", "fsemi-tagging", "flet-no-escape", - "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", - "fomit-interface-pragmas", "fruntime-types", "fno-pre-inlining", - "fdo-eta-reduction", - "fdo-lambda-eta-expansion", - "fcase-merge", "fexcess-precision", "funfolding-update-in-place", "fno-prune-decls", diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs index 337cad7..2dc42a2 100644 --- a/ghc/compiler/main/DriverFlags.hs +++ b/ghc/compiler/main/DriverFlags.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverFlags.hs,v 1.124 2003/09/10 16:44:05 simonmar Exp $ +-- $Id: DriverFlags.hs,v 1.125 2003/09/23 14:32:59 simonmar Exp $ -- -- Driver flags -- @@ -307,28 +307,11 @@ static_flags = , ( "Rghc-timing" , NoArg (enableTimingStats) ) ------ Compiler flags ----------------------------------------------- - , ( "O2-for-C" , NoArg (writeIORef v_minus_o2_for_C True) ) - , ( "O" , NoArg (setOptLevel 1)) - , ( "Onot" , NoArg (setOptLevel 0)) - , ( "O" , PrefixPred (all isDigit) (setOptLevel . read)) - , ( "fno-asm-mangling" , NoArg (writeIORef v_Do_asm_mangling False) ) - , ( "fmax-simplifier-iterations", - PrefixPred (all isDigit) (writeIORef v_MaxSimplifierIterations . read) ) - - , ( "frule-check", - SepArg (\s -> writeIORef v_RuleCheck (Just s)) ) - , ( "fexcess-precision" , NoArg (do writeIORef v_Excess_precision True add v_Opt_C "-fexcess-precision")) - -- Optimisation flags are treated specially, so the normal - -- -fno-* pattern below doesn't work. We therefore allow - -- certain optimisation passes to be turned off explicitly: - , ( "fno-strictness" , NoArg (writeIORef v_Strictness False) ) - , ( "fno-cse" , NoArg (writeIORef v_CSE False) ) - -- All other "-fno-" options cancel out "-f" on the hsc cmdline , ( "fno-", PrefixPred (\s -> isStaticHscFlag ("f"++s)) (\s -> add v_Anti_opt_C ("-f"++s)) ) @@ -417,6 +400,19 @@ dynamic_flags = [ , ( "Wnot" , NoArg (mapM_ unSetDynFlag minusWallOpts) ) /* DEPREC */ , ( "w" , NoArg (mapM_ unSetDynFlag minusWallOpts) ) + ------ Optimisation flags ------------------------------------------ + , ( "O" , NoArg (setOptLevel 1)) + , ( "Onot" , NoArg (setOptLevel 0)) + , ( "O" , PrefixPred (all isDigit) (setOptLevel . read)) + + , ( "fmax-simplifier-iterations", + PrefixPred (all isDigit) + (\n -> updDynFlags (\dfs -> + dfs{ maxSimplIterations = read n })) ) + + , ( "frule-check", + SepArg (\s -> updDynFlags (\dfs -> dfs{ ruleCheck = Just s }))) + ------ Compiler flags ----------------------------------------------- , ( "fasm", AnySuffix (\_ -> setLang HscAsm) ) @@ -464,7 +460,16 @@ fFlags = [ ( "allow-overlapping-instances", Opt_AllowOverlappingInstances ), ( "allow-undecidable-instances", Opt_AllowUndecidableInstances ), ( "allow-incoherent-instances", Opt_AllowIncoherentInstances ), - ( "generics", Opt_Generics ) + ( "generics", Opt_Generics ), + ( "strictness", Opt_Strictness ), + ( "cse", Opt_CSE ), + ( "ignore-interface-pragmas", Opt_IgnoreInterfacePragmas ), + ( "omit-interface-pragmas", Opt_OmitInterfacePragmas ), + ( "do-lambda-eta-expansion", Opt_DoLambdaEtaExpansion ), + ( "ignore-asserts", Opt_IgnoreAsserts ), + ( "do-eta-reduction", Opt_DoEtaReduction ), + ( "case-merge", Opt_CaseMerge ), + ( "unbox-strict-fields", Opt_UnboxStrictFields ) ] glasgowExtsFlags = [ Opt_GlasgowExts, Opt_FFI, Opt_TH, Opt_ImplicitParams ] @@ -506,21 +511,10 @@ buildStaticHscOpts = do opt_C_ <- getStaticOpts v_Opt_C -- misc hsc opts from the command line - -- optimisation - minus_o <- readIORef v_OptLevel - let optimisation_opts = - case minus_o of - 0 -> hsc_minusNoO_flags - 1 -> hsc_minusO_flags - 2 -> hsc_minusO2_flags - n -> throwDyn (CmdLineError ("unknown optimisation level: " - ++ show n)) - -- ToDo: -Ofile - -- take into account -fno-* flags by removing the equivalent -f* -- flag from our list. anti_flags <- getStaticOpts v_Anti_opt_C - let basic_opts = opt_C_ ++ optimisation_opts + let basic_opts = opt_C_ filtered_opts = filter (`notElem` anti_flags) basic_opts static <- (do s <- readIORef v_Static; if s then return "-static" diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index b4e8722..87977cb 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -690,10 +690,6 @@ runPhase cc_phase basename suff input_fn get_output_fn maybe_loc verb <- getVerbFlag - o2 <- readIORef v_minus_o2_for_C - let opt_flag | o2 = "-O2" - | otherwise = "-O" - pkg_extra_cc_opts <- getPackageExtraCcOpts pkgs split_objs <- readIORef v_Split_object_files @@ -718,7 +714,7 @@ runPhase cc_phase basename suff input_fn get_output_fn maybe_loc ++ (if cc_phase == HCc && mangle then md_regd_c_flags else []) - ++ [ verb, "-S", "-Wimplicit", opt_flag ] + ++ [ verb, "-S", "-Wimplicit", "-O" ] ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ] ++ cc_opts ++ split_opt diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs index e8f83a2..74d82e8 100644 --- a/ghc/compiler/main/DriverState.hs +++ b/ghc/compiler/main/DriverState.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverState.hs,v 1.96 2003/09/04 11:08:47 simonmar Exp $ +-- $Id: DriverState.hs,v 1.97 2003/09/23 14:33:00 simonmar Exp $ -- -- Settings for the driver -- @@ -181,175 +181,7 @@ osuf_ify f = do osuf <- readIORef v_Object_suf return (replaceFilenameSuffix f osuf) ------------------------------------------------------------------------------ --- Compiler optimisation options - -GLOBAL_VAR(v_OptLevel, 0, Int) - -setOptLevel :: Int -> IO () -setOptLevel n = do - when (n >= 1) $ setLang HscC -- turn on -fvia-C with -O - writeIORef v_OptLevel n - -GLOBAL_VAR(v_minus_o2_for_C, False, Bool) -GLOBAL_VAR(v_MaxSimplifierIterations, 4, Int) GLOBAL_VAR(v_StgStats, False, Bool) -GLOBAL_VAR(v_Strictness, True, Bool) -GLOBAL_VAR(v_CSE, True, Bool) -GLOBAL_VAR(v_RuleCheck, Nothing, Maybe String) - --- these are the static flags you get without -O. -hsc_minusNoO_flags = - [ - "-fignore-interface-pragmas", - "-fomit-interface-pragmas", - "-fdo-lambda-eta-expansion", -- 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. - "-flet-no-escape" - ] - --- these are the static flags you get when -O is on. -hsc_minusO_flags = - [ - "-fignore-asserts", - "-fdo-eta-reduction", - "-fdo-lambda-eta-expansion", - "-fcase-merge", - "-flet-to-case", - "-flet-no-escape" - ] - -hsc_minusO2_flags = hsc_minusO_flags -- for now - -getStaticOptimisationFlags 0 = hsc_minusNoO_flags -getStaticOptimisationFlags 1 = hsc_minusO_flags -getStaticOptimisationFlags n = hsc_minusO2_flags - -buildCoreToDo :: IO [CoreToDo] -buildCoreToDo = do - opt_level <- readIORef v_OptLevel - max_iter <- readIORef v_MaxSimplifierIterations - strictness <- readIORef v_Strictness - cse <- readIORef v_CSE - rule_check <- readIORef v_RuleCheck - - if opt_level == 0 then return - [ - CoreDoSimplify (SimplPhase 0) [ - MaxSimplifierIterations max_iter - ] - ] - - else {- opt_level >= 1 -} return [ - - -- 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, - - CoreDoFloatOutwards (FloatOutSw False False), - 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 - ], - - CoreDoFloatOutwards (FloatOutSw False -- Not lambdas - True), -- Float constants - -- 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 - ] - ] buildStgToDo :: IO [ StgToDo ] buildStgToDo = do diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index 5c66a92..1731fa5 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -1,7 +1,7 @@ {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-} ----------------------------------------------------------------------------- --- $Id: Main.hs,v 1.132 2003/09/04 11:08:47 simonmar Exp $ +-- $Id: Main.hs,v 1.133 2003/09/23 14:33:00 simonmar Exp $ -- -- GHC Driver program -- @@ -31,12 +31,12 @@ import Packages ( showPackages, getPackageConfigMap, basePackage, haskell98Package ) import DriverPipeline ( staticLink, doMkDLL, runPipeline ) -import DriverState ( buildCoreToDo, buildStgToDo, +import DriverState ( buildStgToDo, findBuildTag, getPackageExtraGhcOpts, unregFlags, v_GhcMode, v_GhcModeFlag, GhcMode(..), v_Keep_tmp_files, v_Ld_inputs, v_Ways, - v_OptLevel, v_Output_file, v_Output_hi, + v_Output_file, v_Output_hi, readPackageConf, verifyOutputFiles, v_NoLink, v_Build_tag ) @@ -141,10 +141,6 @@ main = -- -O and --interactive are not a good combination -- ditto with any kind of way selection - orig_opt_level <- readIORef v_OptLevel - when (orig_opt_level > 0 && isInteractive mode) $ - do putStr "warning: -O conflicts with --interactive; -O turned off.\n" - writeIORef v_OptLevel 0 orig_ways <- readIORef v_Ways when (notNull orig_ways && isInteractive mode) $ do throwDyn (UsageError @@ -167,7 +163,6 @@ main = -- build the default DynFlags (these may be adjusted on a per -- module basis by OPTIONS pragmas and settings in the interpreter). - core_todo <- buildCoreToDo stg_todo <- buildStgToDo -- set the "global" HscLang. The HscLang can be further adjusted on a module @@ -183,8 +178,7 @@ main = -- for ways other that the normal way, we must -- compile via C. - setDynFlags (dyn_flags{ coreToDo = core_todo, - stgToDo = stg_todo, + setDynFlags (dyn_flags{ stgToDo = stg_todo, hscLang = lang, -- leave out hscOutName for now hscOutName = panic "Main.main:hscOutName not set", diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 49d428f..0172930 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -182,6 +182,7 @@ mkIface hsc_env location maybe_old_iface where dflags = hsc_dflags hsc_env ghci_mode = hsc_mode hsc_env + omit_pragmas = dopt Opt_OmitInterfacePragmas dflags must_write_hi_file Nothing = False must_write_hi_file (Just _diffs) = ghci_mode /= Interactive @@ -194,7 +195,7 @@ mkIface hsc_env location maybe_old_iface hi_file_path = ml_hi_file location new_decls = mkIfaceDecls ty_cls_dcls rule_dcls inst_dcls inst_dcls = map ifaceInstance insts - ty_cls_dcls = foldNameEnv ifaceTyThing_acc [] types + ty_cls_dcls = foldNameEnv (ifaceTyThing_acc omit_pragmas) [] types rule_dcls = map ifaceRule rules orphan_mod = isOrphanModule impl @@ -225,20 +226,21 @@ Implicit Ids and class tycons aren't included in interface files, so we miss them out of the accumulating parameter here. \begin{code} -ifaceTyThing_acc :: TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl] +ifaceTyThing_acc :: Bool -> TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl] -- Don't put implicit things into the result -ifaceTyThing_acc (ADataCon dc) so_far = so_far -ifaceTyThing_acc (AnId id) so_far | isImplicitId id = so_far -ifaceTyThing_acc (ATyCon id) so_far | isClassTyCon id = so_far -ifaceTyThing_acc other so_far = ifaceTyThing other : so_far +ifaceTyThing_acc omit_pragmas (ADataCon dc) so_far = so_far +ifaceTyThing_acc omit_pragmas (AnId id) so_far | isImplicitId id = so_far +ifaceTyThing_acc omit_pragmas (ATyCon id) so_far | isClassTyCon id = so_far +ifaceTyThing_acc omit_pragmas other so_far + = ifaceTyThing omit_pragmas other : so_far \end{code} Convert *any* TyThing into a RenamedTyClDecl. Used both for generating interface files and for the ':info' command in GHCi. \begin{code} -ifaceTyThing :: TyThing -> RenamedTyClDecl -ifaceTyThing (AClass clas) = cls_decl +ifaceTyThing :: Bool -> TyThing -> RenamedTyClDecl +ifaceTyThing omit_pragmas (AClass clas) = cls_decl where cls_decl = ClassDecl { tcdCtxt = toHsContext sc_theta, tcdName = getName clas, @@ -264,7 +266,7 @@ ifaceTyThing (AClass clas) = cls_decl (sel_tyvars, rho_ty) = tcSplitForAllTys (idType sel_id) op_ty = tcFunResultTy rho_ty -ifaceTyThing (ATyCon tycon) = ty_decl +ifaceTyThing omit_pragmas (ATyCon tycon) = ty_decl where ty_decl | isSynTyCon tycon = TySynonym { tcdName = getName tycon, @@ -332,7 +334,7 @@ ifaceTyThing (ATyCon tycon) = ty_decl mk_field strict_mark field_label = (getName field_label, BangType strict_mark (toHsType (fieldLabelType field_label))) -ifaceTyThing (AnId id) = iface_sig +ifaceTyThing omit_pragmas (AnId id) = iface_sig where iface_sig = IfaceSig { tcdName = getName id, tcdType = toHsType id_type, @@ -344,7 +346,7 @@ ifaceTyThing (AnId id) = iface_sig arity_info = arityInfo id_info caf_info = idCafInfo id - hs_idinfo | opt_OmitInterfacePragmas + hs_idinfo | omit_pragmas = [] | otherwise = catMaybes [arity_hsinfo, caf_hsinfo, @@ -384,7 +386,7 @@ ifaceTyThing (AnId id) = iface_sig | otherwise = Just (HsUnfold inline_prag (toUfExpr rhs)) -ifaceTyThing (ADataCon dc) +ifaceTyThing omit_pragmas (ADataCon dc) -- This case only happens in the call to ifaceThing in InteractiveUI -- Otherwise DataCons are filtered out in ifaceThing_acc = IfaceSig { tcdName = getName dc, diff --git a/ghc/compiler/main/TidyPgm.lhs b/ghc/compiler/main/TidyPgm.lhs index d543080..61b5b8e 100644 --- a/ghc/compiler/main/TidyPgm.lhs +++ b/ghc/compiler/main/TidyPgm.lhs @@ -8,7 +8,7 @@ module TidyPgm( tidyCorePgm, tidyCoreExpr ) where #include "HsVersions.h" -import CmdLineOpts ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas ) +import CmdLineOpts ( DynFlags, DynFlag(..), dopt ) import CoreSyn import CoreUnfold ( noUnfolding, mkTopUnfolding ) import CoreFVs ( ruleLhsFreeIds, ruleRhsFreeVars, exprSomeFreeVars ) @@ -129,8 +129,9 @@ tidyCorePgm dflags pcs mg_binds = binds_in, mg_rules = orphans_in }) = do { showPass dflags "Tidy Core" - ; let ext_ids = findExternalSet binds_in orphans_in - ; let ext_rules = findExternalRules binds_in orphans_in ext_ids + ; let omit_iface_prags = dopt Opt_OmitInterfacePragmas dflags + ; let ext_ids = findExternalSet omit_iface_prags binds_in orphans_in + ; let ext_rules = findExternalRules omit_iface_prags binds_in orphans_in ext_ids -- findExternalRules filters ext_rules to avoid binders that -- aren't externally visible; but the externally-visible binders -- are computed (by findExternalSet) assuming that all orphan @@ -165,7 +166,7 @@ tidyCorePgm dflags pcs ; let pcs' = pcs { pcs_nc = orig_ns' } - ; let tidy_type_env = mkFinalTypeEnv env_tc tidy_binds + ; let tidy_type_env = mkFinalTypeEnv omit_iface_prags env_tc tidy_binds -- Dfuns are local Ids that might have -- changed their unique during tidying. Remember @@ -209,7 +210,8 @@ tidyCoreExpr expr = return (tidyExpr emptyTidyEnv expr) %************************************************************************ \begin{code} -mkFinalTypeEnv :: TypeEnv -- From typechecker +mkFinalTypeEnv :: Bool -- Omit interface pragmas + -> TypeEnv -- From typechecker -> [CoreBind] -- Final Ids -> TypeEnv @@ -228,7 +230,7 @@ mkFinalTypeEnv :: TypeEnv -- From typechecker -- in interface files, because they are needed by importing modules when -- using the compilation manager -mkFinalTypeEnv type_env tidy_binds +mkFinalTypeEnv omit_iface_prags type_env tidy_binds = extendTypeEnvList (filterNameEnv keep_it type_env) final_ids where final_ids = [ AnId (strip_id_info id) @@ -237,8 +239,8 @@ mkFinalTypeEnv type_env tidy_binds isExternalName (idName id)] strip_id_info id - | opt_OmitInterfacePragmas = id `setIdInfo` vanillaIdInfo - | otherwise = id + | omit_iface_prags = id `setIdInfo` vanillaIdInfo + | otherwise = id -- If the interface file has no pragma info then discard all -- info right here. -- @@ -264,15 +266,16 @@ mkFinalTypeEnv type_env tidy_binds \end{code} \begin{code} -findExternalRules :: [CoreBind] +findExternalRules :: Bool -- Omit interface pragmas + -> [CoreBind] -> [IdCoreRule] -- Orphan rules -> IdEnv a -- Ids that are exported, so we need their rules -> [IdCoreRule] -- The complete rules are gotten by combining -- a) the orphan rules -- b) rules embedded in the top-level Ids -findExternalRules binds orphan_rules ext_ids - | opt_OmitInterfacePragmas = [] +findExternalRules omit_iface_prags binds orphan_rules ext_ids + | omit_iface_prags = [] | otherwise = filter needed_rule (orphan_rules ++ local_rules) where @@ -302,11 +305,12 @@ findExternalRules binds orphan_rules ext_ids %************************************************************************ \begin{code} -findExternalSet :: [CoreBind] -> [IdCoreRule] +findExternalSet :: Bool -- omit interface pragmas + -> [CoreBind] -> [IdCoreRule] -> IdEnv Bool -- In domain => external -- Range = True <=> show unfolding -- Step 1 from the notes above -findExternalSet binds orphan_rules +findExternalSet omit_iface_prags binds orphan_rules = foldr find init_needed binds where orphan_rule_ids :: IdSet @@ -320,7 +324,7 @@ findExternalSet binds orphan_rules -- (When we come to the binding site we may change our mind, of course.) find (NonRec id rhs) needed - | need_id needed id = addExternal (id,rhs) needed + | need_id needed id = addExternal omit_iface_prags (id,rhs) needed | otherwise = needed find (Rec prs) needed = find_prs prs needed @@ -330,7 +334,7 @@ findExternalSet binds orphan_rules | otherwise = find_prs other_prs new_needed where (needed_prs, other_prs) = partition (need_pr needed) prs - new_needed = foldr addExternal needed needed_prs + new_needed = foldr (addExternal omit_iface_prags) needed needed_prs -- The 'needed' set contains the Ids that are needed by earlier -- interface file emissions. If the Id isn't in this set, and isn't @@ -338,10 +342,10 @@ findExternalSet binds orphan_rules need_id needed_set id = id `elemVarEnv` needed_set || isExportedId id need_pr needed_set (id,rhs) = need_id needed_set id -addExternal :: (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool +addExternal :: Bool -> (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool -- The Id is needed; extend the needed set -- with it and its dependents (free vars etc) -addExternal (id,rhs) needed +addExternal omit_iface_prags (id,rhs) needed = extendVarEnv (foldVarSet add_occ needed new_needed_ids) id show_unfold where @@ -349,10 +353,10 @@ addExternal (id,rhs) needed -- "False" because we don't know we need the Id's unfolding -- We'll override it later when we find the binding site - new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet - | otherwise = worker_ids `unionVarSet` - unfold_ids `unionVarSet` - spec_ids + new_needed_ids | omit_iface_prags = emptyVarSet + | otherwise = worker_ids `unionVarSet` + unfold_ids `unionVarSet` + spec_ids idinfo = idInfo id dont_inline = isNeverActive (inlinePragInfo idinfo) diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index 985e501..194e457 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- -*-haskell-*- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.123 2003/09/16 13:03:44 simonmar Exp $ +$Id: Parser.y,v 1.124 2003/09/23 14:33:02 simonmar Exp $ Haskell grammar. @@ -814,19 +814,19 @@ forall :: { [RdrNameHsTyVar] } constr_stuff :: { (RdrName, RdrNameConDetails) } : btype {% mkPrefixCon $1 [] } - | btype '!' atype satypes {% mkPrefixCon $1 (BangType MarkedUserStrict $3 : $4) } + | btype strict_mark atype satypes {% mkPrefixCon $1 (BangType $2 $3 : $4) } | oqtycon '{' '}' {% mkRecCon $1 [] } | oqtycon '{' fielddecls '}' {% mkRecCon $1 $3 } | sbtype conop sbtype { ($2, InfixCon $1 $3) } satypes :: { [RdrNameBangType] } : atype satypes { unbangedType $1 : $2 } - | '!' atype satypes { BangType MarkedUserStrict $2 : $3 } + | strict_mark atype satypes { BangType $1 $2 : $3 } | {- empty -} { [] } sbtype :: { RdrNameBangType } : btype { unbangedType $1 } - | '!' atype { BangType MarkedUserStrict $2 } + | strict_mark atype { BangType $1 $2 } fielddecls :: { [([RdrName],RdrNameBangType)] } : fielddecl ',' fielddecls { $1 : $3 } @@ -837,7 +837,11 @@ fielddecl :: { ([RdrName],RdrNameBangType) } stype :: { RdrNameBangType } : ctype { unbangedType $1 } - | '!' atype { BangType MarkedUserStrict $2 } + | strict_mark atype { BangType $1 $2 } + +strict_mark :: { StrictnessMark } + : '!' { MarkedUserStrict } + | '!' '!' { MarkedUserUnboxed } deriving :: { Maybe RdrNameContext } : {- empty -} { Nothing } diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 2b1f285..131a66c 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -31,7 +31,7 @@ import RnEnv import RnNames ( importsFromLocalDecls ) import RnTypes ( rnHsTypeFVs, rnPat, litFVs, rnOverLit, rnPatsAndThen, dupFieldErr, precParseErr, sectionPrecErr, patSigErr, checkTupSize ) -import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts ) +import CmdLineOpts ( DynFlag(..) ) import BasicTypes ( Fixity(..), FixityDirection(..), IPName(..), defaultFixity, negateFixity, compareFixity ) import PrelNames ( hasKey, assertIdKey, @@ -159,7 +159,8 @@ rnExpr :: RdrNameHsExpr -> RnM (RenamedHsExpr, FreeVars) rnExpr (HsVar v) = lookupOccRn v `thenM` \ name -> - if name `hasKey` assertIdKey && not opt_IgnoreAsserts then + doptM Opt_IgnoreAsserts `thenM` \ ignore_asserts -> + if name `hasKey` assertIdKey && not ignore_asserts then -- We expand it to (GHC.Err.assertError location_string) mkAssertErrorExpr `thenM` \ (e, fvs) -> returnM (e, fvs `addOneFV` name) diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index 57b32e7..d83b881 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -15,7 +15,7 @@ module RnHiFiles ( import DriverState ( v_GhcMode, isCompManagerMode ) import DriverUtil ( replaceFilenameSuffix ) -import CmdLineOpts ( opt_IgnoreIfacePragmas ) +import CmdLineOpts ( DynFlag(..) ) import Parser ( parseIface ) import HscTypes ( ModIface(..), emptyModIface, ExternalPackageState(..), noDependencies, @@ -287,7 +287,8 @@ loadDecls mod (decls_map, n_slurped) decls returnM (vers, (decls_map', n_slurped)) loadDecl mod (version_map, decls_map) (version, decl) - = getTyClDeclBinders mod decl `thenM` \ avail -> + = maybeStripPragmas decl `thenM` \ decl -> + getTyClDeclBinders mod decl `thenM` \ avail -> getSysBinders mod decl `thenM` \ sys_names -> let full_avail = case avail of @@ -303,7 +304,13 @@ loadDecl mod (version_map, decls_map) (version, decl) -- traceRn (text "Loading" <+> ppr full_avail) `thenM_` returnM (new_version_map, new_decls_map) - +maybeStripPragmas sig@(IfaceSig {tcdIdInfo = idinfo}) + = doptM Opt_IgnoreInterfacePragmas `thenM` \ ignore_prags -> + if ignore_prags + then returnM sig{ tcdIdInfo = [] } + else returnM sig +maybeStripPragmas other + = returnM other ----------------- getTyClDeclBinders :: Module -> RdrNameTyClDecl -> TcRn m AvailInfo @@ -435,11 +442,12 @@ loadRules :: Module -> (Version, [RdrNameRuleDecl]) -> RnM (Version, IfaceRules) loadRules mod (rule_bag, n_slurped) (version, rules) - | null rules || opt_IgnoreIfacePragmas - = returnM (version, (rule_bag, n_slurped)) - | otherwise - = mappM (loadRule mod) rules `thenM` \ new_rules -> - returnM (version, (rule_bag `unionBags` listToBag new_rules, n_slurped)) + = doptM Opt_IgnoreInterfacePragmas `thenM` \ ignore_prags -> + if null rules || ignore_prags + then returnM (version, (rule_bag, n_slurped)) + else mappM (loadRule mod) rules `thenM` \ new_rules -> + returnM (version, (rule_bag `unionBags` + listToBag new_rules, n_slurped)) loadRule :: Module -> RdrNameRuleDecl -> RnM (GatedDecl RdrNameRuleDecl) -- "Gate" the rule simply by whether the rule variable is diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index e3aa3a4..81a2990 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -12,7 +12,7 @@ where #include "HsVersions.h" -import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_NoPruneDecls ) +import CmdLineOpts ( DynFlag(..), opt_NoPruneDecls ) import HscTypes import HsSyn ( HsDecl(..), Sig(..), TyClDecl(..), ConDecl(..), HsConDetails(..), InstDecl(..), HsType(..), hsTyVarNames, getBangType @@ -535,9 +535,9 @@ ppr_brief_inst_decl (mod, InstDecl inst_ty _ _ _ _) getImportedRules :: NameSet -- Slurped already -> TcRn m [(Module,RdrNameRuleDecl)] getImportedRules slurped - | opt_IgnoreIfacePragmas = returnM [] - | otherwise - = getEps `thenM` \ eps -> + = doptM Opt_IgnoreInterfacePragmas `thenM` \ ignore_prags -> + if ignore_prags then returnM [] else -- ... + getEps `thenM` \ eps -> getInGlobalScope `thenM` \ in_type_env -> let -- Slurp rules for anything that is slurped, -- either now, or previously diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index be781e6..24f465b 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -10,7 +10,7 @@ module SimplCore ( core2core, simplifyExpr ) where import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), SimplifierMode(..), DynFlags, DynFlag(..), dopt, - dopt_CoreToDo + dopt_CoreToDo, buildCoreToDo ) import CoreSyn import CoreFVs ( ruleRhsFreeVars ) @@ -77,7 +77,9 @@ core2core hsc_env pkg_rule_base let dflags = hsc_dflags hsc_env hpt = hsc_HPT hsc_env ghci_mode = hsc_mode hsc_env - core_todos = dopt_CoreToDo dflags + core_todos + | Just todo <- dopt_CoreToDo dflags = todo + | otherwise = buildCoreToDo dflags us <- mkSplitUniqSupply 's' let (cp_us, ru_us) = splitUniqSupply us diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index b57b4b1..83384cf 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -20,10 +20,8 @@ module SimplUtils ( #include "HsVersions.h" -import CmdLineOpts ( SimplifierSwitch(..), - opt_SimplDoLambdaEtaExpansion, opt_SimplDoEtaReduction, - opt_SimplCaseMerge, opt_UF_UpdateInPlace - ) +import CmdLineOpts ( SimplifierSwitch(..), opt_UF_UpdateInPlace, + DynFlag(..), dopt ) import CoreSyn import CoreFVs ( exprFreeVars ) import CoreUtils ( cheapEqExpr, exprType, exprIsTrivial, @@ -504,15 +502,19 @@ Try three things \begin{code} mkLam env bndrs body cont - | opt_SimplDoEtaReduction, - Just etad_lam <- tryEtaReduce bndrs body - = tick (EtaReduction (head bndrs)) `thenSmpl_` - returnSmpl (emptyFloats env, etad_lam) - - | opt_SimplDoLambdaEtaExpansion, - any isRuntimeVar bndrs - = tryEtaExpansion body `thenSmpl` \ body' -> - returnSmpl (emptyFloats env, mkLams bndrs body') + = getDOptsSmpl `thenSmpl` \dflags -> + mkLam' dflags env bndrs body cont + where + mkLam' dflags env bndrs body cont + | dopt Opt_DoEtaReduction dflags, + Just etad_lam <- tryEtaReduce bndrs body + = tick (EtaReduction (head bndrs)) `thenSmpl_` + returnSmpl (emptyFloats env, etad_lam) + + | dopt Opt_DoLambdaEtaExpansion dflags, + any isRuntimeVar bndrs + = tryEtaExpansion body `thenSmpl` \ body' -> + returnSmpl (emptyFloats env, mkLams bndrs body') {- Sept 01: I'm experimenting with getting the full laziness pass to float out past big lambdsa @@ -525,8 +527,8 @@ mkLam env bndrs body cont returnSmpl (floats, mkLams bndrs body') -} - | otherwise - = returnSmpl (emptyFloats env, mkLams bndrs body) + | otherwise + = returnSmpl (emptyFloats env, mkLams bndrs body) \end{code} @@ -1007,12 +1009,16 @@ mkAlts scrut case_bndr alts@((con1,bndrs1,rhs1) : con_alts) -------------------------------------------------- mkAlts scrut outer_bndr outer_alts - | opt_SimplCaseMerge, - (outer_alts_without_deflt, maybe_outer_deflt) <- findDefault outer_alts, - Just (Case (Var scrut_var) inner_bndr inner_alts) <- maybe_outer_deflt, - scruting_same_var scrut_var + = getDOptsSmpl `thenSmpl` \dflags -> + mkAlts' dflags scrut outer_bndr outer_alts + where + mkAlts' dflags scrut outer_bndr outer_alts + | dopt Opt_CaseMerge dflags, + (outer_alts_without_deflt, maybe_outer_deflt) <- findDefault outer_alts, + Just (Case (Var scrut_var) inner_bndr inner_alts) <- maybe_outer_deflt, + scruting_same_var scrut_var - = let -- Eliminate any inner alts which are shadowed by the outer ones + = let -- Eliminate any inner alts which are shadowed by the outer ones outer_cons = [con | (con,_,_) <- outer_alts_without_deflt] munged_inner_alts = [ (con, args, munge_rhs rhs) @@ -1033,24 +1039,24 @@ mkAlts scrut outer_bndr outer_alts -- mkCase applied to them, so they won't have a case in their default -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr -- in munge_rhs may put a case into the DEFAULT branch! - where + where -- We are scrutinising the same variable if it's -- the outer case-binder, or if the outer case scrutinises a variable -- (and it's the same). Testing both allows us not to replace the -- outer scrut-var with the outer case-binder (Simplify.simplCaseBinder). - scruting_same_var = case scrut of + scruting_same_var = case scrut of Var outer_scrut -> \ v -> v == outer_bndr || v == outer_scrut other -> \ v -> v == outer_bndr - add_default (Just rhs) alts = (DEFAULT,[],rhs) : alts - add_default Nothing alts = alts + add_default (Just rhs) alts = (DEFAULT,[],rhs) : alts + add_default Nothing alts = alts -------------------------------------------------- -- Catch-all -------------------------------------------------- -mkAlts scrut case_bndr other_alts = returnSmpl other_alts + mkAlts' dflags scrut case_bndr other_alts = returnSmpl other_alts \end{code} diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 29be17e..bc339cc 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -12,7 +12,7 @@ import HsSyn ( TyClDecl(..), ConDecl(..), HsConDetails(..), BangType, getBangType, getBangStrictness, conDetailsTys ) import RnHsSyn ( RenamedTyClDecl, RenamedConDecl, RenamedContext ) -import BasicTypes ( NewOrData(..), StrictnessMark ) +import BasicTypes ( NewOrData(..), StrictnessMark(..) ) import TcMonoType ( tcHsTyVars, tcHsTheta, tcHsType, kcHsContext, kcHsSigType, kcHsLiftedSigType @@ -178,8 +178,18 @@ tcMkDataCon src_name arg_stricts fields -- This last one takes the name of the data constructor in the source -- code, which (for Haskell source anyway) will be in the SrcDataName name -- space, and makes it into a "real data constructor name" + + doptM Opt_UnboxStrictFields `thenM` \ unbox_strict_fields -> + let - data_con = mkDataCon src_name arg_stricts fields + real_stricts + | unbox_strict_fields = map unboxUserStrict arg_stricts + | otherwise = arg_stricts + + unboxUserStrict MarkedUserStrict = MarkedUserUnboxed + unboxUserStrict other = other + + data_con = mkDataCon src_name real_stricts fields tyvars (thinContext arg_tys ctxt) ex_tyvars ex_theta arg_tys tycon