[commit: ghc] wip/nested-cpr: Limit the depth of the CPR information (1810fe5)

[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/1810fe5660c72e15ea35886d10a14bc2c095915c/ghc

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

commit 1810fe5660c72e15ea35886d10a14bc2c095915c
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Thu Dec 5 16:13:41 2013 +0000

    Limit the depth of the CPR information
    
    as otherwise, it could become infinite.


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

1810fe5660c72e15ea35886d10a14bc2c095915c
 compiler/basicTypes/Demand.lhs |   34 ++++++++++++++++++++++++++++------
 1 file changed, 28 insertions(+), 6 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index 8411356..668dd55 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -813,8 +813,8 @@ cprSumRes tag | opt_CprOff = topRes
 
 cprProdRes :: [DmdResult] -> DmdResult
 cprProdRes arg_ress
-  | opt_CprOff = topRes
-  | otherwise  = Converges $ RetProd arg_ress
+  | opt_CprOff        = topRes
+  | otherwise         = Converges $ cutCPRResult maxCPRDepth  $ RetProd arg_ress
 
 getDmdResult :: DmdType -> DmdResult
 getDmdResult (DmdType _ [] r) = r       -- Only for data-typed arguments!
@@ -824,10 +824,31 @@ getDmdResult _                = topRes
 divergeDmdResult :: DmdResult -> DmdResult
 divergeDmdResult r = r `lubDmdResult` botRes
 
+maxCPRDepth :: Int
+maxCPRDepth = 3
+
+-- With nested CPR, DmdResult can be arbitrarily deep; consider
+-- data Rec1 = Foo Rec2 Rec2
+-- data Rec2 = Bar Rec1 Rec1
+--
+-- x = Foo y y
+-- y = Bar x x
+--
+-- 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
+
 vanillaCprProdRes :: Arity -> DmdResult
-vanillaCprProdRes arity
-  | opt_CprOff = topRes
-  | otherwise  = Converges $ RetProd (replicate arity topRes)
+vanillaCprProdRes arity = cprProdRes (replicate arity topRes)
 
 isTopRes :: DmdResult -> Bool
 isTopRes (Dunno NoCPR) = True
@@ -1097,10 +1118,11 @@ bothDmdType (DmdType fv1 ds1 r1) (fv2, t2)
 instance Outputable DmdType where
   ppr (DmdType fv ds res) 
     = hsep [text "DmdType",
-            hcat (map ppr ds) <> ppr res,
+            hcat (map ppr ds) <> ppr_res,
             if null fv_elts then empty
             else braces (fsep (map pp_elt fv_elts))]
     where
+      ppr_res = if isTopRes res then empty else ppr res
       pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd
       fv_elts = ufmToList fv