module CoreLint (
lintCoreBindings,
lintUnfolding,
- beginPass, endPass
+ showPass, endPass
) where
#include "HsVersions.h"
-import IO ( hPutStr, hPutStrLn, stderr )
-
-import CmdLineOpts ( opt_D_show_passes, opt_DoCoreLinting, opt_PprStyle_Debug )
import CoreSyn
import CoreFVs ( idFreeVars )
-import CoreUtils ( exprOkForSpeculation )
+import CoreUtils ( findDefault, exprOkForSpeculation, coreBindsSize, mkPiType )
import Bag
-import Const ( Con(..), DataCon, conType, conOkForApp, conOkForAlt )
-import Id ( mayHaveNoBinding )
-import Var ( IdOrTyVar, Id, TyVar, idType, tyVarKind, isTyVar, isId )
+import Literal ( literalType )
+import DataCon ( dataConRepType )
+import Var ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId, mustHaveLocalBinding )
import VarSet
-import Subst ( mkTyVarSubst, substTy )
-import Name ( isLocallyDefined, getSrcLoc )
+import Subst ( substTyWith )
+import Name ( getSrcLoc )
import PprCore
-import ErrUtils ( doIfSet, dumpIfSet, ghcExit, Message,
- ErrMsg, addErrLocHdrLine, pprBagOfErrors )
-import PrimRep ( PrimRep(..) )
-import SrcLoc ( SrcLoc, noSrcLoc, isNoSrcLoc )
-import Type ( Type, Kind, tyVarsOfType,
- splitFunTy_maybe, mkPiType, mkTyVarTy, unUsgTy,
- splitForAllTy_maybe, splitTyConApp_maybe,
+import ErrUtils ( dumpIfSet_core, ghcExit, Message, showPass,
+ addErrLocHdrLine )
+import SrcLoc ( SrcLoc, noSrcLoc )
+import Type ( Type, tyVarsOfType, eqType,
+ splitFunTy_maybe, mkTyVarTy,
+ splitForAllTy_maybe, splitTyConApp_maybe, splitTyConApp,
isUnLiftedType, typeKind,
- splitAlgTyConApp_maybe,
isUnboxedTupleType,
hasMoreBoxityInfo
)
-import TyCon ( TyCon, isPrimTyCon, tyConDataCons )
+import TyCon ( isPrimTyCon )
import BasicTypes ( RecFlag(..), isNonRec )
+import CmdLineOpts
+import Maybe
import Outputable
+import IO ( hPutStrLn, stderr )
+
infixr 9 `thenL`, `seqL`
\end{code}
%************************************************************************
%* *
-\subsection{Start and end pass}
+\subsection{End pass}
%* *
%************************************************************************
-@beginPass@ and @endPass@ don't really belong here, but it makes a convenient
+@showPass@ and @endPass@ don't really belong here, but it makes a convenient
place for them. They print out stuff before and after core passes,
and do Core Lint when necessary.
\begin{code}
-beginPass :: String -> IO ()
-beginPass pass_name
- | opt_D_show_passes
- = hPutStrLn stderr ("*** " ++ pass_name)
- | otherwise
- = return ()
-
-
-endPass :: String -> Bool -> [CoreBind] -> IO [CoreBind]
-endPass pass_name dump_flag binds
+endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
+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
- if opt_D_show_passes then
+ if verbosity dflags >= 2 then
hPutStrLn stderr (" Result size = " ++ show (coreBindsSize binds))
else
return ()
-- Report verbosely, if required
- dumpIfSet dump_flag pass_name
- (pprCoreBindings binds)
+ dumpIfSet_core dflags dump_flag pass_name (pprCoreBindings binds)
-- Type check
- lintCoreBindings pass_name binds
+ lintCoreBindings dflags pass_name binds
return binds
\end{code}
-- may well be happening...);
\begin{code}
-lintCoreBindings :: String -> [CoreBind] -> IO ()
+lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()
-lintCoreBindings whoDunnit binds
- | not opt_DoCoreLinting
+lintCoreBindings dflags whoDunnit binds
+ | not (dopt Opt_DoCoreLinting dflags)
= return ()
-lintCoreBindings whoDunnit binds
+lintCoreBindings dflags whoDunnit binds
= case (initL (lint_binds binds)) of
- Nothing -> doIfSet opt_D_show_passes
- (hPutStr stderr ("*** Core Linted result of " ++ whoDunnit ++ "\n"))
-
+ Nothing -> showPass dflags ("Core Linted result of " ++ whoDunnit)
Just bad_news -> printDump (display bad_news) >>
ghcExit 1
where
lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
display bad_news
- = vcat [
- text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
+ = vcat [ text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
bad_news,
ptext SLIT("*** Offending Program ***"),
pprCoreBindings binds,
\begin{code}
lintUnfolding :: SrcLoc
- -> [IdOrTyVar] -- Treat these as in scope
+ -> [Var] -- Treat these as in scope
-> CoreExpr
- -> Maybe Message -- Nothing => OK
+ -> Maybe Message -- Nothing => OK
lintUnfolding locn vars expr
- | not opt_DoCoreLinting
- = Nothing
-
- | otherwise
= initL (addLoc (ImportedUnfolding locn) $
- addInScopeVars vars $
- lintCoreExpr expr)
+ addInScopeVars vars $
+ lintCoreExpr expr)
\end{code}
%************************************************************************
checkTys binder_ty ty (mkRhsMsg binder ty) `seqL`
-- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
- checkL (not (isUnLiftedType binder_ty) || (isNonRec rec_flag && exprOkForSpeculation rhs))
+ checkL (not (isUnLiftedType binder_ty)
+ || (isNonRec rec_flag && exprOkForSpeculation rhs))
(mkRhsPrimMsg binder rhs) `seqL`
-- Check whether binder's specialisations contain any out-of-scope variables
lintCoreExpr :: CoreExpr -> LintM Type
lintCoreExpr (Var var) = checkIdInScope var `seqL` returnL (idType var)
+lintCoreExpr (Lit lit) = returnL (literalType lit)
lintCoreExpr (Note (Coerce to_ty from_ty) expr)
= lintCoreExpr expr `thenL` \ expr_ty ->
lintTy to_ty `seqL`
lintTy from_ty `seqL`
- checkTys from_ty (unUsgTy expr_ty) (mkCoerceErr from_ty expr_ty) `seqL`
+ checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty) `seqL`
returnL to_ty
lintCoreExpr (Note other_note expr)
where
bndrs = map fst pairs
-lintCoreExpr e@(Con con args)
- = addLoc (AnExpr e) $
- checkL (conOkForApp con) (mkConAppMsg e) `seqL`
- lintCoreArgs (conType con) args
-
lintCoreExpr e@(App fun arg)
= lintCoreExpr fun `thenL` \ ty ->
addLoc (AnExpr e) $
lintCoreExpr (Lam var expr)
= addLoc (LambdaBodyOf var) $
- checkL (not (isUnboxedTupleType (idType var))) (mkUnboxedTupleMsg var)
+ (if isId var then
+ checkL (not (isUnboxedTupleType (idType var))) (mkUnboxedTupleMsg var)
+ else
+ returnL ())
`seqL`
(addInScopeVars [var] $
lintCoreExpr expr `thenL` \ ty ->
+
returnL (mkPiType var ty))
lintCoreExpr e@(Case scrut var alts)
addInScopeVars [var] (
-- Check the alternatives
- checkAllCasesCovered e scrut_ty alts `seqL`
+ checkCaseAlts e scrut_ty alts `seqL`
+
mapL (lintCoreAlt scrut_ty) alts `thenL` \ (alt_ty : alt_tys) ->
mapL (check alt_ty) alt_tys `seqL`
returnL alt_ty)
%* *
%************************************************************************
-The boolean argument indicates whether we should flag type
-applications to primitive types as being errors.
+The basic version of these functions checks that the argument is a
+subtype of the required type, as one would expect.
\begin{code}
lintCoreArgs :: Type -> [CoreArg] -> LintM Type
+lintCoreArgs = lintCoreArgs0 checkTys
-lintCoreArgs ty [] = returnL ty
-lintCoreArgs ty (a : args)
- = lintCoreArg ty a `thenL` \ res ->
- lintCoreArgs res args
+lintCoreArg :: Type -> CoreArg -> LintM Type
+lintCoreArg = lintCoreArg0 checkTys
\end{code}
+The primitive version of these functions takes a check argument,
+allowing a different comparison.
+
\begin{code}
-lintCoreArg :: Type -> CoreArg -> LintM Type
+lintCoreArgs0 check_tys ty [] = returnL ty
+lintCoreArgs0 check_tys ty (a : args)
+ = lintCoreArg0 check_tys ty a `thenL` \ res ->
+ lintCoreArgs0 check_tys res args
-lintCoreArg ty a@(Type arg_ty)
+lintCoreArg0 check_tys ty a@(Type arg_ty)
= lintTy arg_ty `seqL`
lintTyApp ty arg_ty
-lintCoreArg fun_ty arg
+lintCoreArg0 check_tys fun_ty arg
= -- Make sure function type matches argument
lintCoreExpr arg `thenL` \ arg_ty ->
- case (splitFunTy_maybe fun_ty) of
- Just (arg,res) | (arg_ty == arg) -> returnL res
- _ -> addErrL (mkAppMsg fun_ty arg_ty)
+ let
+ err = mkAppMsg fun_ty arg_ty
+ in
+ case splitFunTy_maybe fun_ty of
+ Just (arg,res) -> check_tys arg arg_ty err `seqL`
+ returnL res
+ _ -> addErrL err
\end{code}
\begin{code}
Nothing -> addErrL (mkTyAppMsg ty arg_ty)
Just (tyvar,body) ->
+ if not (isTyVar tyvar) then addErrL (mkTyAppMsg ty arg_ty) else
let
tyvar_kind = tyVarKind tyvar
argty_kind = typeKind arg_ty
-- error :: forall a:*. String -> a
-- and then apply it to both boxed and unboxed types.
then
- returnL (substTy (mkTyVarSubst [tyvar] [arg_ty]) body)
+ returnL (substTyWith [tyvar] [arg_ty] body)
else
addErrL (mkKindErrMsg tyvar arg_ty)
%************************************************************************
\begin{code}
-checkAllCasesCovered e ty [] = addErrL (mkNullAltsMsg e)
-
-checkAllCasesCovered e ty [(DEFAULT,_,_)] = nopL
-
-checkAllCasesCovered e scrut_ty alts
- = case splitTyConApp_maybe scrut_ty of {
- Nothing -> addErrL (badAltsMsg e);
- Just (tycon, tycon_arg_tys) ->
-
- if isPrimTyCon tycon then
- checkL (hasDefault alts) (nonExhaustiveAltsMsg e)
- else
-{- No longer needed
-#ifdef DEBUG
- -- Algebraic cases are not necessarily exhaustive, because
- -- the simplifer correctly eliminates case that can't
- -- possibly match.
- -- This code just emits a message to say so
- let
- missing_cons = filter not_in_alts (tyConDataCons tycon)
- not_in_alts con = all (not_in_alt con) alts
- not_in_alt con (DataCon con', _, _) = con /= con'
- not_in_alt con other = True
+checkCaseAlts :: CoreExpr -> Type -> [CoreAlt] -> LintM ()
+-- a) Check that the alts are non-empty
+-- b) Check that the DEFAULT comes first, if it exists
+-- c) Check that there's a default for infinite types
+-- NB: Algebraic cases are not necessarily exhaustive, because
+-- the simplifer correctly eliminates case that can't
+-- possibly match.
+
+checkCaseAlts e ty []
+ = addErrL (mkNullAltsMsg e)
+
+checkCaseAlts e ty alts
+ = checkL (all non_deflt con_alts) (mkNonDefltMsg e) `seqL`
+ checkL (isJust maybe_deflt || not is_infinite_ty)
+ (nonExhaustiveAltsMsg e)
+ where
+ (con_alts, maybe_deflt) = findDefault alts
- case_bndr = case e of { Case _ bndr alts -> bndr }
- in
- if not (hasDefault alts || null missing_cons) then
- pprTrace "Exciting (but not a problem)! Non-exhaustive case:"
- (ppr case_bndr <+> ppr missing_cons)
- nopL
- else
-#endif
--}
- nopL }
-
-hasDefault [] = False
-hasDefault ((DEFAULT,_,_) : alts) = True
-hasDefault (alt : alts) = hasDefault alts
+ non_deflt (DEFAULT, _, _) = False
+ non_deflt alt = True
+
+ is_infinite_ty = case splitTyConApp_maybe ty of
+ Nothing -> False
+ Just (tycon, tycon_arg_tys) -> isPrimTyCon tycon
\end{code}
\begin{code}
= checkL (null args) (mkDefaultArgsMsg args) `seqL`
lintCoreExpr rhs
-lintCoreAlt scrut_ty alt@(con, args, rhs)
- = addLoc (CaseAlt alt) (
+lintCoreAlt scrut_ty alt@(LitAlt lit, args, rhs)
+ = checkL (null args) (mkDefaultArgsMsg args) `seqL`
+ checkTys lit_ty scrut_ty
+ (mkBadPatMsg lit_ty scrut_ty) `seqL`
+ lintCoreExpr rhs
+ where
+ lit_ty = literalType lit
- checkL (conOkForAlt con) (mkConAltMsg con) `seqL`
+lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs)
+ = addLoc (CaseAlt alt) (
- mapL (\arg -> checkL (not (isUnboxedTupleType (idType arg)))
+ mapL (\arg -> checkL (not (isUnboxedTupleType (idType arg)))
(mkUnboxedTupleMsg arg)) args `seqL`
addInScopeVars args (
-- Scrutinee type must be a tycon applicn; checked by caller
-- This code is remarkably compact considering what it does!
-- NB: args must be in scope here so that the lintCoreArgs line works.
- case splitTyConApp_maybe scrut_ty of { Just (tycon, tycon_arg_tys) ->
- lintTyApps (conType con) tycon_arg_tys `thenL` \ con_type ->
- lintCoreArgs con_type (map mk_arg args) `thenL` \ con_result_ty ->
+ -- NB: relies on existential type args coming *after* ordinary type args
+ case splitTyConApp scrut_ty of { (tycon, tycon_arg_tys) ->
+ lintTyApps (dataConRepType con) tycon_arg_tys `thenL` \ con_type ->
+ lintCoreArgs con_type (map mk_arg args) `thenL` \ con_result_ty ->
checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
} `seqL`
))
where
mk_arg b | isTyVar b = Type (mkTyVarTy b)
- | otherwise = Var b
+ | isId b = Var b
+ | otherwise = pprPanic "lintCoreAlt:mk_arg " (ppr b)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-lintBinder :: IdOrTyVar -> LintM ()
+lintBinder :: Var -> LintM ()
lintBinder v = nopL
-- ToDo: lint its type
+-- ToDo: lint its rules
lintTy :: Type -> LintM ()
lintTy ty = mapL checkIdInScope (varSetElems (tyVarsOfType ty)) `seqL`
\begin{code}
type LintM a = [LintLocInfo] -- Locations
-> IdSet -- Local vars in scope
- -> Bag ErrMsg -- Error messages so far
- -> (Maybe a, Bag ErrMsg) -- Result and error messages (if any)
+ -> Bag Message -- Error messages so far
+ -> (Maybe a, Bag Message) -- Result and error messages (if any)
data LintLocInfo
= RhsOf Id -- The variable bound
\end{code}
\begin{code}
-initL :: LintM a -> Maybe Message
+initL :: LintM a -> Maybe Message {- errors -}
initL m
- = case (m [] emptyVarSet emptyBag) of { (_, errs) ->
- if isEmptyBag errs then
- Nothing
- else
- Just (pprBagOfErrors errs)
- }
+ = case m [] emptyVarSet emptyBag of
+ (_, errs) | isEmptyBag errs -> Nothing
+ | otherwise -> Just (vcat (punctuate (text "") (bagToList errs)))
returnL :: a -> LintM a
returnL r loc scope errs = (Just r, errs)
\begin{code}
checkL :: Bool -> Message -> LintM ()
-checkL True msg loc scope errs = (Nothing, errs)
-checkL False msg loc scope errs = (Nothing, addErr errs msg loc)
+checkL True msg = nopL
+checkL False msg = addErrL msg
addErrL :: Message -> LintM a
addErrL msg loc scope errs = (Nothing, addErr errs msg loc)
-addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg
-
+addErr :: Bag Message -> Message -> [LintLocInfo] -> Bag Message
addErr errs_so_far msg locs
- = ASSERT (not (null locs))
+ = ASSERT( notNull locs )
errs_so_far `snocBag` mk_msg msg
where
(loc, cxt1) = dumpLoc (head locs)
context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1
| otherwise = cxt1
- mk_msg msg
- | isNoSrcLoc loc = (loc, hang context 4 msg)
- | otherwise = addErrLocHdrLine loc context msg
+ mk_msg msg = addErrLocHdrLine loc context msg
addLoc :: LintLocInfo -> LintM a -> LintM a
addLoc extra_loc m loc scope errs
= m (extra_loc:loc) scope errs
-addInScopeVars :: [IdOrTyVar] -> LintM a -> LintM a
+addInScopeVars :: [Var] -> LintM a -> LintM a
addInScopeVars ids m loc scope errs
= m loc (scope `unionVarSet` mkVarSet ids) errs
\end{code}
\begin{code}
-checkIdInScope :: IdOrTyVar -> LintM ()
+checkIdInScope :: Var -> LintM ()
checkIdInScope id
= checkInScope (ptext SLIT("is out of scope")) id
-checkBndrIdInScope :: IdOrTyVar -> IdOrTyVar -> LintM ()
+checkBndrIdInScope :: Var -> Var -> LintM ()
checkBndrIdInScope binder id
= checkInScope msg id
where
msg = ptext SLIT("is out of scope inside info for") <+>
ppr binder
-checkInScope :: SDoc -> IdOrTyVar -> LintM ()
+checkInScope :: SDoc -> Var -> LintM ()
checkInScope loc_msg var loc scope errs
- | isLocallyDefined var
- && not (var `elemVarSet` scope)
- && not (isId var && mayHaveNoBinding var)
- -- Micro-hack here... Class decls generate applications of their
- -- dictionary constructor, but don't generate a binding for the
- -- constructor (since it would never be used). After a single round
- -- of simplification, these dictionary constructors have been
- -- inlined (from their UnfoldInfo) to CoCons. Just between
- -- desugaring and simplfication, though, they appear as naked, unbound
- -- variables as the function in an application.
- -- The hack here simply doesn't check for out-of-scope-ness for
- -- data constructors (at least, in a function position).
- -- Ditto primitive Ids
+ | mustHaveLocalBinding var && not (var `elemVarSet` scope)
= (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc)
| otherwise
- = (Nothing,errs)
+ = nopL loc scope errs
checkTys :: Type -> Type -> Message -> LintM ()
-checkTys ty1 ty2 msg loc scope errs
- | ty1 == ty2 = (Nothing, errs)
- | otherwise = (Nothing, addErr errs msg loc)
+-- check ty2 is subtype of ty1 (ie, has same structure but usage
+-- annotations need only be consistent, not equal)
+checkTys ty1 ty2 msg
+ | ty1 `eqType` ty2 = nopL
+ | otherwise = addErrL msg
\end{code}
dumpLoc (LambdaBodyOf b)
= (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b))
-dumpLoc (BodyOfLetRec bs)
+dumpLoc (BodyOfLetRec [])
+ = (noSrcLoc, brackets (ptext SLIT("In body of a letrec with no binders")))
+
+dumpLoc (BodyOfLetRec bs@(_:_))
= ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs))
dumpLoc (AnExpr e)
dumpLoc (ImportedUnfolding locn)
= (locn, brackets (ptext SLIT("in an imported unfolding")))
-pp_binders :: [Id] -> SDoc
+pp_binders :: [Var] -> SDoc
pp_binders bs = sep (punctuate comma (map pp_binder bs))
-pp_binder :: Id -> SDoc
-pp_binder b = hsep [ppr b, dcolon, ppr (idType b)]
+pp_binder :: Var -> SDoc
+pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)]
+ | isTyVar b = hsep [ppr b, dcolon, ppr (tyVarKind b)]
\end{code}
\begin{code}
------------------------------------------------------
-- Messages for case expressions
-mkConAppMsg :: CoreExpr -> Message
-mkConAppMsg e
- = hang (text "Application of newtype constructor:")
- 4 (ppr e)
-
-mkConAltMsg :: Con -> Message
-mkConAltMsg con
- = text "PrimOp in case pattern:" <+> ppr con
-
mkNullAltsMsg :: CoreExpr -> Message
mkNullAltsMsg e
= hang (text "Case expression with no alternatives:")
4 (ppr e)
-mkDefaultArgsMsg :: [IdOrTyVar] -> Message
+mkDefaultArgsMsg :: [Var] -> Message
mkDefaultArgsMsg args
= hang (text "DEFAULT case with binders")
4 (ppr args)
text "Result binder type:" <+> ppr (idType var),
text "Scrutinee type:" <+> ppr scrut_ty]
-badAltsMsg :: CoreExpr -> Message
-badAltsMsg e
- = hang (text "Case statement scrutinee is not a data type:")
- 4 (ppr e)
+
+mkNonDefltMsg e
+ = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
nonExhaustiveAltsMsg :: CoreExpr -> Message
nonExhaustiveAltsMsg e
- = hang (text "Case expression with non-exhaustive alternatives")
- 4 (ppr e)
+ = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
mkBadPatMsg :: Type -> Type -> Message
mkBadPatMsg con_result_ty scrut_ty
projects / ghc-hetmet.git / blobdiff