[commit: ghc] wip/cpr-vs-jp: After demand analysis of a let, reduce CPR information of the join point (9894024)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/cpr-vs-jp
Link       : http://ghc.haskell.org/trac/ghc/changeset/98940247926c2af1ccdacd18111facebe31d5982/ghc

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

commit 98940247926c2af1ccdacd18111facebe31d5982
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Tue Jan 7 09:51:00 2014 +0000

    After demand analysis of a let, reduce CPR information of the join point
    
    Code needs cleanup. TODO: How to treat the termination information of
    the join point?


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

98940247926c2af1ccdacd18111facebe31d5982
 compiler/basicTypes/Demand.lhs |    2 ++
 compiler/stranal/DmdAnal.lhs   |   16 +++++++++++++++-
 2 files changed, 17 insertions(+), 1 deletion(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index d408e6d..c25ff71 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -10,6 +10,8 @@ module Demand (
         StrDmd, UseDmd(..), Count(..), 
         countOnce, countMany,   -- cardinality
 
+        JointDmd(..), MaybeUsed(..), lubDmdResult, -- temporary hack
+
         Demand, CleanDemand, 
         mkProdDmd, mkOnceUsedDmd, mkManyUsedDmd, mkHeadStrict, oneifyDmd,
         getUsage, toCleanDmd, 
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index 11a60c7..8a6e9ee 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -283,7 +283,7 @@ dmdAnal env dmd (Case scrut case_bndr ty alts)
     (res_ty, Case scrut' case_bndr' ty alts')
 
 dmdAnal env dmd (Let (NonRec id rhs) body)
-  = (body_ty2, Let (NonRec id2 annotated_rhs) body')                    
+  = (body_ty2, Let (NonRec id3 annotated_rhs) body')
   where
     (sig, lazy_fv, id1, rhs') = dmdAnalRhs NotTopLevel Nothing env id rhs
     (body_ty, body') 	      = dmdAnal (extendAnalEnv NotTopLevel env id sig) dmd body
@@ -294,6 +294,20 @@ dmdAnal env dmd (Let (NonRec id rhs) body)
     -- See Note [Annotating lambdas at right-hand side] 
     annotated_rhs = annLamWithShotness (idDemandInfo id2) rhs'   
 
+    -- If var is a joint point for the expression of which dmd_ty is the demand
+    -- type, then restrict var's CPR property to that in dmd_ty
+    -- Of course, this implementation is a HACK!
+    id3 | isJoinPointOf id body = setIdStrictness id2 $
+           case (idStrictness id2, body_ty) of
+            (StrictSig (DmdType fv args r1), DmdType _ _ r2) ->
+                (\x ->
+                    if r1 /= r2
+                    then pprTrace "cpr-join-point-fix" (vcat [ppr (idDemandInfo id2), ppr body_ty, ppr (idStrictness id2), ppr x]) x
+                    else x) $
+                -- TODO: What about a bottoming result?
+                StrictSig (DmdType fv args (r1 `lubDmdResult` r2))
+        | otherwise = id2
+
 	-- If the actual demand is better than the vanilla call
 	-- demand, you might think that we might do better to re-analyse 
 	-- the RHS with the stronger demand.