From fca15ac53af8308608a44d6e7b9faaff1cf30d70 Mon Sep 17 00:00:00 2001
From: Joachim Breitner <mail@joachim-breitner.de>
Date: Tue, 26 Nov 2013 10:18:35 +0000
Subject: [PATCH] Loop breakers are not allowed to have a Converges DmdResult
---
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 6c0ae89a767..4fbf3ca1845 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 17dbb5f48d2..24c627c892a 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)
--
GitLab