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

[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/90529b15c02ef03dcece13c267b76d470941b808/ghc

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

commit 90529b15c02ef03dcece13c267b76d470941b808
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


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

90529b15c02ef03dcece13c267b76d470941b808
 compiler/basicTypes/Demand.lhs |   28 +++++++++++++++++++---------
 compiler/main/StaticFlags.hs   |    9 +++++++--
 2 files changed, 26 insertions(+), 11 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index 557a9bd..e955195 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -791,20 +791,29 @@ botRes = Diverges
 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
@@ -819,8 +828,9 @@ forgetCPR (Dunno _) = Dunno NoCPR
 
 cprConRes :: ConTag -> [DmdType] -> CPRResult
 cprConRes tag arg_tys
-  | opt_CprOff = NoCPR
-  | otherwise  = cutCPRResult maxCPRDepth $ RetCon tag (map get_res arg_tys)
+  | opt_CprOff       = NoCPR
+  | opt_NestedCprOff = cutCPRResult flatCPRDepth $ RetCon tag (map get_res arg_tys)
+  | otherwise        = cutCPRResult maxCPRDepth  $ RetCon tag (map get_res arg_tys)
   where
     get_res :: DmdType -> DmdResult
     get_res (DmdType _ [] r) = r       -- Only for data-typed arguments!
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")