Commit 6b965570 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Make Core Lint check the let/app invariant

If we have an invariant, Lint should jolly well check it.

(And indeed, adding this test throws up Lint errors that
are fixed in separate patches.)
parent 93b1a43e
......@@ -207,7 +207,8 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
; binder_ty <- applySubstTy binder_ty
; checkTys binder_ty ty (mkRhsMsg binder (ptext (sLit "RHS")) ty)
-- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
-- Check the let/app invariant
-- See Note [CoreSyn let/app invariant] in CoreSyn
; checkL (not (isUnLiftedType binder_ty)
|| (isNonRec rec_flag && exprOkForSpeculation rhs))
(mkRhsPrimMsg binder rhs)
......@@ -220,6 +221,7 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
-- Check that if the binder is local, it is not marked as exported
; checkL (not (isExportedId binder) || isTopLevel top_lvl_flag)
(mkNonTopExportedMsg binder)
-- Check that if the binder is local, it does not have an external name
; checkL (not (isExternalName (Var.varName binder)) || isTopLevel top_lvl_flag)
(mkNonTopExternalNameMsg binder)
......@@ -451,6 +453,8 @@ lintCoreArg fun_ty (Type arg_ty)
lintCoreArg fun_ty arg
= do { arg_ty <- lintCoreExpr arg
; checkL (not (isUnLiftedType arg_ty) || exprOkForSpeculation arg)
(mkLetAppMsg arg)
; lintValApp arg fun_ty arg_ty }
......@@ -1391,6 +1395,11 @@ mkRhsMsg binder what ty
hsep [ptext (sLit "Binder's type:"), ppr (idType binder)],
hsep [ptext (sLit "Rhs type:"), ppr ty]]
mkLetAppMsg :: CoreExpr -> MsgDoc
mkLetAppMsg e
= hang (ptext (sLit "This argument does not satisfy the let/app invariant:"))
2 (ppr e)
mkRhsPrimMsg :: Id -> CoreExpr -> MsgDoc
mkRhsPrimMsg binder _rhs
= vcat [hsep [ptext (sLit "The type of this binder is primitive:"),
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment