diff options
Diffstat (limited to 'compiler/coreSyn/CoreLint.hs')
| -rw-r--r-- | compiler/coreSyn/CoreLint.hs | 20 |
1 files changed, 20 insertions, 0 deletions
diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index 690836a1aa..a81c9c39ed 100644 --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -56,6 +56,8 @@ import Util import InstEnv ( instanceDFunId ) import OptCoercion ( checkAxInstCo ) import UniqSupply +import CoreArity ( typeArity ) +import Demand ( splitStrictSig, isBotRes ) import HscTypes import DynFlags @@ -487,6 +489,24 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs) -- StrictSig dmd_ty -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs) -- (mkArityMsg binder) + -- Check that the binder's arity is within the bounds imposed by + -- the type and the strictness signature. See Note [exprArity invariant] + -- and Note [Trimming arity] + ; checkL (idArity binder <= length (typeArity (idType binder))) + (ptext (sLit "idArity") <+> ppr (idArity binder) <+> + ptext (sLit "exceeds typeArity") <+> + ppr (length (typeArity (idType binder))) <> colon <+> + ppr binder) + + ; case splitStrictSig (idStrictness binder) of + (demands, result_info) | isBotRes result_info -> + checkL (idArity binder <= length demands) + (ptext (sLit "idArity") <+> ppr (idArity binder) <+> + ptext (sLit "exceeds arity imposed by the strictness signature") <+> + ppr (idStrictness binder) <> colon <+> + ppr binder) + _ -> return () + ; lintIdUnfolding binder binder_ty (idUnfolding binder) } -- We should check the unfolding, if any, but this is tricky because |