Improve Lint a little
authorSimon Peyton Jones <simonpj@microsoft.com>
Fri, 17 Mar 2017 08:54:39 +0000 (08:54 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Fri, 17 Mar 2017 16:30:25 +0000 (16:30 +0000)
Better location info if the error is in an unfolding

compiler/coreSyn/CoreLint.hs

index 40386e4..0363d6b 100644 (file)
@@ -582,7 +582,9 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
            _ -> return ()
 
        ; mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder)
-       ; lintIdUnfolding binder binder_ty (idUnfolding binder) }
+
+       ; addLoc (UnfoldingOf binder) $
+         lintIdUnfolding binder binder_ty (idUnfolding binder) }
 
         -- We should check the unfolding, if any, but this is tricky because
         -- the unfolding is a SimplifiableCoreExpr. Give up for now.
@@ -611,7 +613,7 @@ lintRhs bndr rhs
            ; return $ mkLamType var' body_ty }
 
     lint_join_lams n tot True _other
-      = failWithL $ mkBadJoinArityMsg bndr tot (tot-n)
+      = failWithL $ mkBadJoinArityMsg bndr tot (tot-n) rhs
     lint_join_lams _ _ False rhs
       = markAllJoinsBad $ lintCoreExpr rhs
           -- Future join point, not yet eta-expanded
@@ -1940,6 +1942,7 @@ instance HasDynFlags LintM where
 data LintLocInfo
   = RhsOf Id            -- The variable bound
   | LambdaBodyOf Id     -- The lambda-binder
+  | UnfoldingOf Id      -- Unfolding of a binder
   | BodyOfLetRec [Id]   -- One of the binders
   | CaseAlt CoreAlt     -- Case alternative
   | CasePat CoreAlt     -- The *pattern* of the case alternative
@@ -2127,6 +2130,9 @@ dumpLoc (RhsOf v)
 dumpLoc (LambdaBodyOf b)
   = (getSrcLoc b, brackets (text "in body of lambda with binder" <+> pp_binder b))
 
+dumpLoc (UnfoldingOf b)
+  = (getSrcLoc b, brackets (text "in the unfolding of" <+> pp_binder b))
+
 dumpLoc (BodyOfLetRec [])
   = (noSrcLoc, brackets (text "In body of a letrec with no binders"))
 
@@ -2353,12 +2359,14 @@ mkInvalidJoinPointMsg var ty
   = hang (text "Join point has invalid type:")
         2 (ppr var <+> dcolon <+> ppr ty)
 
-mkBadJoinArityMsg :: Var -> Int -> Int -> SDoc
-mkBadJoinArityMsg var ar nlams
+mkBadJoinArityMsg :: Var -> Int -> Int -> CoreExpr -> SDoc
+mkBadJoinArityMsg var ar nlams rhs
   = vcat [ text "Join point has too few lambdas",
            text "Join var:" <+> ppr var,
            text "Join arity:" <+> ppr ar,
-           text "Number of lambdas:" <+> ppr nlams ]
+           text "Number of lambdas:" <+> ppr nlams,
+           text "Rhs = " <+> ppr rhs
+           ]
 
 invalidJoinOcc :: Var -> SDoc
 invalidJoinOcc var