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) ...@@ -207,7 +207,8 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
; binder_ty <- applySubstTy binder_ty ; binder_ty <- applySubstTy binder_ty
; checkTys binder_ty ty (mkRhsMsg binder (ptext (sLit "RHS")) 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) ; checkL (not (isUnLiftedType binder_ty)
|| (isNonRec rec_flag && exprOkForSpeculation rhs)) || (isNonRec rec_flag && exprOkForSpeculation rhs))
(mkRhsPrimMsg binder rhs) (mkRhsPrimMsg binder rhs)
...@@ -220,6 +221,7 @@ lintSingleBinding top_lvl_flag rec_flag (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 -- Check that if the binder is local, it is not marked as exported
; checkL (not (isExportedId binder) || isTopLevel top_lvl_flag) ; checkL (not (isExportedId binder) || isTopLevel top_lvl_flag)
(mkNonTopExportedMsg binder) (mkNonTopExportedMsg binder)
-- Check that if the binder is local, it does not have an external name -- Check that if the binder is local, it does not have an external name
; checkL (not (isExternalName (Var.varName binder)) || isTopLevel top_lvl_flag) ; checkL (not (isExternalName (Var.varName binder)) || isTopLevel top_lvl_flag)
(mkNonTopExternalNameMsg binder) (mkNonTopExternalNameMsg binder)
...@@ -451,6 +453,8 @@ lintCoreArg fun_ty (Type arg_ty) ...@@ -451,6 +453,8 @@ lintCoreArg fun_ty (Type arg_ty)
lintCoreArg fun_ty arg lintCoreArg fun_ty arg
= do { arg_ty <- lintCoreExpr arg = do { arg_ty <- lintCoreExpr arg
; checkL (not (isUnLiftedType arg_ty) || exprOkForSpeculation arg)
(mkLetAppMsg arg)
; lintValApp arg fun_ty arg_ty } ; lintValApp arg fun_ty arg_ty }
----------------- -----------------
...@@ -1391,6 +1395,11 @@ mkRhsMsg binder what ty ...@@ -1391,6 +1395,11 @@ mkRhsMsg binder what ty
hsep [ptext (sLit "Binder's type:"), ppr (idType binder)], hsep [ptext (sLit "Binder's type:"), ppr (idType binder)],
hsep [ptext (sLit "Rhs type:"), ppr ty]] 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 :: Id -> CoreExpr -> MsgDoc
mkRhsPrimMsg binder _rhs mkRhsPrimMsg binder _rhs
= vcat [hsep [ptext (sLit "The type of this binder is primitive:"), = 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