From: simonpj Date: Mon, 22 Apr 2002 16:06:37 +0000 (+0000) Subject: [project @ 2002-04-22 16:06:35 by simonpj] X-Git-Tag: Approx_11550_changesets_converted~2122 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=dbfe93e664ee00ad854114128ffbace2a5298da4;hp=acaaf62143d015fe66ec9b100bd7f0ea1df523cb;p=ghc-hetmet.git [project @ 2002-04-22 16:06:35 by simonpj] CPR control 1. Remove -fno-cpr, add -fcpr-off which is a simple static flag for switching the new CPR analysis off altogether. (The "-fno" machinery is rather complicated.) 2. Rejig SimplCore a little so that the "old strictness analyser" runs both the old strictness analyser and the old CPR analyser, which makes it more like the new strictness/CPR analyser. (How much longer we keep the old strictness/CPR analyser in the compiler at all I don't know. It's just for comparision purposes when we write the paper.) --- diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 2dc8b42..6a7ff62 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -189,7 +189,7 @@ mk_strict_sig name arity dmd_ty mkStrictSig dmd_ty newRes True _ = BotRes -newRes False ReturnsCPR = RetCPR +newRes False ReturnsCPR = retCPR newRes False NoCPRInfo = TopRes newDemand :: Demand.Demand -> NewDemand.Demand diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index adcd06b..ee92ad1 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -80,7 +80,7 @@ import IdInfo ( IdInfo, noCafNoTyGenIdInfo, GlobalIdDetails(..), CafInfo(..) ) import NewDemand ( mkStrictSig, strictSigResInfo, DmdResult(..), - mkTopDmdType, topDmd, evalDmd, lazyDmd, + mkTopDmdType, topDmd, evalDmd, lazyDmd, retCPR, Demand(..), Demands(..) ) import FieldLabel ( mkFieldLabel, fieldLabelName, firstFieldLabelTag, allFieldLabelTags, fieldLabelType @@ -176,7 +176,7 @@ mkDataConId work_name data_con cpr_info | isProductTyCon tycon && isDataTyCon tycon && arity > 0 && - arity <= mAX_CPR_SIZE = RetCPR + arity <= mAX_CPR_SIZE = retCPR | otherwise = TopRes -- RetCPR is only true for products that are real data types; -- that is, not unboxed tuples or [non-recursive] newtypes diff --git a/ghc/compiler/basicTypes/NewDemand.lhs b/ghc/compiler/basicTypes/NewDemand.lhs index cafd67c..9da7b7e 100644 --- a/ghc/compiler/basicTypes/NewDemand.lhs +++ b/ghc/compiler/basicTypes/NewDemand.lhs @@ -12,17 +12,19 @@ module NewDemand( DmdType(..), topDmdType, botDmdType, mkDmdType, mkTopDmdType, dmdTypeDepth, dmdTypeRes, seqDmdType, DmdEnv, emptyDmdEnv, - DmdResult(..), isBotRes, returnsCPR, resTypeArgDmd, + DmdResult(..), retCPR, isBotRes, returnsCPR, resTypeArgDmd, Demands(..), mapDmds, zipWithDmds, allTop, seqDemands, - StrictSig(..), mkStrictSig, topSig, botSig, isTopSig, + StrictSig(..), mkStrictSig, topSig, botSig, cprSig, + isTopSig, splitStrictSig, strictSigResInfo, pprIfaceStrictSig, appIsBottom, isBottomingSig, seqStrictSig, ) where #include "HsVersions.h" +import CmdLineOpts ( opt_CprOff ) import BasicTypes ( Arity ) import VarEnv ( VarEnv, emptyVarEnv, isEmptyVarEnv ) import UniqFM ( ufmToList ) @@ -159,6 +161,14 @@ data DmdType = DmdType -- Handwavey reason: these don't correspond to calling conventions -- See DmdAnal.funArgDemand for details + +-- This guy lets us switch off CPR analysis +-- by making sure that everything uses TopRes instead of RetCPR +-- Assuming, of course, that they don't mention RetCPR by name. +-- They should onlyu use retCPR +retCPR | opt_CprOff = TopRes + | otherwise = RetCPR + seqDmdType (DmdType env ds res) = {- ??? env `seq` -} seqDemandList ds `seq` res `seq` () @@ -194,8 +204,10 @@ instance Outputable DmdResult where -- without ambiguity emptyDmdEnv = emptyVarEnv + topDmdType = DmdType emptyDmdEnv [] TopRes botDmdType = DmdType emptyDmdEnv [] BotRes +cprDmdType = DmdType emptyVarEnv [] retCPR isTopDmdType :: DmdType -> Bool -- Only used on top-level types, hence the assert @@ -288,8 +300,11 @@ strictSigResInfo (StrictSig (DmdType _ _ res)) = res isTopSig (StrictSig ty) = isTopDmdType ty +topSig, botSig, cprSig :: StrictSig topSig = StrictSig topDmdType botSig = StrictSig botDmdType +cprSig = StrictSig cprDmdType + -- appIsBottom returns true if an application to n args would diverge appIsBottom (StrictSig (DmdType _ ds BotRes)) n = listLengthCmp ds n /= GT diff --git a/ghc/compiler/main/BinIface.hs b/ghc/compiler/main/BinIface.hs index 799ce15..611bd53 100644 --- a/ghc/compiler/main/BinIface.hs +++ b/ghc/compiler/main/BinIface.hs @@ -575,7 +575,7 @@ instance Binary DmdResult where h <- getByte bh case h of 0 -> do return TopRes - 1 -> do return RetCPR + 1 -> do return retCPR _ -> do return BotRes instance Binary StrictSig where diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 3e0f33a..94dd354 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -77,6 +77,7 @@ module CmdLineOpts ( opt_LiberateCaseThreshold, opt_StgDoLetNoEscapes, opt_UnfoldCasms, + opt_CprOff, opt_UsageSPOn, opt_UnboxStrictFields, opt_SimplNoPreInlining, @@ -186,7 +187,7 @@ data CoreToDo -- These are diff core-to-core passes, | CoreDoSpecialising | CoreDoSpecConstr | CoreDoUSPInf - | CoreDoCPResult + | CoreDoOldStrictness | CoreDoGlomBinds | CoreCSE | CoreDoRuleCheck Int{-CompilerPhase-} String -- Check for non-application of rules @@ -585,6 +586,8 @@ opt_Flatten = lookUp FSLIT("-fflatten") opt_NoMethodSharing = lookUp FSLIT("-fno-method-sharing") opt_DoSemiTagging = lookUp FSLIT("-fsemi-tagging") opt_FoldrBuildOn = lookUp FSLIT("-ffoldr-build-on") +opt_CprOff = lookUp FSLIT("-fcpr-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_UnfoldCasms = lookUp FSLIT("-funfold-casms-in-hi-file") @@ -688,7 +691,8 @@ isStaticHscFlag f = "static", "funregisterised", "fext-core", - "frule-check" + "frule-check", + "fcpr-off" ] || any (flip prefixMatch f) [ "fcontext-stack", diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs index 6a6a744..2ebd51d 100644 --- a/ghc/compiler/main/DriverFlags.hs +++ b/ghc/compiler/main/DriverFlags.hs @@ -1,7 +1,7 @@ {-# OPTIONS -#include "hschooks.h" #-} ----------------------------------------------------------------------------- --- $Id: DriverFlags.hs,v 1.91 2002/04/05 23:24:29 sof Exp $ +-- $Id: DriverFlags.hs,v 1.92 2002/04/22 16:06:36 simonpj Exp $ -- -- Driver flags -- @@ -322,9 +322,6 @@ static_flags = -- -fno-* pattern below doesn't work. We therefore allow -- certain optimisation passes to be turned off explicitly: , ( "fno-strictness" , NoArg (writeIORef v_Strictness False) ) -#ifdef OLD_STRICTNESS - , ( "fno-cpr" , NoArg (writeIORef v_CPR False) ) -#endif , ( "fno-cse" , NoArg (writeIORef v_CSE False) ) -- All other "-fno-" options cancel out "-f" on the hsc cmdline diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs index cd4f1fb..1948933 100644 --- a/ghc/compiler/main/DriverState.hs +++ b/ghc/compiler/main/DriverState.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverState.hs,v 1.76 2002/04/05 23:24:29 sof Exp $ +-- $Id: DriverState.hs,v 1.77 2002/04/22 16:06:36 simonpj Exp $ -- -- Settings for the driver -- @@ -192,9 +192,6 @@ GLOBAL_VAR(v_MaxSimplifierIterations, 4, Int) GLOBAL_VAR(v_StgStats, False, Bool) GLOBAL_VAR(v_UsageSPInf, False, Bool) -- Off by default GLOBAL_VAR(v_Strictness, True, Bool) -#ifdef OLD_STRICTNESS -GLOBAL_VAR(v_CPR, True, Bool) -#endif GLOBAL_VAR(v_CSE, True, Bool) GLOBAL_VAR(v_RuleCheck, Nothing, Maybe String) @@ -234,9 +231,6 @@ buildCoreToDo = do max_iter <- readIORef v_MaxSimplifierIterations usageSP <- readIORef v_UsageSPInf strictness <- readIORef v_Strictness -#ifdef OLD_STRICTNESS - cpr <- readIORef v_CPR -#endif cse <- readIORef v_CSE rule_check <- readIORef v_RuleCheck @@ -313,7 +307,7 @@ buildCoreToDo = do case rule_check of { Just pat -> CoreDoRuleCheck 0 pat; Nothing -> CoreDoNothing }, #ifdef OLD_STRICTNESS - if cpr then CoreDoCPResult else CoreDoNothing, + CoreDoOldStrictness #endif if strictness then CoreDoStrictness else CoreDoNothing, CoreDoWorkerWrapper, diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index facff06..d5cb99a 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -39,10 +39,12 @@ import SAT ( doStaticArgs ) import Specialise ( specProgram) import SpecConstr ( specConstrProgram) import UsageSPInf ( doUsageSPInf ) -import StrictAnal ( saBinds ) import DmdAnal ( dmdAnalPgm ) import WorkWrap ( wwTopBinds ) +#ifdef OLD_STRICTNESS +import StrictAnal ( saBinds ) import CprAnalyse ( cprAnalyse ) +#endif import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) import IO ( hPutStr, stderr ) @@ -152,7 +154,7 @@ doCorePass dfs rb us binds (CoreDoFloatOutwards f) doCorePass dfs rb us binds CoreDoStaticArgs = _scc_ "StaticArgs" noStats dfs (doStaticArgs us binds) doCorePass dfs rb us binds CoreDoStrictness - = _scc_ "Stranal" noStats dfs (strictAnal dfs binds) + = _scc_ "Stranal" noStats dfs (dmdAnalPgm dfs binds) doCorePass dfs rb us binds CoreDoWorkerWrapper = _scc_ "WorkWrap" noStats dfs (wwTopBinds dfs us binds) doCorePass dfs rb us binds CoreDoSpecialising @@ -160,8 +162,8 @@ doCorePass dfs rb us binds CoreDoSpecialising doCorePass dfs rb us binds CoreDoSpecConstr = _scc_ "SpecConstr" noStats dfs (specConstrProgram dfs us binds) #ifdef OLD_STRICTNESS -doCorePass dfs rb us binds CoreDoCPResult - = _scc_ "CPResult" noStats dfs (cprAnalyse dfs binds) +doCorePass dfs rb us binds CoreDoOldStrictness + = _scc_ "OldStrictness" noStats dfs (doOldStrictness dfs binds) #endif doCorePass dfs rb us binds CoreDoPrintCore = _scc_ "PrintCore" noStats dfs (printCore binds) @@ -174,11 +176,12 @@ doCorePass dfs rb us binds (CoreDoRuleCheck phase pat) doCorePass dfs rb us binds CoreDoNothing = noStats dfs (return binds) -strictAnal dfs binds = do #ifdef OLD_STRICTNESS - binds <- saBinds dfs binds +doOldStrictness dfs binds + = do binds1 <- saBinds dfs binds + binds2 <- cprAnalyse dfs binds1 + return binds2 #endif - dmdAnalPgm dfs binds printCore binds = do dumpIfSet True "Print Core" (pprCoreBindings binds) diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 79ebf09..5cae204 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -248,8 +248,15 @@ simplTopBinds env binds drop_bs (NonRec _ _) (_ : bs) = bs drop_bs (Rec prs) bs = drop (length prs) bs - simpl_bind env (NonRec b r) (b':_) = simplRecOrTopPair env TopLevel b b' r - simpl_bind env (Rec pairs) bs' = simplRecBind env TopLevel pairs bs' + simpl_bind env bind bs + = getDOptsSmpl `thenSmpl` \ dflags -> + if dopt Opt_D_dump_inlinings dflags then + pprTrace "SimplBind" (ppr (bindersOf bind)) $ simpl_bind1 env bind bs + else + simpl_bind1 env bind bs + + simpl_bind1 env (NonRec b r) (b':_) = simplRecOrTopPair env TopLevel b b' r + simpl_bind1 env (Rec pairs) bs' = simplRecBind env TopLevel pairs bs' \end{code} diff --git a/ghc/compiler/stranal/DmdAnal.lhs b/ghc/compiler/stranal/DmdAnal.lhs index a36ebbc..5320305 100644 --- a/ghc/compiler/stranal/DmdAnal.lhs +++ b/ghc/compiler/stranal/DmdAnal.lhs @@ -738,9 +738,6 @@ extendSigsWithLam sigs id Just (Eval (Prod ds)) -> extendVarEnv sigs id (cprSig, NotTopLevel) other -> sigs -cprSig :: StrictSig -cprSig = StrictSig (mkDmdType emptyVarEnv [] RetCPR) - dmdTransform :: SigEnv -- The strictness environment -> Id -- The function