summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ghc/compiler/basicTypes/IdInfo.lhs2
-rw-r--r--ghc/compiler/basicTypes/MkId.lhs4
-rw-r--r--ghc/compiler/basicTypes/NewDemand.lhs19
-rw-r--r--ghc/compiler/main/BinIface.hs2
-rw-r--r--ghc/compiler/main/CmdLineOpts.lhs8
-rw-r--r--ghc/compiler/main/DriverFlags.hs5
-rw-r--r--ghc/compiler/main/DriverState.hs10
-rw-r--r--ghc/compiler/simplCore/SimplCore.lhs17
-rw-r--r--ghc/compiler/simplCore/Simplify.lhs11
-rw-r--r--ghc/compiler/stranal/DmdAnal.lhs3
10 files changed, 49 insertions, 32 deletions
diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs
index 2dc8b42f27..6a7ff62433 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 adcd06b253..ee92ad1afd 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 cafd67c8f5..9da7b7e928 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 799ce15c39..611bd5315b 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 3e0f33a13a..94dd35464d 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 6a6a744c2e..2ebd51dc29 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-<blah>" options cancel out "-f<blah>" on the hsc cmdline
diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs
index cd4f1fbed3..194893336f 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 facff06579..d5cb99a555 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 79ebf09a55..5cae204ae7 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 a36ebbccd0..5320305235 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
View Lorry Controller Status