[commit: ghc] wip/nested-cpr: Recover [CPR for sum types] (slightly differently) (7279cbc)

[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/7279cbc4869fcf179863694b4edb65b19e4c7d5b/ghc

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

commit 7279cbc4869fcf179863694b4edb65b19e4c7d5b
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Thu Nov 28 11:17:16 2013 +0000

    Recover [CPR for sum types] (slightly differently)


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

7279cbc4869fcf179863694b4edb65b19e4c7d5b
 compiler/basicTypes/Demand.lhs |   24 +++++++++---------------
 compiler/stranal/DmdAnal.lhs   |   14 ++++++++------
 2 files changed, 17 insertions(+), 21 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index 66ea620..9811882 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -29,7 +29,8 @@ module Demand (
         isBotRes, isTopRes, resTypeArgDmd, 
         topRes, botRes, cprConRes, vanillaCprConRes,
         appIsBottom, isBottomingSig, pprIfaceStrictSig, 
-        trimCPRInfo, returnsCPR, returnsCPR_maybe,
+        returnsCPR, returnsCPR_maybe,
+        forgetCPR,
         StrictSig(..), mkStrictSig, topSig, botSig, cprProdSig,
         isTopSig, splitStrictSig, increaseStrictSigArity,
        
@@ -817,6 +818,13 @@ cutCPRResult :: Int -> CPRResult -> CPRResult
 cutCPRResult _ NoCPR = NoCPR
 cutCPRResult n (RetCon tag rs) = RetCon tag (map (cutDmdResult (n-1)) rs)
 
+-- Forget the CPR information, but remember if it converges or diverges
+-- Used for non-strict thunks and non-top-level things with sum type
+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
@@ -839,20 +847,6 @@ isBotRes :: DmdResult -> Bool
 isBotRes Diverges = True
 isBotRes _        = False
 
--- TODO: This currently ignores trim_sums. Evaluate if still required, and fix
--- Note [CPR for sum types]
-trimCPRInfo :: Bool -> Bool -> DmdResult -> DmdResult
-trimCPRInfo trim_all _trim_sums res
-  = trimR res
-  where
-    trimR (Converges c) = Converges (trimC c)
-    trimR (Dunno c)     = Dunno (trimC c)
-    trimR Diverges      = Diverges
-
-    trimC (RetCon n rs) | trim_all = NoCPR
-                        | otherwise             = RetCon n (map trimR rs)
-    trimC NoCPR = NoCPR
-
 returnsCPR :: DmdResult -> Bool
 returnsCPR dr = isJust (returnsCPR_maybe dr)
 
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index ba015bf..9239a64 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -643,9 +643,10 @@ dmdAnalRhs top_lvl rec_flag env id rhs
 	-- See Note [NOINLINE and strictness]
 
     -- See Note [Product demands for function body]
-    body_dmd = case deepSplitProductType_maybe (exprType body) of
-                 Nothing            -> cleanEvalDmd
-                 Just (dc, _, _, _) -> cleanEvalProdDmd (dataConRepArity dc)
+    (is_sum_type, body_dmd)
+      = case deepSplitProductType_maybe (exprType body) of
+          Nothing            -> (True, cleanEvalDmd)
+          Just (dc, _, _, _) -> (False, cleanEvalProdDmd (dataConRepArity dc))
 
     -- See Note [Lazy and unleashable free variables]
     -- See Note [Aggregated demand for cardinality]
@@ -655,9 +656,10 @@ dmdAnalRhs top_lvl rec_flag env id rhs
 
     (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv1
 
-    rhs_res'  = trimCPRInfo trim_all trim_sums rhs_res
-    trim_all  = is_thunk && not_strict
-    trim_sums = not (isTopLevel top_lvl) -- See Note [CPR for sum types]
+    -- Note [CPR for sum types]
+    rhs_res' | (is_sum_type && not (isTopLevel top_lvl)) ||
+               (is_thunk && not_strict)                = forgetCPR rhs_res
+             | otherwise                               = rhs_res
 
     -- See Note [CPR for thunks]
     is_thunk = not (exprIsHNF rhs)