projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Improve error reporting in Core Lint
[ghc-hetmet.git]
/
ghc
/
compiler
/
coreSyn
/
CoreLint.lhs
diff --git
a/ghc/compiler/coreSyn/CoreLint.lhs
b/ghc/compiler/coreSyn/CoreLint.lhs
index
60ddc5c
..
be323be
100644
(file)
--- a/
ghc/compiler/coreSyn/CoreLint.lhs
+++ b/
ghc/compiler/coreSyn/CoreLint.lhs
@@
-38,7
+38,8
@@
import Type ( Type, tyVarsOfType, coreEqType,
getTvSubstEnv, getTvInScope )
import TyCon ( isPrimTyCon )
import BasicTypes ( RecFlag(..), Boxity(..), isNonRec )
getTvSubstEnv, getTvInScope )
import TyCon ( isPrimTyCon )
import BasicTypes ( RecFlag(..), Boxity(..), isNonRec )
-import CmdLineOpts
+import StaticFlags ( opt_PprStyle_Debug )
+import DynFlags ( DynFlags, DynFlag(..), dopt )
import Outputable
#ifdef DEBUG
import Outputable
#ifdef DEBUG
@@
-65,8
+66,8
@@
endPass dflags pass_name dump_flag binds
= do
-- Report result size if required
-- This has the side effect of forcing the intermediate to be evaluated
= do
-- Report result size if required
-- This has the side effect of forcing the intermediate to be evaluated
- debugTraceMsg dflags $
- " Result size = " ++ show (coreBindsSize binds)
+ debugTraceMsg dflags 2 $
+ (text " Result size =" <+> int (coreBindsSize binds))
-- Report verbosely, if required
dumpIfSet_core dflags dump_flag pass_name (pprCoreBindings binds)
-- Report verbosely, if required
dumpIfSet_core dflags dump_flag pass_name (pprCoreBindings binds)
@@
-103,9
+104,9
@@
Outstanding issues:
--
-- Things are *not* OK if:
--
--
-- Things are *not* OK if:
--
- -- * Unsaturated type app before specialisation has been done;
+ -- * Unsaturated type app before specialisation has been done;
--
--
- -- * Oversaturated type app after specialisation (eta reduction
+ -- * Oversaturated type app after specialisation (eta reduction
-- may well be happening...);
\begin{code}
-- may well be happening...);
\begin{code}
@@
-119,7
+120,7
@@
lintCoreBindings dflags whoDunnit binds
= case (initL (lint_binds binds)) of
Nothing -> showPass dflags ("Core Linted result of " ++ whoDunnit)
Just bad_news -> printDump (display bad_news) >>
= case (initL (lint_binds binds)) of
Nothing -> showPass dflags ("Core Linted result of " ++ whoDunnit)
Just bad_news -> printDump (display bad_news) >>
- ghcExit 1
+ ghcExit dflags 1
where
-- Put all the top-level binders in scope at the start
-- This is because transformation rules can bring something
where
-- Put all the top-level binders in scope at the start
-- This is because transformation rules can bring something
@@
-234,7
+235,7
@@
lintCoreExpr (Let (Rec pairs) body)
where
bndrs = map fst pairs
where
bndrs = map fst pairs
-lintCoreExpr (App fun (Type ty))
+lintCoreExpr e@(App fun (Type ty))
-- This is like 'let' for types
-- It's needed when dealing with desugarer output for GADTs. Consider
-- data T = forall a. T a (a->Int) Bool
-- This is like 'let' for types
-- It's needed when dealing with desugarer output for GADTs. Consider
-- data T = forall a. T a (a->Int) Bool
@@
-259,7
+260,8
@@
lintCoreExpr (App fun (Type ty))
-- False -> fail)
-- ) a
-- Now the inner case look as though it has incompatible branches.
-- False -> fail)
-- ) a
-- Now the inner case look as though it has incompatible branches.
- = go fun [ty]
+ = addLoc (AnExpr e) $
+ go fun [ty]
where
go (App fun (Type ty)) tys
= do { go fun (ty:tys) }
where
go (App fun (Type ty)) tys
= do { go fun (ty:tys) }
@@
-277,9
+279,9
@@
lintCoreExpr (App fun (Type ty))
; lintCoreArgs fun_ty (map Type tys) }
lintCoreExpr e@(App fun arg)
; lintCoreArgs fun_ty (map Type tys) }
lintCoreExpr e@(App fun arg)
- = do { ty <- lintCoreExpr fun
+ = do { fun_ty <- lintCoreExpr fun
; addLoc (AnExpr e) $
; addLoc (AnExpr e) $
- lintCoreArg ty arg }
+ lintCoreArg fun_ty arg }
lintCoreExpr (Lam var expr)
= addLoc (LambdaBodyOf var) $
lintCoreExpr (Lam var expr)
= addLoc (LambdaBodyOf var) $
@@
-335,14
+337,14
@@
lintCoreArgs ty (a : args) =
do { res <- lintCoreArg ty a
; lintCoreArgs res args }
do { res <- lintCoreArg ty a
; lintCoreArgs res args }
-lintCoreArg ty a@(Type arg_ty) =
+lintCoreArg fun_ty a@(Type arg_ty) =
do { arg_ty <- lintTy arg_ty
do { arg_ty <- lintTy arg_ty
- ; lintTyApp ty arg_ty }
+ ; lintTyApp fun_ty arg_ty }
lintCoreArg fun_ty arg =
-- Make sure function type matches argument
do { arg_ty <- lintCoreExpr arg
lintCoreArg fun_ty arg =
-- Make sure function type matches argument
do { arg_ty <- lintCoreExpr arg
- ; let err = mkAppMsg fun_ty arg_ty
+ ; let err = mkAppMsg fun_ty arg_ty arg
; case splitFunTy_maybe fun_ty of
Just (arg,res) ->
do { checkTys arg arg_ty err
; case splitFunTy_maybe fun_ty of
Just (arg,res) ->
do { checkTys arg arg_ty err
@@
-448,7
+450,8
@@
lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
addInScopeVars args $ -- Put the args in scope before lintBinder,
-- because the Ids mention the type variables
if isVanillaDataCon con then
addInScopeVars args $ -- Put the args in scope before lintBinder,
-- because the Ids mention the type variables
if isVanillaDataCon con then
- do { mapM lintBinder args
+ do { addLoc (CasePat alt) $ do
+ { mapM lintBinder args
-- FIX! Add check that all args are Ids.
-- Check the pattern
-- Scrutinee type must be a tycon applicn; checked by caller
-- FIX! Add check that all args are Ids.
-- Check the pattern
-- Scrutinee type must be a tycon applicn; checked by caller
@@
-456,11
+459,12
@@
lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
-- NB: args must be in scope here so that the lintCoreArgs line works.
-- NB: relies on existential type args coming *after* ordinary type args
-- NB: args must be in scope here so that the lintCoreArgs line works.
-- NB: relies on existential type args coming *after* ordinary type args
- ; con_type <- lintTyApps (dataConRepType con) tycon_arg_tys
+ ; con_type <- lintTyApps (dataConRepType con) tycon_arg_tys
-- Can just map Var as we know that this is a vanilla datacon
-- Can just map Var as we know that this is a vanilla datacon
- ; con_result_ty <- lintCoreArgs con_type (map Var args)
- ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
- -- Check the RHS
+ ; con_result_ty <- lintCoreArgs con_type (map Var args)
+ ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
+ }
+ -- Check the RHS
; checkAltExpr rhs alt_ty }
else -- GADT
; checkAltExpr rhs alt_ty }
else -- GADT
@@
-471,10
+475,13
@@
lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
; case coreRefineTys in_scope con tvs scrut_ty of {
Nothing -> return () ; -- Alternative is dead code
Just (refine, _) -> updateTvSubstEnv (composeTvSubst in_scope refine subst_env) $
; case coreRefineTys in_scope con tvs scrut_ty of {
Nothing -> return () ; -- Alternative is dead code
Just (refine, _) -> updateTvSubstEnv (composeTvSubst in_scope refine subst_env) $
- do { tvs' <- mapM lintTy (mkTyVarTys tvs)
- ; con_type <- lintTyApps (dataConRepType con) tvs'
- ; mapM lintBinder ids -- Lint Ids in the refined world
- ; lintCoreArgs con_type (map Var ids)
+ do { addLoc (CasePat alt) $ do
+ { tvs' <- mapM lintTy (mkTyVarTys tvs)
+ ; con_type <- lintTyApps (dataConRepType con) tvs'
+ ; mapM lintBinder ids -- Lint Ids in the refined world
+ ; lintCoreArgs con_type (map Var ids)
+ }
+
; let refined_alt_ty = substTy (mkTvSubst in_scope refine) alt_ty
-- alt_ty is already an OutType, so don't re-apply
-- the current substitution. But we must apply the
; let refined_alt_ty = substTy (mkTvSubst in_scope refine) alt_ty
-- alt_ty is already an OutType, so don't re-apply
-- the current substitution. But we must apply the
@@
-544,7
+551,8
@@
data LintLocInfo
= RhsOf Id -- The variable bound
| LambdaBodyOf Id -- The lambda-binder
| BodyOfLetRec [Id] -- One of the binders
= RhsOf Id -- The variable bound
| LambdaBodyOf Id -- The lambda-binder
| BodyOfLetRec [Id] -- One of the binders
- | CaseAlt CoreAlt -- Pattern of a case alternative
+ | CaseAlt CoreAlt -- Case alternative
+ | CasePat CoreAlt -- *Pattern* of the case alternative
| AnExpr CoreExpr -- Some expression
| ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
\end{code}
| AnExpr CoreExpr -- Some expression
| ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
\end{code}
@@
-655,7
+663,10
@@
dumpLoc (AnExpr e)
= (noSrcLoc, text "In the expression:" <+> ppr e)
dumpLoc (CaseAlt (con, args, rhs))
= (noSrcLoc, text "In the expression:" <+> ppr e)
dumpLoc (CaseAlt (con, args, rhs))
- = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> ppr args))
+ = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args))
+
+dumpLoc (CasePat (con, args, rhs))
+ = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args))
dumpLoc (ImportedUnfolding locn)
= (locn, brackets (ptext SLIT("in an imported unfolding")))
dumpLoc (ImportedUnfolding locn)
= (locn, brackets (ptext SLIT("in an imported unfolding")))
@@
-720,11
+731,12
@@
mkBadAltMsg scrut_ty alt
------------------------------------------------------
-- Other error messages
------------------------------------------------------
-- Other error messages
-mkAppMsg :: Type -> Type -> Message
-mkAppMsg fun arg
+mkAppMsg :: Type -> Type -> CoreExpr -> Message
+mkAppMsg fun_ty arg_ty arg
= vcat [ptext SLIT("Argument value doesn't match argument type:"),
= vcat [ptext SLIT("Argument value doesn't match argument type:"),
- hang (ptext SLIT("Fun type:")) 4 (ppr fun),
- hang (ptext SLIT("Arg type:")) 4 (ppr arg)]
+ hang (ptext SLIT("Fun type:")) 4 (ppr fun_ty),
+ hang (ptext SLIT("Arg type:")) 4 (ppr arg_ty),
+ hang (ptext SLIT("Arg:")) 4 (ppr arg)]
mkKindErrMsg :: TyVar -> Type -> Message
mkKindErrMsg tyvar arg_ty
mkKindErrMsg :: TyVar -> Type -> Message
mkKindErrMsg tyvar arg_ty