[commit: ghc] wip/cbv-conv-thunk: Loop breakers are not allowed to have a Converges DmdResult (fca15ac)

[git at git.haskell.org]

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

On branch  : wip/cbv-conv-thunk
Link       : http://ghc.haskell.org/trac/ghc/changeset/fca15ac53af8308608a44d6e7b9faaff1cf30d70/ghc

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

commit fca15ac53af8308608a44d6e7b9faaff1cf30d70
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


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

fca15ac53af8308608a44d6e7b9faaff1cf30d70
 compiler/basicTypes/Demand.lhs |    8 ++++++++
 compiler/stranal/DmdAnal.lhs   |    5 ++++-
 2 files changed, 12 insertions(+), 1 deletion(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index 6c0ae89..4fbf3ca 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -33,6 +33,7 @@ module Demand (
         trimCPRInfo, returnsCPR, returnsCPR_maybe,
         StrictSig(..), mkStrictSig, mkClosedStrictSig, nopSig, botSig, cprProdSig, convergeSig,
         isNopSig, splitStrictSig, increaseStrictSigArity,
+        sigMayDiverge,
 
         seqDemand, seqDemandList, seqDmdType, seqStrictSig, 
 
@@ -794,6 +795,10 @@ cprProdRes _arg_tys
   | opt_CprOff = topRes
   | otherwise  = Converges $ RetProd
 
+-- Forget that something might converge for sure
+divergeDmdResult :: DmdResult -> DmdResult
+divergeDmdResult r = r `lubDmdResult` botRes
+
 vanillaCprProdRes :: Arity -> DmdResult
 vanillaCprProdRes _arity
   | opt_CprOff = topRes
@@ -1449,6 +1454,9 @@ convergeResult Diverges      = Converges NoCPR
 convergeResult (Dunno c)     = Converges c
 convergeResult (Converges c) = Converges c
 
+sigMayDiverge :: StrictSig -> StrictSig
+sigMayDiverge (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 17dbb5f..24c627c 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -1056,7 +1056,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) = sigMayDiverge sig
+       | otherwise                         = sig
 
 extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv
 extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl)