module CoreLint (
lintCoreBindings,
lintUnfolding,
- beginPass, endPass
+ showPass, endPass
) where
#include "HsVersions.h"
-import IO ( hPutStr, hPutStrLn, stderr, stdout )
-
-import CmdLineOpts ( opt_D_show_passes, opt_DoCoreLinting, opt_PprStyle_Debug )
import CoreSyn
-import CoreFVs ( idFreeVars, mustHaveLocalBinding )
-import CoreUtils ( exprOkForSpeculation, coreBindsSize )
+import CoreFVs ( idFreeVars )
+import CoreUtils ( findDefault, exprOkForSpeculation, coreBindsSize, mkPiType )
import Bag
-import Literal ( Literal, literalType )
-import DataCon ( DataCon, dataConRepType )
-import Id ( isDeadBinder )
-import Var ( Var, 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,
isUnboxedTupleType,
hasMoreBoxityInfo
)
-import PprType ( {- instance Outputable Type -} )
-import TyCon ( TyCon, isPrimTyCon, tyConDataCons )
+import TyCon ( isPrimTyCon )
import BasicTypes ( RecFlag(..), isNonRec )
+import CmdLineOpts
+import Maybe
+import Util ( notNull )
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
- hPutStrLn stdout (" Result size = " ++ show (coreBindsSize binds))
+ 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,
lintUnfolding :: SrcLoc
-> [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 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)
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}
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) ->
+ -- 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)
))
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}
%************************************************************************
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
| 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}
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
------------------------------------------------------
-- Other error messages
+mkAppMsg :: Type -> Type -> Message
mkAppMsg fun arg
= vcat [ptext SLIT("Argument value doesn't match argument type:"),
hang (ptext SLIT("Fun type:")) 4 (ppr fun),