#include "HsVersions.h"
-import IO ( hPutStr, stderr )
+import IO ( hPutStr, hPutStrLn, stderr, stdout )
-import CmdLineOpts ( opt_D_show_passes, opt_DoCoreLinting )
+import CmdLineOpts ( opt_D_show_passes, opt_DoCoreLinting, opt_PprStyle_Debug )
import CoreSyn
-import CoreUtils ( idFreeVars )
+import CoreFVs ( idFreeVars )
+import CoreUtils ( exprOkForSpeculation, coreBindsSize )
import Bag
-import Const ( Con(..), DataCon, conType, conOkForApp, conOkForAlt )
-import Id ( isConstantId, idMustBeINLINEd )
-import Var ( IdOrTyVar, Id, TyVar, idType, tyVarKind, isTyVar )
+import Literal ( Literal, literalType )
+import DataCon ( DataCon, dataConRepType )
+import Id ( mayHaveNoBinding, isDeadBinder )
+import Var ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId )
import VarSet
-import VarEnv ( mkVarEnv )
+import Subst ( mkTyVarSubst, substTy )
import Name ( isLocallyDefined, getSrcLoc )
import PprCore
-import ErrUtils ( doIfSet, dumpIfSet, ghcExit )
+import ErrUtils ( doIfSet, dumpIfSet, ghcExit, Message,
+ ErrMsg, addErrLocHdrLine, pprBagOfErrors )
import PrimRep ( PrimRep(..) )
-import SrcLoc ( SrcLoc )
+import SrcLoc ( SrcLoc, noSrcLoc, isNoSrcLoc )
import Type ( Type, Kind, tyVarsOfType,
- splitFunTy_maybe, mkPiType, mkTyVarTy,
+ splitFunTy_maybe, mkPiType, mkTyVarTy, unUsgTy,
splitForAllTy_maybe, splitTyConApp_maybe,
- isUnLiftedType, typeKind, substTy,
- splitAlgTyConApp_maybe,
+ isUnLiftedType, typeKind,
isUnboxedTupleType,
hasMoreBoxityInfo
)
import TyCon ( TyCon, isPrimTyCon, tyConDataCons )
-import ErrUtils ( ErrMsg )
+import BasicTypes ( RecFlag(..), isNonRec )
import Outputable
-infixr 9 `thenL`, `seqL`, `thenMaybeL`
+infixr 9 `thenL`, `seqL`
\end{code}
%************************************************************************
beginPass :: String -> IO ()
beginPass pass_name
| opt_D_show_passes
- = hPutStr stderr ("*** " ++ pass_name ++ "\n")
+ = hPutStrLn stderr ("*** " ++ pass_name)
| otherwise
= return ()
endPass :: String -> Bool -> [CoreBind] -> IO [CoreBind]
endPass 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))
+ else
+ return ()
+
-- Report verbosely, if required
dumpIfSet dump_flag pass_name
(pprCoreBindings binds)
Just bad_news -> printDump (display bad_news) >>
ghcExit 1
where
- lint_binds [] = returnL ()
- lint_binds (bind:binds)
- = lintCoreBinding bind `thenL` \binders ->
- addInScopeVars binders (lint_binds binds)
+ -- Put all the top-level binders in scope at the start
+ -- This is because transformation rules can bring something
+ -- into use 'unexpectedly'
+ lint_binds binds = addInScopeVars (bindersOfBinds binds) $
+ mapL lint_bind binds
+
+ lint_bind (Rec prs) = mapL (lintSingleBinding Recursive) prs `seqL`
+ returnL ()
+ lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
display bad_news
= vcat [
(it is very painful to catch errors otherwise):
\begin{code}
-lintUnfolding :: SrcLoc -> CoreExpr -> Maybe CoreExpr
-
-lintUnfolding locn expr
- = case
- initL (addLoc (ImportedUnfolding locn) (lintCoreExpr expr))
- of
- Nothing -> Just expr
- Just msg ->
- pprTrace "WARNING: Discarded bad unfolding from interface:\n"
- (vcat [msg,
- ptext SLIT("*** Bad unfolding ***"),
- ppr expr,
- ptext SLIT("*** End unfolding ***")])
- Nothing
+lintUnfolding :: SrcLoc
+ -> [Var] -- Treat these as in scope
+ -> CoreExpr
+ -> Maybe Message -- Nothing => OK
+
+lintUnfolding locn vars expr
+ | not opt_DoCoreLinting
+ = Nothing
+
+ | otherwise
+ = initL (addLoc (ImportedUnfolding locn) $
+ addInScopeVars vars $
+ lintCoreExpr expr)
\end{code}
%************************************************************************
Check a core binding, returning the list of variables bound.
\begin{code}
-lintCoreBinding :: CoreBind -> LintM [Id]
-
-lintCoreBinding (NonRec binder rhs)
- = lintSingleBinding (binder,rhs) `seqL` returnL [binder]
-
-lintCoreBinding (Rec pairs)
- = addInScopeVars binders (
- mapL lintSingleBinding pairs `seqL` returnL binders
- )
- where
- binders = map fst pairs
-
-lintSingleBinding (binder,rhs)
+lintSingleBinding rec_flag (binder,rhs)
= addLoc (RhsOf binder) $
-- Check the rhs
checkTys binder_ty ty (mkRhsMsg binder ty) `seqL`
-- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
- checkL (not (isUnLiftedType binder_ty))
+ 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
\begin{code}
lintCoreExpr :: CoreExpr -> LintM Type
-lintCoreExpr (Var var)
- | isConstantId var = returnL (idType 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
-
- | otherwise = checkIdInScope var `seqL` returnL (idType var)
+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 expr_ty (mkCoerceErr from_ty expr_ty) `seqL`
+ checkTys from_ty (unUsgTy expr_ty) (mkCoerceErr from_ty expr_ty) `seqL`
returnL to_ty
lintCoreExpr (Note other_note expr)
= lintCoreExpr expr
-lintCoreExpr (Let binds body)
- = lintCoreBinding binds `thenL` \binders ->
- if (null binders) then
- lintCoreExpr body -- Can't add a new source location
- else
- addLoc (BodyOfLetRec binders)
- (addInScopeVars binders (lintCoreExpr body))
+lintCoreExpr (Let (NonRec bndr rhs) body)
+ = lintSingleBinding NonRecursive (bndr,rhs) `seqL`
+ addLoc (BodyOfLetRec [bndr])
+ (addInScopeVars [bndr] (lintCoreExpr body))
-lintCoreExpr e@(Con con args)
- = addLoc (AnExpr e) $
- checkL (conOkForApp con) (mkConAppMsg e) `seqL`
- lintCoreArgs (conType con) args
+lintCoreExpr (Let (Rec pairs) body)
+ = addInScopeVars bndrs $
+ mapL (lintSingleBinding Recursive) pairs `seqL`
+ addLoc (BodyOfLetRec bndrs) (lintCoreExpr body)
+ where
+ bndrs = map fst pairs
lintCoreExpr e@(App fun arg)
= lintCoreExpr fun `thenL` \ ty ->
returnL alt_ty)
where
check alt_ty1 alt_ty2 = checkTys alt_ty1 alt_ty2 (mkCaseAltMsg e)
+
+lintCoreExpr e@(Type ty)
+ = addErrL (mkStrangeTyMsg e)
\end{code}
%************************************************************************
-- error :: forall a:*. String -> a
-- and then apply it to both boxed and unboxed types.
then
- returnL (substTy (mkVarEnv [(tyvar,arg_ty)]) body)
+ returnL (substTy (mkTyVarSubst [tyvar] [arg_ty]) body)
else
addErrL (mkKindErrMsg tyvar arg_ty)
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
nopL
else
#endif
+-}
nopL }
hasDefault [] = False
= 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)))
(mkUnboxedTupleMsg arg)) args `seqL`
-- 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 ->
+ 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`
%************************************************************************
\begin{code}
-lintBinder :: IdOrTyVar -> LintM ()
+lintBinder :: Var -> LintM ()
lintBinder v = nopL
-- ToDo: lint its type
\end{code}
\begin{code}
-initL :: LintM a -> Maybe ErrMsg
+initL :: LintM a -> Maybe Message
initL m
= case (m [] emptyVarSet emptyBag) of { (_, errs) ->
if isEmptyBag errs then
Nothing
else
- Just (vcat (bagToList errs))
+ Just (pprBagOfErrors errs)
}
returnL :: a -> LintM a
\end{code}
\begin{code}
-checkL :: Bool -> ErrMsg -> LintM ()
+checkL :: Bool -> Message -> LintM ()
checkL True msg loc scope errs = (Nothing, errs)
checkL False msg loc scope errs = (Nothing, addErr errs msg loc)
-addErrL :: ErrMsg -> LintM a
+addErrL :: Message -> LintM a
addErrL msg loc scope errs = (Nothing, addErr errs msg loc)
-addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg
+addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg
addErr errs_so_far msg locs
= ASSERT (not (null locs))
- errs_so_far `snocBag` (hang (pprLoc (head locs)) 4 msg)
+ errs_so_far `snocBag` mk_msg msg
+ where
+ (loc, cxt1) = dumpLoc (head locs)
+ cxts = [snd (dumpLoc loc) | loc <- 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
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 loc_msg id loc scope errs
- | isLocallyDefined id
- && not (id `elemVarSet` scope)
- && not (idMustBeINLINEd id) -- Constructors and dict selectors
- -- don't have bindings,
- -- just MustInline prags
- = (Nothing, addErr errs (hsep [ppr id, loc_msg]) loc)
+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
+ = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc)
| otherwise
= (Nothing,errs)
-checkTys :: Type -> Type -> ErrMsg -> LintM ()
+checkTys :: Type -> Type -> Message -> LintM ()
checkTys ty1 ty2 msg loc scope errs
| ty1 == ty2 = (Nothing, errs)
| otherwise = (Nothing, addErr errs msg loc)
%************************************************************************
\begin{code}
-pprLoc (RhsOf v)
- = ppr (getSrcLoc v) <> colon <+>
- brackets (ptext SLIT("RHS of") <+> pp_binders [v])
+dumpLoc (RhsOf v)
+ = (getSrcLoc v, brackets (ptext SLIT("RHS of") <+> pp_binders [v]))
-pprLoc (LambdaBodyOf b)
- = ppr (getSrcLoc b) <> colon <+>
- brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b)
+dumpLoc (LambdaBodyOf b)
+ = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b))
-pprLoc (BodyOfLetRec bs)
- = ppr (getSrcLoc (head bs)) <> colon <+>
- brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs)
+dumpLoc (BodyOfLetRec bs)
+ = ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs))
-pprLoc (AnExpr e)
- = text "In the expression:" <+> ppr e
+dumpLoc (AnExpr e)
+ = (noSrcLoc, text "In the expression:" <+> ppr e)
-pprLoc (CaseAlt (con, args, rhs))
- = text "In a case pattern:" <+> parens (ppr con <+> ppr args)
+dumpLoc (CaseAlt (con, args, rhs))
+ = (noSrcLoc, text "In a case pattern:" <+> parens (ppr con <+> ppr args))
-pprLoc (ImportedUnfolding locn)
- = ppr locn <> colon <+>
- brackets (ptext SLIT("in an imported unfolding"))
+dumpLoc (ImportedUnfolding locn)
+ = (locn, brackets (ptext SLIT("in an imported unfolding")))
pp_binders :: [Id] -> SDoc
pp_binders bs = sep (punctuate comma (map pp_binder bs))
pp_binder :: Id -> SDoc
-pp_binder b = hsep [ppr b, text "::", ppr (idType b)]
+pp_binder b = hsep [ppr b, dcolon, ppr (idType b)]
\end{code}
\begin{code}
------------------------------------------------------
-- Messages for case expressions
-mkConAppMsg :: CoreExpr -> ErrMsg
-mkConAppMsg e
- = hang (text "Application of newtype constructor:")
- 4 (ppr e)
-
-mkConAltMsg :: Con -> ErrMsg
-mkConAltMsg con
- = text "PrimOp in case pattern:" <+> ppr con
-
-mkNullAltsMsg :: CoreExpr -> ErrMsg
+mkNullAltsMsg :: CoreExpr -> Message
mkNullAltsMsg e
= hang (text "Case expression with no alternatives:")
4 (ppr e)
-mkDefaultArgsMsg :: [IdOrTyVar] -> ErrMsg
+mkDefaultArgsMsg :: [Var] -> Message
mkDefaultArgsMsg args
= hang (text "DEFAULT case with binders")
4 (ppr args)
-mkCaseAltMsg :: CoreExpr -> ErrMsg
+mkCaseAltMsg :: CoreExpr -> Message
mkCaseAltMsg e
= hang (text "Type of case alternatives not the same:")
4 (ppr e)
-mkScrutMsg :: Id -> Type -> ErrMsg
+mkScrutMsg :: Id -> Type -> Message
mkScrutMsg var scrut_ty
= vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
text "Result binder type:" <+> ppr (idType var),
text "Scrutinee type:" <+> ppr scrut_ty]
-badAltsMsg :: CoreExpr -> ErrMsg
+badAltsMsg :: CoreExpr -> Message
badAltsMsg e
= hang (text "Case statement scrutinee is not a data type:")
4 (ppr e)
-nonExhaustiveAltsMsg :: CoreExpr -> ErrMsg
+nonExhaustiveAltsMsg :: CoreExpr -> Message
nonExhaustiveAltsMsg e
= hang (text "Case expression with non-exhaustive alternatives")
4 (ppr e)
-mkBadPatMsg :: Type -> Type -> ErrMsg
+mkBadPatMsg :: Type -> Type -> Message
mkBadPatMsg con_result_ty scrut_ty
= vcat [
text "In a case alternative, pattern result type doesn't match scrutinee type:",
------------------------------------------------------
-- Other error messages
-mkAppMsg :: Type -> Type -> ErrMsg
mkAppMsg fun arg
= 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)]
-mkKindErrMsg :: TyVar -> Type -> ErrMsg
+mkKindErrMsg :: TyVar -> Type -> Message
mkKindErrMsg tyvar arg_ty
= vcat [ptext SLIT("Kinds don't match in type application:"),
hang (ptext SLIT("Type variable:"))
- 4 (ppr tyvar <+> ptext SLIT("::") <+> ppr (tyVarKind tyvar)),
+ 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
hang (ptext SLIT("Arg type:"))
- 4 (ppr arg_ty <+> ptext SLIT("::") <+> ppr (typeKind arg_ty))]
+ 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
-mkTyAppMsg :: Type -> Type -> ErrMsg
+mkTyAppMsg :: Type -> Type -> Message
mkTyAppMsg ty arg_ty
= vcat [text "Illegal type application:",
hang (ptext SLIT("Exp type:"))
- 4 (ppr ty <+> ptext SLIT("::") <+> ppr (typeKind ty)),
+ 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
hang (ptext SLIT("Arg type:"))
- 4 (ppr arg_ty <+> ptext SLIT("::") <+> ppr (typeKind arg_ty))]
+ 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
-mkRhsMsg :: Id -> Type -> ErrMsg
+mkRhsMsg :: Id -> Type -> Message
mkRhsMsg binder ty
= vcat
[hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
hsep [ptext SLIT("Rhs type:"), ppr ty]]
-mkRhsPrimMsg :: Id -> CoreExpr -> ErrMsg
+mkRhsPrimMsg :: Id -> CoreExpr -> Message
mkRhsPrimMsg binder rhs
= vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
ppr binder],
hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
]
-mkUnboxedTupleMsg :: Id -> ErrMsg
+mkUnboxedTupleMsg :: Id -> Message
mkUnboxedTupleMsg binder
= vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder],
hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]]
ptext SLIT("From-type:") <+> ppr from_ty,
ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
]
+
+mkStrangeTyMsg e
+ = ptext SLIT("Type where expression expected:") <+> ppr e
\end{code}
projects / ghc-hetmet.git / blobdiff