[commit: ghc] wip/nested-cpr: Forget DmdResult information within recursive calls (a15bc77)

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

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

commit a15bc77360da1923467b419ed67f99a5917d5633
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Thu Nov 28 09:33:33 2013 +0000

    Forget DmdResult information within recursive calls


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

a15bc77360da1923467b419ed67f99a5917d5633
 compiler/basicTypes/Demand.lhs |   10 +++-------
 compiler/stranal/DmdAnal.lhs   |   22 +++++++++++++++++-----
 2 files changed, 20 insertions(+), 12 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index be6058d..92bbf2b 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -30,7 +30,7 @@ module Demand (
         trimCPRInfo, returnsCPR, returnsCPR_maybe,
         StrictSig(..), mkStrictSig, topSig, botSig, cprProdSig,
         isTopSig, splitStrictSig, increaseStrictSigArity,
-        sigMayConverge,
+        sigForgetCPR,
        
         seqDemand, seqDemandList, seqDmdType, seqStrictSig, 
 
@@ -828,10 +828,6 @@ cutCPRResult :: Int -> CPRResult -> CPRResult
 cutCPRResult _ NoCPR = NoCPR
 cutCPRResult n (RetCon tag rs) = RetCon tag (map (cutDmdResult (n-1)) rs)
 
--- Forget that something might converge for sure
-divergeDmdResult :: DmdResult -> DmdResult
-divergeDmdResult r = r `lubDmdResult` botRes
-
 cprConRes :: ConTag -> [DmdType] -> CPRResult
 cprConRes tag arg_tys
   | opt_CprOff = NoCPR
@@ -1346,8 +1342,8 @@ botSig = StrictSig botDmdType
 cprProdSig :: Arity -> StrictSig
 cprProdSig arity = StrictSig (cprProdDmdType arity)
 
-sigMayConverge :: StrictSig -> StrictSig
-sigMayConverge (StrictSig (DmdType env ds res)) = (StrictSig (DmdType env ds (divergeDmdResult res)))
+sigForgetCPR :: StrictSig -> StrictSig
+sigForgetCPR (StrictSig (DmdType env ds _)) = (StrictSig (DmdType env ds topRes))
 
 argsOneShots :: StrictSig -> Arity -> [[Bool]]
 argsOneShots (StrictSig (DmdType _ arg_ds _)) n_val_args
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index 59018ac..6aba874 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -611,7 +611,8 @@ dmdFix top_lvl env orig_pairs
         my_downRhs (env, lazy_fv) (id,rhs)
           = ((env', lazy_fv'), (id', rhs'))
           where
-	    (sig, lazy_fv1, id', rhs') = dmdAnalRhs top_lvl (Just bndrs) env id rhs
+              -- See Note [Forgetting CPR information in recursive calls]
+	    (sig, lazy_fv1, id', rhs') = dmdAnalRhs top_lvl (Just bndrs) (safeRecursiveSigs env bndrs) id rhs
 	    lazy_fv'		       = plusVarEnv_C bothDmd lazy_fv lazy_fv1
             env'                       = extendAnalEnv top_lvl env id sig
 
@@ -1094,10 +1095,7 @@ updSigEnv env sigs = env { ae_sigs = sigs }
 
 extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> StrictSig -> AnalEnv
 extendAnalEnv top_lvl env var sig
-  = env { ae_sigs = extendSigEnv top_lvl (ae_sigs env) var sig' }
-  where
-  sig' | isWeakLoopBreaker (idOccInfo var) = sigMayConverge sig
-       | otherwise                         = sig
+  = env { ae_sigs = extendSigEnv top_lvl (ae_sigs env) var sig }
 
 extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv
 extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl)
@@ -1111,6 +1109,15 @@ getStrictness env fn
   | Just (sig, _) <- lookupSigEnv env fn = sig
   | otherwise                            = topSig
 
+safeRecursiveSigs :: AnalEnv -> [Id] -> AnalEnv
+-- Note [Forgetting CPR information in recursive calls]
+safeRecursiveSigs env ids = foldr go env ids
+  where
+  go id env = case lookupVarEnv (sigEnv env) id of
+        Just (sig, top_lvl) -> extendAnalEnv top_lvl env id (sigForgetCPR sig)
+        Nothing -> panic "safeRecursiveSigs"
+
+
 addInitialSigs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv
 -- See Note [Initialising strictness]
 addInitialSigs top_lvl env@(AE { ae_sigs = sigs, ae_virgin = virgin }) ids
@@ -1204,3 +1211,8 @@ of the Id, and start from "bottom".  Nowadays the Id can have a current
 strictness, because interface files record strictness for nested bindings.
 To know when we are in the first iteration, we look at the ae_virgin
 field of the AnalEnv.
+
+
+Note [Forgetting CPR information in recursive calls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+TODO: (take from http://www.haskell.org/pipermail/ghc-devs/2013-November/003356.html )