diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2014-08-01 16:41:52 +0100 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2014-08-07 09:55:14 +0100 |
| commit | 6b965570e72cebd56875a7f3115580b0954b6d14 (patch) | |
| tree | a47265cc51075f0275e809c6d981f8ed327e6013 /compiler | |
| parent | 93b1a43ebe8bf145b35e903966d4a62b7847f213 (diff) | |
| download | haskell-6b965570e72cebd56875a7f3115580b0954b6d14.tar.gz | |
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.)
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/coreSyn/CoreLint.lhs | 11 |
1 files changed, 10 insertions, 1 deletions
diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index a5868108d9..f4607823a8 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -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:"), |