[commit: ghc] wip/nested-cpr: Do not remove the demand on arguments without updating the result type (f90dcd6)

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

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

commit f90dcd6ad99cb6158a4bb18e4ac8fcd68d0a5263
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Tue Jan 21 12:01:44 2014 +0000

    Do not remove the demand on arguments without updating the result type
    
    The CPR and termination information of a strictness signature depends on
    the number arguments. If the latter is changed, e.g. in dmdAnalRHS, the
    former needs to be adjusted.


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

f90dcd6ad99cb6158a4bb18e4ac8fcd68d0a5263
 compiler/basicTypes/Demand.lhs |   13 ++++++++++---
 compiler/stranal/DmdAnal.lhs   |   16 ++++++++++++----
 2 files changed, 22 insertions(+), 7 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index b81f7d0..e4cfe3e 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -27,7 +27,7 @@ module Demand (
         peelFV,
 
         DmdResult, CPRResult,
-        isBotRes, isTopRes, getDmdResult, resTypeArgDmd,
+        isBotRes, isTopRes, getDmdResult, removeArgs, resTypeArgDmd,
         topRes, convRes, botRes,
         splitNestedRes,
         appIsBottom, isBottomingSig, pprIfaceStrictSig,
@@ -814,8 +814,15 @@ cprProdRes :: Int -> [DmdResult] -> DmdResult
 cprProdRes depth arg_ress = cutDmdResult depth $ Converges $ RetProd arg_ress
 
 getDmdResult :: DmdType -> DmdResult
-getDmdResult (DmdType _ [] r) = r       -- Only for data-typed arguments!
-getDmdResult _                = topRes
+getDmdResult (DmdType _ [] r)            = r       -- Only for data-typed arguments!
+getDmdResult (DmdType _ _ (Converges _)) = convRes -- Convergence is retained
+getDmdResult _                           = topRes  -- Other CPR information is invalid now
+
+-- This removes the arguments from a demand signature,
+-- e.g. in dmdAnalRhs, where a function value should not be
+-- exported. If it is removing arguments, zap the CPR information!
+removeArgs :: DmdType -> DmdType
+removeArgs d@(DmdType fv _ _) = (DmdType fv [] (getDmdResult d))
 
 -- Forget that something might converge for sure
 divergeDmdResult :: DmdResult -> DmdResult
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index 67c4a31..cf372ca 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -692,13 +692,21 @@ dmdAnalRhs top_lvl rec_flag env var rhs
   = (fn_str, emptyDmdEnv, set_idStrictness env var fn_str, rhs)
 
   | otherwise
-  = (sig_ty, lazy_fv, var', mkLams bndrs' body')
+  = -- pprTrace "dmdAnalRhs" (vcat [ text "body_ty"  <+> ppr body_ty
+    --                             , text "body_ty'" <+> ppr body_ty'
+    --                             , text "sig_ty"   <+> ppr sig_ty
+    --                             ]) $
+    (sig_ty, lazy_fv, var', mkLams bndrs' body')
   where
     (bndrs, body)        = collectBinders rhs
     env_body             = foldl extendSigsWithLam env bndrs
-    (DmdType body_fv _      body_res, body')  = dmdAnal env_body body_dmd body
-    (DmdType rhs_fv rhs_dmds rhs_res, bndrs') = annotateLamBndrs env (isDFunId var)
-                                                  (DmdType body_fv [] body_res) bndrs
+    (body_ty, body')     = dmdAnal env_body body_dmd body
+    body_ty'             = removeArgs body_ty
+                           -- ^ we do not want to expose a function demand type
+                           -- that does not come from top-level lambdas
+    (DmdType rhs_fv rhs_dmds rhs_res, bndrs')
+                         = annotateLamBndrs env (isDFunId var) body_ty' bndrs
+
     sig_ty               = mkStrictSig $
                            mkDmdType sig_fv rhs_dmds $
                                 handle_sum_cpr $