module CoreLint (
lintCoreBindings,
lintUnfolding,
- beginPass, endPass, endPassWithRules
+ 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 Rules ( RuleBase, pprRuleBase )
-import CoreFVs ( idFreeVars, mustHaveLocalBinding )
-import CoreUtils ( exprOkForSpeculation, coreBindsSize, mkPiType )
+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,
- WarnMsg, pprBagOfWarnings)
-import PrimRep ( PrimRep(..) )
-import SrcLoc ( SrcLoc, noSrcLoc, isNoSrcLoc )
-import Type ( Type, Kind, tyVarsOfType,
+import ErrUtils ( dumpIfSet_core, ghcExit, Message, showPass,
+ addErrLocHdrLine )
+import SrcLoc ( SrcLoc, noSrcLoc )
+import Type ( Type, tyVarsOfType, eqType,
splitFunTy_maybe, mkTyVarTy,
- splitForAllTy_maybe, splitTyConApp_maybe,
+ 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 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
- = do
- (binds, _) <- endPassWithRules pass_name dump_flag binds Nothing
- return binds
-
-endPassWithRules :: String -> Bool -> [CoreBind] -> Maybe RuleBase
- -> IO ([CoreBind], Maybe RuleBase)
-endPassWithRules pass_name dump_flag binds rules
+endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
+endPass dflags pass_name dump_flag binds
= do
- -- ToDo: force the rules?
-
-- 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 $$ case rules of
- Nothing -> empty
- Just rb -> pprRuleBase rb)
+ dumpIfSet_core dflags dump_flag pass_name (pprCoreBindings binds)
-- Type check
- lintCoreBindings pass_name binds
- -- ToDo: lint the rules
+ lintCoreBindings dflags pass_name binds
- return (binds, rules)
+ 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, Nothing) -> done_lint
-
- (Nothing, Just warnings) -> printDump (warn warnings) >>
- done_lint
-
- (Just bad_news, warns) -> printDump (display bad_news warns) >>
- ghcExit 1
+ Nothing -> showPass dflags ("Core Linted result of " ++ whoDunnit)
+ Just bad_news -> printDump (display bad_news) >>
+ ghcExit 1
where
-- Put all the top-level binders in scope at the start
-- This is because transformation rules can bring something
returnL ()
lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
- done_lint = doIfSet opt_D_show_passes
- (hPutStr stderr ("*** Core Linted result of " ++ whoDunnit ++ "\n"))
- warn warnings
- = vcat [
- text ("*** Core Lint Warnings: in result of " ++ whoDunnit ++ " ***"),
- warnings,
- offender
- ]
-
- display bad_news warns
- = vcat [
- text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
+ display bad_news
+ = vcat [ text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
bad_news,
- maybe offender warn warns -- either offender or warnings (with offender)
- ]
-
- offender
- = vcat [
ptext SLIT("*** Offending Program ***"),
pprCoreBindings binds,
ptext SLIT("*** End of Offense ***")
lintUnfolding :: SrcLoc
-> [Var] -- Treat these as in scope
-> CoreExpr
- -> (Maybe Message, Maybe Message) -- (Nothing,_) => OK
+ -> Maybe Message -- Nothing => OK
lintUnfolding locn vars expr
- | not opt_DoCoreLinting
- = (Nothing, Nothing)
-
- | otherwise
= initL (addLoc (ImportedUnfolding locn) $
- addInScopeVars vars $
- lintCoreExpr expr)
+ addInScopeVars vars $
+ lintCoreExpr expr)
\end{code}
%************************************************************************
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`
-- 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 :: CoreExpr -> Type -> [CoreAlt] -> LintM ()
-
-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}
-- 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)
\begin{code}
type LintM a = [LintLocInfo] -- Locations
-> IdSet -- Local vars in scope
- -> Bag ErrMsg -- Error messages so far
- -> Bag WarnMsg -- Warning messages so far
- -> (Maybe a, Bag ErrMsg, Bag WarnMsg) -- Result and error/warning 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 {- errors -}, Maybe Message {- warnings -})
+initL :: LintM a -> Maybe Message {- errors -}
initL m
- = case m [] emptyVarSet emptyBag emptyBag of
- (_, errs, warns) -> (ifNonEmptyBag errs pprBagOfErrors,
- ifNonEmptyBag warns pprBagOfWarnings)
- where
- ifNonEmptyBag bag f | isEmptyBag bag = Nothing
- | otherwise = Just (f bag)
+ = 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 warns = (Just r, errs, warns)
+returnL r loc scope errs = (Just r, errs)
nopL :: LintM a
-nopL loc scope errs warns = (Nothing, errs, warns)
+nopL loc scope errs = (Nothing, errs)
thenL :: LintM a -> (a -> LintM b) -> LintM b
-thenL m k loc scope errs warns
- = case m loc scope errs warns of
- (Just r, errs', warns') -> k r loc scope errs' warns'
- (Nothing, errs', warns') -> (Nothing, errs', warns')
+thenL m k loc scope errs
+ = case m loc scope errs of
+ (Just r, errs') -> k r loc scope errs'
+ (Nothing, errs') -> (Nothing, errs')
seqL :: LintM a -> LintM b -> LintM b
-seqL m k loc scope errs warns
- = case m loc scope errs warns of
- (_, errs', warns') -> k loc scope errs' warns'
+seqL m k loc scope errs
+ = case m loc scope errs of
+ (_, errs') -> k loc scope errs'
mapL :: (a -> LintM b) -> [a] -> LintM [b]
mapL f [] = returnL []
checkL False msg = addErrL msg
addErrL :: Message -> LintM a
-addErrL msg loc scope errs warns = (Nothing, addErr errs msg loc, warns)
-
-addWarnL :: Message -> LintM a
-addWarnL msg loc scope errs warns = (Nothing, errs, addErr warns msg loc)
+addErrL msg loc scope errs = (Nothing, addErr errs msg loc)
-addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg
--- errors or warnings, actually... they're the same type.
+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 warns
- = m (extra_loc:loc) scope errs warns
+addLoc extra_loc m loc scope errs
+ = m (extra_loc:loc) scope errs
addInScopeVars :: [Var] -> LintM a -> LintM a
-addInScopeVars ids m loc scope errs warns
- = m loc (scope `unionVarSet` mkVarSet ids) errs warns
+addInScopeVars ids m loc scope errs
+ = m loc (scope `unionVarSet` mkVarSet ids) errs
\end{code}
\begin{code}
ppr binder
checkInScope :: SDoc -> Var -> LintM ()
-checkInScope loc_msg var loc scope errs warns
+checkInScope loc_msg var loc scope errs
| mustHaveLocalBinding var && not (var `elemVarSet` scope)
- = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc, warns)
+ = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc)
| otherwise
- = nopL loc scope errs warns
+ = nopL loc scope errs
checkTys :: Type -> Type -> Message -> LintM ()
-- check ty2 is subtype of ty1 (ie, has same structure but usage
-- annotations need only be consistent, not equal)
checkTys ty1 ty2 msg
- | ty1 == ty2 = nopL
- | otherwise = addErrL msg
+ | ty1 `eqType` ty2 = nopL
+ | otherwise = addErrL msg
\end{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
projects / ghc-hetmet.git / blobdiff