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

[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/239303caec2dff515962f25c8b64ad9ca7ece15c/ghc

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

commit 239303caec2dff515962f25c8b64ad9ca7ece15c
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.


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

239303caec2dff515962f25c8b64ad9ca7ece15c
 compiler/basicTypes/Demand.lhs |   28 ++++++++++++++++++++++++++--
 1 file changed, 26 insertions(+), 2 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index bc2d87a..43b0418 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -826,10 +826,33 @@ 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)
+  | otherwise  = Converges $ cutCPRResult maxCPRDepth $ RetProd (replicate arity topRes)
 
 isTopRes :: DmdResult -> Bool
 isTopRes (Dunno NoCPR) = True
@@ -1118,10 +1141,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