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

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

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

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

    Recover [CPR for sum types] (slightly differently)


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

f9d4d761dd01e83fd80a83460cf25b75c7c6f8ed
 compiler/basicTypes/Demand.lhs |   24 ++++++++----------------
 compiler/stranal/DmdAnal.lhs   |   14 ++++++++------
 2 files changed, 16 insertions(+), 22 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index c193c18..d129a9a 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -30,10 +30,9 @@ module Demand (
         isBotRes, isTopRes, getDmdResult, resTypeArgDmd,
         topRes, botRes, cprConRes, vanillaCprConRes,
         appIsBottom, isBottomingSig, pprIfaceStrictSig, 
-        trimCPRInfo, returnsCPR, returnsCPR_maybe,
+        returnsCPR, returnsCPR_maybe, forgetCPR,
         StrictSig(..), mkStrictSig, mkClosedStrictSig, nopSig, botSig, cprProdSig,
         isNopSig, splitStrictSig, increaseStrictSigArity,
-
         seqDemand, seqDemandList, seqDmdType, seqStrictSig, 
 
         evalDmd, cleanEvalDmd, cleanEvalProdDmd, isStrictDmd, 
@@ -826,6 +825,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 -> [DmdResult] -> DmdResult
 cprConRes tag arg_ress
   | opt_CprOff = topRes
@@ -844,20 +850,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 0da1085..ea1a588 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -655,9 +655,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]
@@ -667,9 +668,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)