Make Core Lint check the let/app invariant
authorSimon Peyton Jones <simonpj@microsoft.com>
Fri, 1 Aug 2014 15:41:52 +0000 (16:41 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Thu, 7 Aug 2014 08:55:14 +0000 (09:55 +0100)
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.)

compiler/coreSyn/CoreLint.lhs

index a586810..f460782 100644 (file)
@@ -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:"),