[commit: ghc] wip/nested-cpr: Add a flag -fnested-cpr-off to conveniently test the effect of nested CPR (346b7e5)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/nested-cpr
Link       : http://ghc.haskell.org/trac/ghc/changeset/346b7e540413b90bfa8378cd061b3a47e2970ee9/ghc

>---------------------------------------------------------------

commit 346b7e540413b90bfa8378cd061b3a47e2970ee9
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Wed Dec 4 09:14:26 2013 +0000

    Add a flag -fnested-cpr-off to conveniently test the effect of nested CPR


>---------------------------------------------------------------

346b7e540413b90bfa8378cd061b3a47e2970ee9
 compiler/basicTypes/Demand.lhs |   27 ++++++++++++++++++---------
 compiler/main/StaticFlags.hs   |    9 +++++++--
 2 files changed, 25 insertions(+), 11 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index 2ef2a6d..b050e79 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -814,6 +814,7 @@ cprSumRes tag | opt_CprOff = topRes
 cprProdRes :: [DmdResult] -> DmdResult
 cprProdRes arg_ress
   | opt_CprOff        = topRes
+  | opt_NestedCprOff  = Converges $ cutCPRResult flatCPRDepth $ RetProd arg_ress
   | otherwise         = Converges $ cutCPRResult maxCPRDepth  $ RetProd arg_ress
 
 getDmdResult :: DmdType -> DmdResult
@@ -827,6 +828,13 @@ divergeDmdResult r = r `lubDmdResult` botRes
 maxCPRDepth :: Int
 maxCPRDepth = 3
 
+-- This is the depth we use with -fnested-cpr-off, in order
+-- to get precisely the same behaviour as before introduction of nested cpr
+-- -fnested-cpr-off can eventually be removed if nested cpr is deemd to be
+-- a good thing always.
+flatCPRDepth :: Int
+flatCPRDepth = 1
+
 -- With nested CPR, DmdResult can be arbitrarily deep; consider
 -- data Rec1 = Foo Rec2 Rec2
 -- data Rec2 = Bar Rec1 Rec1
@@ -836,16 +844,17 @@ maxCPRDepth = 3
 --
 -- So we need to forget information at a certain depth. We do that at all points
 -- where we are constructing new RetProd constructors.
-cutDmdResult :: Int -> DmdResult -> DmdResult
-cutDmdResult 0 _ = topRes
-cutDmdResult _ Diverges = Diverges
-cutDmdResult n (Converges c) = Converges (cutCPRResult n c)
-cutDmdResult n (Dunno c) = Dunno (cutCPRResult n c)
-
 cutCPRResult :: Int -> CPRResult -> CPRResult
-cutCPRResult _ NoCPR = NoCPR
-cutCPRResult n (RetProd rs) = RetProd (map (cutDmdResult (n-1)) rs)
-cutCPRResult _ (RetSum tag) = RetSum tag
+cutCPRResult 0 _               = NoCPR
+cutCPRResult _ NoCPR           = NoCPR
+cutCPRResult _ (RetSum tag)    = RetSum tag
+cutCPRResult n (RetProd rs)    = RetProd (map (cutDmdResult (n-1)) rs)
+  where
+    cutDmdResult :: Int -> DmdResult -> DmdResult
+    cutDmdResult 0 _             = topRes
+    cutDmdResult _ Diverges      = Diverges
+    cutDmdResult n (Converges c) = Converges (cutCPRResult n c)
+    cutDmdResult n (Dunno c)     = Dunno     (cutCPRResult n c)
 
 vanillaCprProdRes :: Arity -> DmdResult
 vanillaCprProdRes arity = cprProdRes (replicate arity topRes)
diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs
index 01dc3b7..feb7235 100644
--- a/compiler/main/StaticFlags.hs
+++ b/compiler/main/StaticFlags.hs
@@ -27,6 +27,7 @@ module StaticFlags (
         -- optimisation opts
         opt_NoStateHack,
         opt_CprOff,
+        opt_NestedCprOff,
         opt_NoOptCoercion,
 
         -- For the parser
@@ -140,7 +141,8 @@ flagsStaticNames :: [String]
 flagsStaticNames = [
     "fno-state-hack",
     "fno-opt-coercion",
-    "fcpr-off"
+    "fcpr-off",
+    "fnested-cpr-off"
     ]
 
 -- We specifically need to discard static flags for clients of the
@@ -195,10 +197,13 @@ opt_NoDebugOutput  = lookUp  (fsLit "-dno-debug-output")
 opt_NoStateHack    :: Bool
 opt_NoStateHack    = lookUp  (fsLit "-fno-state-hack")
 
--- Switch off CPR analysis in the new demand analyser
+-- Switch off CPR analysis in the demand analyser
 opt_CprOff         :: Bool
 opt_CprOff         = lookUp  (fsLit "-fcpr-off")
 
+opt_NestedCprOff   :: Bool
+opt_NestedCprOff   = lookUp  (fsLit "-fnested-cpr-off")
+
 opt_NoOptCoercion  :: Bool
 opt_NoOptCoercion  = lookUp  (fsLit "-fno-opt-coercion")