#include "HsVersions.h"
-import IO ( hPutStr, hPutStrLn, stdout )
-
import CoreSyn
import CoreFVs ( idFreeVars )
import CoreUtils ( findDefault, exprOkForSpeculation, coreBindsSize, mkPiType )
import Subst ( substTyWith )
import Name ( getSrcLoc )
import PprCore
-import ErrUtils ( doIfSet, dumpIfSet_core, ghcExit, Message, showPass,
- addErrLocHdrLine )
-import SrcLoc ( SrcLoc, noSrcLoc )
+import ErrUtils ( dumpIfSet_core, ghcExit, Message, showPass,
+ mkLocMessage )
+import SrcLoc ( SrcLoc, noSrcLoc, mkSrcSpan )
import Type ( Type, tyVarsOfType, eqType,
splitFunTy_maybe, mkTyVarTy,
splitForAllTy_maybe, splitTyConApp_maybe, splitTyConApp,
isUnLiftedType, typeKind,
isUnboxedTupleType,
- hasMoreBoxityInfo
+ isSubKind
)
import TyCon ( isPrimTyCon )
import BasicTypes ( RecFlag(..), isNonRec )
import CmdLineOpts
-import Maybe
-import Util ( notNull )
import Outputable
+#ifdef DEBUG
+import Util ( notNull )
+#endif
+
+import Maybe
+import IO ( hPutStrLn, stderr )
+
infixr 9 `thenL`, `seqL`
\end{code}
-- Report result size if required
-- This has the side effect of forcing the intermediate to be evaluated
if verbosity dflags >= 2 then
- hPutStrLn stdout (" Result size = " ++ show (coreBindsSize binds))
+ hPutStrLn stderr (" Result size = " ++ show (coreBindsSize binds))
else
return ()
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 (verbosity dflags >= 2)
- (hPutStr stdout ("*** 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 ***")
(it is very painful to catch errors otherwise):
\begin{code}
-lintUnfolding :: DynFlags
- -> SrcLoc
+lintUnfolding :: SrcLoc
-> [Var] -- Treat these as in scope
-> CoreExpr
- -> (Maybe Message, Maybe Message) -- (Nothing,_) => OK
-
-lintUnfolding dflags locn vars expr
- | not (dopt Opt_DoCoreLinting dflags)
- = (Nothing, Nothing)
+ -> Maybe Message -- Nothing => OK
- | otherwise
+lintUnfolding locn vars expr
= initL (addLoc (ImportedUnfolding locn) $
addInScopeVars vars $
lintCoreExpr expr)
tyvar_kind = tyVarKind tyvar
argty_kind = typeKind arg_ty
in
- if argty_kind `hasMoreBoxityInfo` tyvar_kind
+ if argty_kind `isSubKind` tyvar_kind
-- Arg type might be boxed for a function with an uncommitted
-- tyvar; notably this is used so that we can give
-- error :: forall a:*. String -> a
lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs)
= addLoc (CaseAlt alt) (
- mapL (\arg -> checkL (not (isUnboxedTupleType (idType arg)))
- (mkUnboxedTupleMsg arg)) args `seqL`
+ mapL (\arg -> checkL (not (isId arg && isUnboxedTupleType (idType arg)))
+ (mkUnboxedTupleMsg arg)) args `seqL`
addInScopeVars args (
type LintM a = [LintLocInfo] -- Locations
-> IdSet -- Local vars in scope
-> Bag Message -- Error messages so far
- -> Bag Message -- Warning messages so far
- -> (Maybe a, Bag Message, Bag Message) -- Result and error/warning messages (if any)
+ -> (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,
- ifNonEmptyBag warns)
- where
- ifNonEmptyBag bag
- | isEmptyBag bag = Nothing
- | otherwise = Just (vcat (punctuate (text "") (bagToList 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)
+addErrL msg loc scope errs = (Nothing, addErr errs msg loc)
addErr :: Bag Message -> Message -> [LintLocInfo] -> Bag Message
--- errors or warnings, actually... they're the same type.
addErr errs_so_far msg locs
= ASSERT( notNull locs )
errs_so_far `snocBag` mk_msg msg
context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1
| otherwise = cxt1
- mk_msg msg = addErrLocHdrLine loc context msg
+ mk_msg msg = mkLocMessage (mkSrcSpan loc 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 (extendVarSetList scope 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