[commit: ghc] wip/nested-cpr: Do not forget about Divergence of thunks (f523007)

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

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

commit f5230074a530f12d3665f9c3e66fda6248574c4a
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Fri Nov 29 12:47:34 2013 +0000

    Do not forget about Divergence of thunks


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

f5230074a530f12d3665f9c3e66fda6248574c4a
 compiler/basicTypes/Demand.lhs |    8 ++++++++
 compiler/stranal/DmdAnal.lhs   |    2 +-
 2 files changed, 9 insertions(+), 1 deletion(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index 7eda769..557a9bd 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -29,6 +29,7 @@ module Demand (
         topRes, botRes, cprConRes, vanillaCprConRes,
         appIsBottom, isBottomingSig, pprIfaceStrictSig, 
         returnsCPR, returnsCPR_maybe,
+        forgetCPR,
         StrictSig(..), mkStrictSig, topSig, botSig, cprProdSig,
         isTopSig, splitStrictSig, increaseStrictSigArity,
         sigMayConverge,
@@ -809,6 +810,13 @@ cutCPRResult n (RetCon tag rs) = RetCon tag (map (cutDmdResult (n-1)) rs)
 divergeDmdResult :: DmdResult -> DmdResult
 divergeDmdResult r = r `lubDmdResult` botRes
 
+-- Forget the CPR information, but remember if it converges or diverges
+-- Used for non-strict thunks
+forgetCPR :: DmdResult -> DmdResult
+forgetCPR Diverges = Diverges
+forgetCPR (Converges _) = Converges NoCPR
+forgetCPR (Dunno _) = Dunno NoCPR
+
 cprConRes :: ConTag -> [DmdType] -> CPRResult
 cprConRes tag arg_tys
   | opt_CprOff = NoCPR
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index 28fb5f3..2da9991 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -666,7 +666,7 @@ dmdAnalRhs top_lvl rec_flag env id rhs
     (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv1
 
     -- Note [CPR for sum types]
-    rhs_res' | is_sum_type || (is_thunk && not_strict) = topRes
+    rhs_res' | is_sum_type || (is_thunk && not_strict) = forgetCPR rhs_res
              | otherwise                               = rhs_res
         
     -- See Note [CPR for thunks]