[commit: ghc] master: Lint DFunUnfoldings (0a18231)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/0a18231b9c62c9f773a5c74f7cc290416fbbb655/ghc

>---------------------------------------------------------------

commit 0a18231b9c62c9f773a5c74f7cc290416fbbb655
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Mon Dec 19 15:04:51 2016 +0000

    Lint DFunUnfoldings
    
    Previously we simply failed to Lint these DFunUnfoldings, which led
    to a very delayed error message for Trac #12944


>---------------------------------------------------------------

0a18231b9c62c9f773a5c74f7cc290416fbbb655
 compiler/coreSyn/CoreLint.hs | 16 ++++++++++++++--
 1 file changed, 14 insertions(+), 2 deletions(-)

diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index 8f47d5e..345e4b5 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -563,7 +563,7 @@ lintRhs rhs
         -- imitate @lintCoreExpr (App ...)@
         [] -> do
           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.
 lintRhs rhs = lintCoreExpr rhs
 
@@ -572,6 +572,14 @@ lintIdUnfolding bndr bndr_ty (CoreUnfolding { uf_tmpl = rhs, uf_src = src })
   | isStableSource src
   = do { ty <- lintCoreExpr rhs
        ; 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  _ _ _
   = return ()       -- Do not Lint unstable unfoldings, because that leads
                     -- to exponential behaviour; c.f. CoreFVs.idUnfoldingVars
@@ -694,7 +702,7 @@ lintCoreExpr e@(App _ _)
            _     -> go
   where
     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
 
@@ -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.
 -}
 
+
+lintCoreArgs  :: OutType -> [CoreArg] -> LintM OutType
+lintCoreArgs fun_ty args = foldM lintCoreArg fun_ty args
+
 lintCoreArg  :: OutType -> CoreArg -> LintM OutType
 lintCoreArg fun_ty (Type arg_ty)
   = do { checkL (not (isCoercionTy arg_ty))