[commit: ghc] wip/nested-cpr: Loop breakers are not allowed to have a Converges DmdResult (de6762f)

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

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

commit de6762f69a9a226fa77e875ad0cbff74ccf71a8e
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Tue Nov 26 10:18:35 2013 +0000

    Loop breakers are not allowed to have a Converges DmdResult


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

de6762f69a9a226fa77e875ad0cbff74ccf71a8e
 compiler/basicTypes/Demand.lhs |   19 +++++++++++--------
 compiler/stranal/DmdAnal.lhs   |    5 ++++-
 2 files changed, 15 insertions(+), 9 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index 0a8c9ff..ead28e3 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -33,6 +33,7 @@ module Demand (
         returnsCPR, returnsCPR_maybe, forgetCPR,
         StrictSig(..), mkStrictSig, mkClosedStrictSig, nopSig, botSig, cprProdSig,
         isNopSig, splitStrictSig, increaseStrictSigArity,
+        sigMayConverge,
         seqDemand, seqDemandList, seqDmdType, seqStrictSig, 
 
         evalDmd, cleanEvalDmd, cleanEvalProdDmd, isStrictDmd, 
@@ -806,15 +807,10 @@ getDmdResult _                = topRes
 maxCPRDepth :: Int
 maxCPRDepth = 3
 
--- With nested CPR, DmdResult can be arbitrarily deep; consider
--- data Rec1 = Foo Rec2 Rec2
--- data Rec2 = Bar Rec1 Rec1
--- 
--- x = Foo y y
--- y = Bar x x
--- 
+-- With nested CPR, DmdResult can be arbitrarily deep; consider e.g. the
+-- DmdResult of repeat
 -- So we need to forget information at a certain depth. We do that at all points
--- where we are constructing new RetCon constructors.
+-- where we are building RetCon constructors.
 cutDmdResult :: Int -> DmdResult -> DmdResult
 cutDmdResult 0 _ = topRes
 cutDmdResult _ Diverges = Diverges
@@ -825,6 +821,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
+
 -- 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
@@ -1445,6 +1445,9 @@ 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)))
+
 argsOneShots :: StrictSig -> Arity -> [[OneShotInfo]]
 argsOneShots (StrictSig (DmdType _ arg_ds _)) n_val_args
   = go arg_ds
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index ea1a588..d5bf8a0 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -1084,7 +1084,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)