[commit: ghc] wip/nested-cpr: Revert "Forget DmdResult information within recursive calls" (3bd2eb6)

[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/3bd2eb6e8ba7808ca61324fc517006152c0352f0/ghc

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

commit 3bd2eb6e8ba7808ca61324fc517006152c0352f0
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Thu Nov 28 17:45:24 2013 +0000

    Revert "Forget DmdResult information within recursive calls"
    
    This reverts commit a15bc77360da1923467b419ed67f99a5917d5633.


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

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

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index fbb5ae3..561a43f 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -31,7 +31,7 @@ module Demand (
         returnsCPR, returnsCPR_maybe,
         StrictSig(..), mkStrictSig, topSig, botSig, cprProdSig,
         isTopSig, splitStrictSig, increaseStrictSigArity,
-        sigForgetCPR,
+        sigMayConverge,
        
         seqDemand, seqDemandList, seqDmdType, seqStrictSig, 
 
@@ -829,6 +829,10 @@ 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
@@ -1332,8 +1336,8 @@ botSig = StrictSig botDmdType
 cprProdSig :: Arity -> StrictSig
 cprProdSig arity = StrictSig (cprProdDmdType arity)
 
-sigForgetCPR :: StrictSig -> StrictSig
-sigForgetCPR (StrictSig (DmdType env ds _)) = (StrictSig (DmdType env ds topRes))
+sigMayConverge :: StrictSig -> StrictSig
+sigMayConverge (StrictSig (DmdType env ds res)) = (StrictSig (DmdType env ds (divergeDmdResult res)))
 
 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 1855706..2426377 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -613,8 +613,7 @@ dmdFix top_lvl env orig_pairs
         my_downRhs (env, lazy_fv) (id,rhs)
           = ((env', lazy_fv'), (id', rhs'))
           where
-              -- See Note [Forgetting CPR information in recursive calls]
-	    (sig, lazy_fv1, id', rhs') = dmdAnalRhs top_lvl (Just bndrs) (safeRecursiveSigs env bndrs) id rhs
+	    (sig, lazy_fv1, id', rhs') = dmdAnalRhs top_lvl (Just bndrs) env id rhs
 	    lazy_fv'		       = plusVarEnv_C bothDmd lazy_fv lazy_fv1
             env'                       = extendAnalEnv top_lvl env id sig
 	   
@@ -1098,7 +1097,10 @@ 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 }
+  = env { ae_sigs = extendSigEnv top_lvl (ae_sigs env) var sig' }
+  where
+  sig' | isWeakLoopBreaker (idOccInfo var) = sigMayConverge sig
+       | otherwise                         = sig
 
 extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv
 extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl)
@@ -1112,15 +1114,6 @@ 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
@@ -1214,8 +1207,3 @@ 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 )