[commit: ghc] wip/nested-cpr: Revert "No need to limit the depth of DmdResult any more" (70edc7a)

[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/70edc7acc0484f2cf0c9a92aadfce80741fdef79/ghc

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

commit 70edc7acc0484f2cf0c9a92aadfce80741fdef79
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Thu Nov 28 17:45:20 2013 +0000

    Revert "No need to limit the depth of DmdResult any more"
    
    This reverts commit b4ccb37795f3f1e818fef7b691caca1116f676d6.


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

70edc7acc0484f2cf0c9a92aadfce80741fdef79
 compiler/basicTypes/Demand.lhs |   22 ++++++++++++++++++++--
 1 file changed, 20 insertions(+), 2 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index 2dbb045..fbb5ae3 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -811,10 +811,28 @@ topRes, botRes :: DmdResult
 topRes = Dunno NoCPR
 botRes = Diverges
 
+maxCPRDepth :: Int
+maxCPRDepth = 3
+
+-- 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 n (RetCon tag rs) = RetCon tag (map (cutDmdResult (n-1)) rs)
+
 cprConRes :: ConTag -> [DmdType] -> CPRResult
 cprConRes tag arg_tys
   | opt_CprOff = NoCPR
-  | otherwise  = 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!
@@ -823,7 +841,7 @@ cprConRes tag arg_tys
 vanillaCprConRes :: ConTag -> Arity -> CPRResult
 vanillaCprConRes tag arity
   | opt_CprOff = NoCPR
-  | otherwise  = RetCon tag (replicate arity topRes)
+  | otherwise  = cutCPRResult maxCPRDepth $ RetCon tag (replicate arity topRes)
 
 isTopRes :: DmdResult -> Bool
 isTopRes (Dunno NoCPR) = True