diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs index 6c0ae89a767f854d1a289374abc908bdd2851b56..4fbf3ca18451b714637f702927760ca6f833b242 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 17dbb5f48d2f4517519c631a1b169ac109fdf5c9..24c627c892a4325edd07756b8db9fdedba89aa7f 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)