diff options
author | Andreas Klebinger <klebinger.andreas@gmx.at> | 2022-04-27 22:01:58 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-05-01 22:22:31 -0400 |
commit | 2b2e30203a125dc5bfe70f3df7b39787aaf62b1e (patch) | |
tree | 6ce0e6501db73f2c2abcfa764ff1ba8a03efda8e | |
parent | 60071076d880c9ee189c93e0105a9b3d1ff87a3f (diff) | |
download | haskell-2b2e30203a125dc5bfe70f3df7b39787aaf62b1e.tar.gz |
exprIsDeadEnd: Use isDeadEndAppSig to check if a function appliction is bottoming.
We used to check the divergence and that the number of arguments > arity.
But arity zero represents unknown arity so this was subtly broken for a long time!
We would check if the saturated function diverges, and if we applied >=arity arguments.
But for unknown arity functions any number of arguments is >=idArity.
This fixes #21440.
-rw-r--r-- | compiler/GHC/Core/Utils.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Iface/Tidy.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Types/Demand.hs | 8 |
3 files changed, 7 insertions, 7 deletions
diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs index d6653fd387..b7b1c9334b 100644 --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -1087,7 +1087,7 @@ exprIsDeadEnd e | otherwise = go 0 e where - go n (Var v) = isDeadEndId v && n >= idArity v + go n (Var v) = isDeadEndAppSig (idDmdSig v) n go n (App e a) | isTypeArg a = go n e | otherwise = go (n+1) e go n (Tick _ e) = go n e diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index 85cd431c37..7616c9458c 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -52,7 +52,7 @@ import GHC.Types.Var import GHC.Types.Id import GHC.Types.Id.Make ( mkDictSelRhs ) import GHC.Types.Id.Info -import GHC.Types.Demand ( appIsDeadEnd, isTopSig, isDeadEndSig ) +import GHC.Types.Demand ( isDeadEndAppSig, isTopSig, isDeadEndSig ) import GHC.Types.Cpr ( mkCprSig, botCpr ) import GHC.Types.Basic import GHC.Types.Name hiding (varName) @@ -1277,7 +1277,7 @@ tidyTopIdInfo uf_opts rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold _bottom_hidden id_sig = case mb_bot_str of Nothing -> False - Just (arity, _) -> not (appIsDeadEnd id_sig arity) + Just (arity, _) -> not (isDeadEndAppSig id_sig arity) --------- Unfolding ------------ unf_info = realUnfoldingInfo idinfo diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs index 733ca6819d..19d1938557 100644 --- a/compiler/GHC/Types/Demand.hs +++ b/compiler/GHC/Types/Demand.hs @@ -66,7 +66,7 @@ module GHC.Types.Demand ( -- * Demand signatures DmdSig(..), mkDmdSigForArity, mkClosedDmdSig, splitDmdSig, dmdSigDmdEnv, hasDemandEnvSig, - nopSig, botSig, isTopSig, isDeadEndSig, appIsDeadEnd, trimBoxityDmdSig, + nopSig, botSig, isTopSig, isDeadEndSig, isDeadEndAppSig, trimBoxityDmdSig, -- ** Handling arity adjustments prependArgsDmdSig, etaConvertDmdSig, @@ -1976,15 +1976,15 @@ onlyBoxedArguments (DmdSig (DmdType _ dmds _)) = all demandIsBoxed dmds subDemandIsboxed (Prod Unboxed _) = False subDemandIsboxed (Prod _ ds) = all demandIsBoxed ds --- | Returns true if an application to n args would diverge or throw an +-- | Returns true if an application to n value args would diverge or throw an -- exception. -- -- If a function having 'botDiv' is applied to a less number of arguments than -- its syntactic arity, we cannot say for sure that it is going to diverge. -- Hence this function conservatively returns False in that case. -- See Note [Dead ends]. -appIsDeadEnd :: DmdSig -> Int -> Bool -appIsDeadEnd (DmdSig (DmdType _ ds res)) n +isDeadEndAppSig :: DmdSig -> Int -> Bool +isDeadEndAppSig (DmdSig (DmdType _ ds res)) n = isDeadEndDiv res && not (lengthExceeds ds n) trimBoxityDmdType :: DmdType -> DmdType |