#include "HsVersions.h"
-import NewDemand
+import Demand
import CoreSyn
import CoreFVs
import CoreUtils
import StaticFlags
import ListSetOps
import PrelNames
-import DynFlags
import Outputable
import FastString
import Util
\begin{code}
-lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()
-
-lintCoreBindings dflags _whoDunnit _binds
- | not (dopt Opt_DoCoreLinting dflags)
- = return ()
-
-lintCoreBindings dflags whoDunnit binds
- | isEmptyBag errs
- = do { showPass dflags ("Core Linted result of " ++ whoDunnit)
- ; unless (isEmptyBag warns || opt_NoDebugOutput) $ printDump $
- (banner "warnings" $$ displayMessageBag warns)
- ; return () }
-
- | otherwise
- = do { printDump (vcat [ banner "errors", displayMessageBag errs
- , ptext (sLit "*** Offending Program ***")
- , pprCoreBindings binds
- , ptext (sLit "*** End of Offense ***") ])
-
- ; ghcExit dflags 1 }
+lintCoreBindings :: [CoreBind] -> (Bag Message, Bag Message)
+-- Returns (warnings, errors)
+lintCoreBindings binds
+ = initL (lint_binds binds)
where
- (warns, errs) = initL (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_bind (Rec prs) = mapM_ (lintSingleBinding TopLevel Recursive) prs
lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs)
-
- banner string = ptext (sLit "*** Core Lint") <+> text string
- <+> ptext (sLit ": in result of") <+> text whoDunnit
- <+> ptext (sLit "***")
-
-displayMessageBag :: Bag Message -> SDoc
-displayMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))
\end{code}
%************************************************************************
lintUnfolding locn vars expr
| isEmptyBag errs = Nothing
- | otherwise = Just (displayMessageBag errs)
+ | otherwise = Just (pprMessageBag errs)
where
(_warns, errs) = initL (addLoc (ImportedUnfolding locn) $
addInScopeVars vars $
-- the unfolding is a SimplifiableCoreExpr. Give up for now.
where
binder_ty = idType binder
- maybeDmdTy = idNewStrictness_maybe binder
+ maybeDmdTy = idStrictness_maybe binder
bndr_vars = varSetElems (idFreeVars binder)
lintBinder var | isId var = lintIdBndr var $ \_ -> (return ())
| otherwise = return ()
subtype of the required type, as one would expect.
\begin{code}
-lintCoreArgs :: OutType -> [CoreArg] -> LintM OutType
-lintCoreArg :: OutType -> CoreArg -> LintM OutType
--- First argument has already had substitution applied to it
-\end{code}
-
-\begin{code}
-lintCoreArgs ty [] = return ty
-lintCoreArgs ty (a : args) =
- do { res <- lintCoreArg ty a
- ; lintCoreArgs res args }
-
+lintCoreArg :: OutType -> CoreArg -> LintM OutType
lintCoreArg fun_ty (Type arg_ty)
- | Just (tyvar,body) <- splitForAllTy_maybe fun_ty
= do { arg_ty' <- applySubst arg_ty
- ; checkKinds tyvar arg_ty'
+ ; lintTyApp fun_ty arg_ty' }
+
+lintCoreArg fun_ty arg
+ = do { arg_ty <- lintCoreExpr arg
+ ; lintValApp arg fun_ty arg_ty }
+
+-----------------
+lintAltBinders :: OutType -- Scrutinee type
+ -> OutType -- Constructor type
+ -> [OutVar] -- Binders
+ -> LintM ()
+lintAltBinders scrut_ty con_ty []
+ = checkTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty)
+lintAltBinders scrut_ty con_ty (bndr:bndrs)
+ | isTyVar bndr
+ = do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr)
+ ; lintAltBinders scrut_ty con_ty' bndrs }
+ | otherwise
+ = do { con_ty' <- lintValApp (Var bndr) con_ty (idType bndr)
+ ; lintAltBinders scrut_ty con_ty' bndrs }
+
+-----------------
+lintTyApp :: OutType -> OutType -> LintM OutType
+lintTyApp fun_ty arg_ty
+ | Just (tyvar,body_ty) <- splitForAllTy_maybe fun_ty
+ = do { checkKinds tyvar arg_ty
; if isCoVar tyvar then
- return body -- Co-vars don't appear in body!
+ return body_ty -- Co-vars don't appear in body_ty!
else
- return (substTyWith [tyvar] [arg_ty'] body) }
+ return (substTyWith [tyvar] [arg_ty] body_ty) }
| otherwise
= failWithL (mkTyAppMsg fun_ty arg_ty)
-
-lintCoreArg fun_ty arg
- -- Make sure function type matches argument
- = do { arg_ty <- lintCoreExpr arg
- ; let err1 = mkAppMsg fun_ty arg_ty arg
- err2 = mkNonFunAppMsg fun_ty arg_ty arg
- ; case splitFunTy_maybe fun_ty of
- Just (arg,res) ->
- do { checkTys arg arg_ty err1
- ; return res }
- _ -> failWithL err2 }
+
+-----------------
+lintValApp :: CoreExpr -> OutType -> OutType -> LintM OutType
+lintValApp arg fun_ty arg_ty
+ | Just (arg,res) <- splitFunTy_maybe fun_ty
+ = do { checkTys arg arg_ty err1
+ ; return res }
+ | otherwise
+ = failWithL err2
+ where
+ err1 = mkAppMsg fun_ty arg_ty arg
+ err2 = mkNonFunAppMsg fun_ty arg_ty arg
\end{code}
\begin{code}
lit_ty = literalType lit
lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
- | isNewTyCon (dataConTyCon con) = addErrL (mkNewTyDataConAltMsg scrut_ty alt)
+ | isNewTyCon (dataConTyCon con)
+ = addErrL (mkNewTyDataConAltMsg scrut_ty alt)
| Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty
= addLoc (CaseAlt alt) $ do
{ -- First instantiate the universally quantified
; let con_payload_ty = applyTys (dataConRepType con) tycon_arg_tys
-- And now bring the new binders into scope
- ; lintBinders args $ \ args -> do
- { addLoc (CasePat alt) $ do
- { -- Check the pattern
- -- 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.
- -- NB: relies on existential type args coming *after*
- -- ordinary type args
- ; con_result_ty <- lintCoreArgs con_payload_ty (varsToCoreExprs args)
- ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
- }
- -- Check the RHS
+ ; lintBinders args $ \ args' -> do
+ { addLoc (CasePat alt) (lintAltBinders scrut_ty con_payload_ty args')
; checkAltExpr rhs alt_ty } }
| otherwise -- Scrut-ty is wrong shape
; return (FunTy s1 s2, FunTy t1 t2) }
lintCoercion ty@(TyConApp tc tys)
- | Just (ar, rule) <- isCoercionTyCon_maybe tc
+ | Just (ar, desc) <- isCoercionTyCon_maybe tc
= do { unless (tys `lengthAtLeast` ar) (badCo ty)
- ; (s,t) <- rule lintType lintCoercion
- True (take ar tys)
+ ; (s,t) <- lintCoTyConApp ty desc (take ar tys)
; (ss,ts) <- mapAndUnzipM lintCoercion (drop ar tys)
; check_co_app ty (typeKind s) ss
; return (mkAppTys s ss, mkAppTys t ts) }
badCo :: Coercion -> LintM a
badCo co = failWithL (hang (ptext (sLit "Ill-kinded coercion term:")) 2 (ppr co))
+---------------
+lintCoTyConApp :: Coercion -> CoTyConDesc -> [Coercion] -> LintM (Type,Type)
+-- Always called with correct number of coercion arguments
+-- First arg is just for error message
+lintCoTyConApp _ CoLeft (co:_) = lintLR fst co
+lintCoTyConApp _ CoRight (co:_) = lintLR snd co
+lintCoTyConApp _ CoCsel1 (co:_) = lintCsel fstOf3 co
+lintCoTyConApp _ CoCsel2 (co:_) = lintCsel sndOf3 co
+lintCoTyConApp _ CoCselR (co:_) = lintCsel thirdOf3 co
+
+lintCoTyConApp _ CoSym (co:_)
+ = do { (ty1,ty2) <- lintCoercion co
+ ; return (ty2,ty1) }
+
+lintCoTyConApp co CoTrans (co1:co2:_)
+ = do { (ty1a, ty1b) <- lintCoercion co1
+ ; (ty2a, ty2b) <- lintCoercion co2
+ ; checkL (ty1b `coreEqType` ty2a)
+ (hang (ptext (sLit "Trans coercion mis-match:") <+> ppr co)
+ 2 (vcat [ppr ty1a, ppr ty1b, ppr ty2a, ppr ty2b]))
+ ; return (ty1a, ty2b) }
+
+lintCoTyConApp _ CoInst (co:arg_ty:_)
+ = do { co_tys <- lintCoercion co
+ ; arg_kind <- lintType arg_ty
+ ; case decompInst_maybe co_tys of
+ Just ((tv1,tv2), (ty1,ty2))
+ | arg_kind `isSubKind` tyVarKind tv1
+ -> return (substTyWith [tv1] [arg_ty] ty1,
+ substTyWith [tv2] [arg_ty] ty2)
+ | otherwise
+ -> failWithL (ptext (sLit "Kind mis-match in inst coercion"))
+ Nothing -> failWithL (ptext (sLit "Bad argument of inst")) }
+
+lintCoTyConApp _ (CoAxiom { co_ax_tvs = tvs
+ , co_ax_lhs = lhs_ty, co_ax_rhs = rhs_ty }) cos
+ = do { (tys1, tys2) <- mapAndUnzipM lintCoercion cos
+ ; sequence_ (zipWith checkKinds tvs tys1)
+ ; return (substTyWith tvs tys1 lhs_ty,
+ substTyWith tvs tys2 rhs_ty) }
+
+lintCoTyConApp _ CoUnsafe (ty1:ty2:_)
+ = do { _ <- lintType ty1
+ ; _ <- lintType ty2 -- Ignore kinds; it's unsafe!
+ ; return (ty1,ty2) }
+
+lintCoTyConApp _ _ _ = panic "lintCoTyConApp" -- Called with wrong number of coercion args
+
+----------
+lintLR :: (forall a. (a,a)->a) -> Coercion -> LintM (Type,Type)
+lintLR sel co
+ = do { (ty1,ty2) <- lintCoercion co
+ ; case decompLR_maybe (ty1,ty2) of
+ Just res -> return (sel res)
+ Nothing -> failWithL (ptext (sLit "Bad argument of left/right")) }
+
+----------
+lintCsel :: (forall a. (a,a,a)->a) -> Coercion -> LintM (Type,Type)
+lintCsel sel co
+ = do { (ty1,ty2) <- lintCoercion co
+ ; case decompCsel_maybe (ty1,ty2) of
+ Just res -> return (sel res)
+ Nothing -> failWithL (ptext (sLit "Bad argument of csel")) }
+
-------------------
lintType :: OutType -> LintM Kind
lintType (TyVarTy tv)
; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst))
(hsep [ppr var, loc_msg]) }
-checkTys :: Type -> Type -> Message -> LintM ()
+checkTys :: OutType -> OutType -> Message -> LintM ()
-- check ty2 is subtype of ty1 (ie, has same structure but usage
-- annotations need only be consistent, not equal)
-- Assumes ty1,ty2 are have alrady had the substitution applied
mkStrictMsg binder
= vcat [hsep [ptext (sLit "Recursive or top-level binder has strict demand info:"),
ppr binder],
- hsep [ptext (sLit "Binder's demand info:"), ppr (idNewDemandInfo binder)]
+ hsep [ptext (sLit "Binder's demand info:"), ppr (idDemandInfo binder)]
]
mkArityMsg :: Id -> Message
hsep [ptext (sLit "Binder's strictness signature:"), ppr dmd_ty]
]
- where (StrictSig dmd_ty) = idNewStrictness binder
+ where (StrictSig dmd_ty) = idStrictness binder
mkUnboxedTupleMsg :: Id -> Message
mkUnboxedTupleMsg binder