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

[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/fb9b3ab9f9db118bf14bab3e48bbf66638fa8426/ghc

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

commit fb9b3ab9f9db118bf14bab3e48bbf66638fa8426
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


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

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

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index ead28e3..6fd8076 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -807,19 +807,29 @@ getDmdResult _                = topRes
 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 e.g. the
 -- DmdResult of repeat
+--
 -- So we need to forget information at a certain depth. We do that at all points
 -- where we are building RetCon 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 0 _               = NoCPR
+cutCPRResult _ NoCPR           = NoCPR
 cutCPRResult n (RetCon tag rs) = RetCon tag (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)
+
 
 -- Forget that something might converge for sure
 divergeDmdResult :: DmdResult -> DmdResult
@@ -834,8 +844,9 @@ forgetCPR (Dunno _) = Dunno NoCPR
 
 cprConRes :: ConTag -> [DmdResult] -> DmdResult
 cprConRes tag arg_ress
-  | opt_CprOff = topRes
-  | otherwise  = Converges $ cutCPRResult maxCPRDepth $ RetCon tag arg_ress
+  | opt_CprOff       = topRes
+  | opt_NestedCprOff = Converges $ cutCPRResult flatCPRDepth $ RetCon tag arg_ress
+  | otherwise        = Converges $ cutCPRResult maxCPRDepth  $ RetCon tag arg_ress
 
 vanillaCprConRes :: ConTag -> Arity -> DmdResult
 vanillaCprConRes tag arity
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")