[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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 cd4f1fb..1948933 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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