Commit 0a18231b authored by Simon Peyton Jones's avatar Simon Peyton Jones

Lint DFunUnfoldings

Previously we simply failed to Lint these DFunUnfoldings, which led
to a very delayed error message for Trac #12944
parent e07ad4db
...@@ -563,7 +563,7 @@ lintRhs rhs ...@@ -563,7 +563,7 @@ lintRhs rhs
-- imitate @lintCoreExpr (App ...)@ -- imitate @lintCoreExpr (App ...)@
[] -> do [] -> do
fun_ty <- lintCoreExpr fun fun_ty <- lintCoreExpr fun
addLoc (AnExpr rhs') $ foldM lintCoreArg fun_ty args addLoc (AnExpr rhs') $ lintCoreArgs fun_ty args
-- Rejects applications of the data constructor @StaticPtr@ if it finds any. -- Rejects applications of the data constructor @StaticPtr@ if it finds any.
lintRhs rhs = lintCoreExpr rhs lintRhs rhs = lintCoreExpr rhs
...@@ -572,6 +572,14 @@ lintIdUnfolding bndr bndr_ty (CoreUnfolding { uf_tmpl = rhs, uf_src = src }) ...@@ -572,6 +572,14 @@ lintIdUnfolding bndr bndr_ty (CoreUnfolding { uf_tmpl = rhs, uf_src = src })
| isStableSource src | isStableSource src
= do { ty <- lintCoreExpr rhs = do { ty <- lintCoreExpr rhs
; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "unfolding") ty) } ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "unfolding") ty) }
lintIdUnfolding bndr bndr_ty (DFunUnfolding { df_con = con, df_bndrs = bndrs
, df_args = args })
= do { ty <- lintBinders bndrs $ \ bndrs' ->
do { res_ty <- lintCoreArgs (dataConRepType con) args
; return (mkLamTypes bndrs' res_ty) }
; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "dfun unfolding") ty) }
lintIdUnfolding _ _ _ lintIdUnfolding _ _ _
= return () -- Do not Lint unstable unfoldings, because that leads = return () -- Do not Lint unstable unfoldings, because that leads
-- to exponential behaviour; c.f. CoreFVs.idUnfoldingVars -- to exponential behaviour; c.f. CoreFVs.idUnfoldingVars
...@@ -694,7 +702,7 @@ lintCoreExpr e@(App _ _) ...@@ -694,7 +702,7 @@ lintCoreExpr e@(App _ _)
_ -> go _ -> go
where where
go = do { fun_ty <- lintCoreExpr fun go = do { fun_ty <- lintCoreExpr fun
; addLoc (AnExpr e) $ foldM lintCoreArg fun_ty args } ; addLoc (AnExpr e) $ lintCoreArgs fun_ty args }
(fun, args) = collectArgs e (fun, args) = collectArgs e
...@@ -791,6 +799,10 @@ The basic version of these functions checks that the argument is a ...@@ -791,6 +799,10 @@ The basic version of these functions checks that the argument is a
subtype of the required type, as one would expect. subtype of the required type, as one would expect.
-} -}
lintCoreArgs :: OutType -> [CoreArg] -> LintM OutType
lintCoreArgs fun_ty args = foldM lintCoreArg fun_ty args
lintCoreArg :: OutType -> CoreArg -> LintM OutType lintCoreArg :: OutType -> CoreArg -> LintM OutType
lintCoreArg fun_ty (Type arg_ty) lintCoreArg fun_ty (Type arg_ty)
= do { checkL (not (isCoercionTy arg_ty)) = do { checkL (not (isCoercionTy arg_ty))
......
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