diff options
Diffstat (limited to 'compiler/GHC/Core/Lint.hs')
| -rw-r--r-- | compiler/GHC/Core/Lint.hs | 36 |
1 files changed, 25 insertions, 11 deletions
diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index b3ed2ce8eb..7eaec265a8 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -490,7 +490,18 @@ lintCoreBindings dflags pass local_in_scope binds { lf_check_global_ids = check_globals , lf_check_inline_loop_breakers = check_lbs , lf_check_static_ptrs = check_static_ptrs - , lf_check_linearity = check_linearity } + , lf_check_linearity = check_linearity + , lf_check_levity_poly = check_levity } + + -- In the output of the desugarer, before optimisation, + -- we have eta-expanded data constructors with levity-polymorphic + -- bindings; so we switch off the lev-poly checks. The very simple + -- optimiser will beta-reduce them away. + -- See Note [Checking levity-polymorphic data constructors] + -- in GHC.HsToCore.Expr. + check_levity = case pass of + CoreDesugar -> False + _ -> True -- See Note [Checking for global Ids] check_globals = case pass of @@ -541,7 +552,6 @@ lintCoreBindings dflags pass local_in_scope binds Note [Linting Unfoldings from Interfaces] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - We use this to check all top-level unfoldings that come in from interfaces (it is very painful to catch errors otherwise). @@ -922,9 +932,9 @@ lintCoreExpr e@(App _ _) , fun `hasKey` runRWKey -- N.B. we may have an over-saturated application of the form: -- runRW (\s -> \x -> ...) y - , arg_ty1 : arg_ty2 : arg3 : rest <- args - = do { fun_pair1 <- lintCoreArg (idType fun, zeroUE) arg_ty1 - ; (fun_ty2, ue2) <- lintCoreArg fun_pair1 arg_ty2 + , ty_arg1 : ty_arg2 : arg3 : rest <- args + = do { fun_pair1 <- lintCoreArg (idType fun, zeroUE) ty_arg1 + ; (fun_ty2, ue2) <- lintCoreArg fun_pair1 ty_arg2 -- See Note [Linting of runRW#] ; let lintRunRWCont :: CoreArg -> LintM (LintedType, UsageEnv) lintRunRWCont expr@(Lam _ _) = @@ -1190,13 +1200,17 @@ lintCoreArg (fun_ty, fun_ue) arg = do { (arg_ty, arg_ue) <- markAllJoinsBad $ lintCoreExpr arg -- See Note [Levity polymorphism invariants] in GHC.Core ; flags <- getLintFlags - ; lintL (not (lf_check_levity_poly flags) || not (isTypeLevPoly arg_ty)) - (text "Levity-polymorphic argument:" <+> - (ppr arg <+> dcolon <+> parens (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty)))) - -- check for levity polymorphism first, because otherwise isUnliftedType panics - ; checkL (not (isUnliftedType arg_ty) || exprOkForSpeculation arg) - (mkLetAppMsg arg) + ; when (lf_check_levity_poly flags) $ + -- Only do these checks if lf_check_levity_poly is on, + -- because otherwise isUnliftedType panics + do { checkL (not (isTypeLevPoly arg_ty)) + (text "Levity-polymorphic argument:" + <+> ppr arg <+> dcolon + <+> parens (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))) + + ; checkL (not (isUnliftedType arg_ty) || exprOkForSpeculation arg) + (mkLetAppMsg arg) } ; lintValApp arg fun_ty arg_ty fun_ue arg_ue } |