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

[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/48a9118394e69e9113ee2967a7c69ef64c42a59a/ghc

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

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

    Recover [CPR for sum types] (slightly differently)


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

48a9118394e69e9113ee2967a7c69ef64c42a59a
 compiler/basicTypes/Demand.lhs |   16 +---------------
 compiler/stranal/DmdAnal.lhs   |   13 +++++++------
 2 files changed, 8 insertions(+), 21 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index b3fe942..7eda769 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -28,7 +28,7 @@ module Demand (
         isBotRes, isTopRes, resTypeArgDmd, 
         topRes, botRes, cprConRes, vanillaCprConRes,
         appIsBottom, isBottomingSig, pprIfaceStrictSig, 
-        trimCPRInfo, returnsCPR, returnsCPR_maybe,
+        returnsCPR, returnsCPR_maybe,
         StrictSig(..), mkStrictSig, topSig, botSig, cprProdSig,
         isTopSig, splitStrictSig, increaseStrictSigArity,
         sigMayConverge,
@@ -831,20 +831,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 False dr)
 
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index 0f18ea9..28fb5f3 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -652,9 +652,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]
@@ -664,9 +665,9 @@ 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 || (is_thunk && not_strict) = topRes
+             | otherwise                               = rhs_res
         
     -- See Note [CPR for thunks]
     is_thunk = not (exprIsHNF rhs)