%
% (c) The GRASP/AQUA Project, Glasgow University, 19931998
%
\section[StgLint]{A ``lint'' pass to check for Stg correctness}
\begin{code}
module StgLint ( lintStgBindings ) where
import StgSyn
import Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
import Id ( Id, idType, isLocalId )
import VarSet
import DataCon ( DataCon, dataConInstArgTys, dataConRepType )
import CoreSyn ( AltCon(..) )
import PrimOp ( primOpType )
import Literal ( literalType )
import Maybes
import Name ( getSrcLoc )
import ErrUtils ( Message, mkLocMessage )
import TypeRep
import Type ( mkFunTys, splitFunTy_maybe, splitTyConApp_maybe,
isUnLiftedType, isTyVarTy, dropForAlls
)
import TyCon ( isAlgTyCon, isNewTyCon, tyConDataCons )
import Util ( zipEqual, equalLength )
import SrcLoc
import Outputable
import FastString
import Control.Monad
\end{code}
Checks for
(a) *some* type errors
(b) locallydefined variables used but not defined
Note: unless dverbosestg is on, display of lint errors will result
in "panic: bOGUS_LVs".
WARNING:
~~~~~~~~
This module has suffered bitrot; it is likely to yield lint errors
for Stg code that is currently perfectly acceptable for code
generation. Solution: don't use it! (KSW 200005).
%************************************************************************
%* *
\subsection{``lint'' for various constructs}
%* *
%************************************************************************
@lintStgBindings@ is the toplevel interface function.
\begin{code}
lintStgBindings :: String -> [StgBinding] -> [StgBinding]
lintStgBindings whodunnit binds
=
case (initL (lint_binds binds)) of
Nothing -> binds
Just msg -> pprPanic "" (vcat [
ptext (sLit "*** Stg Lint ErrMsgs: in") <+>
text whodunnit <+> ptext (sLit "***"),
msg,
ptext (sLit "*** Offending Program ***"),
pprStgBindings binds,
ptext (sLit "*** End of Offense ***")])
where
lint_binds :: [StgBinding] -> LintM ()
lint_binds [] = return ()
lint_binds (bind:binds) = do
binders <- lintStgBinds bind
addInScopeVars binders $
lint_binds binds
\end{code}
\begin{code}
lintStgArg :: StgArg -> LintM (Maybe Type)
lintStgArg (StgLitArg lit) = return (Just (literalType lit))
lintStgArg (StgVarArg v) = lintStgVar v
lintStgArg a = pprPanic "lintStgArg" (ppr a)
lintStgVar :: Id -> LintM (Maybe Kind)
lintStgVar v = do checkInScope v
return (Just (idType v))
\end{code}
\begin{code}
lintStgBinds :: StgBinding -> LintM [Id]
lintStgBinds (StgNonRec binder rhs) = do
lint_binds_help (binder,rhs)
return [binder]
lintStgBinds (StgRec pairs)
= addInScopeVars binders $ do
mapM_ lint_binds_help pairs
return binders
where
binders = [b | (b,_) <- pairs]
lint_binds_help :: (Id, StgRhs) -> LintM ()
lint_binds_help (binder, rhs)
= addLoc (RhsOf binder) $ do
maybe_rhs_ty <- lintStgRhs rhs
checkL (not (isUnLiftedType binder_ty))
(mkUnLiftedTyMsg binder rhs)
case maybe_rhs_ty of
Nothing -> return ()
Just rhs_ty -> checkTys binder_ty
rhs_ty
(mkRhsMsg binder rhs_ty)
return ()
where
binder_ty = idType binder
\end{code}
\begin{code}
lintStgRhs :: StgRhs -> LintM (Maybe Type)
lintStgRhs (StgRhsClosure _ _ _ _ _ [] expr)
= lintStgExpr expr
lintStgRhs (StgRhsClosure _ _ _ _ _ binders expr)
= addLoc (LambdaBodyOf binders) $
addInScopeVars binders $ runMaybeT $ do
body_ty <- MaybeT $ lintStgExpr expr
return (mkFunTys (map idType binders) body_ty)
lintStgRhs (StgRhsCon _ con args) = runMaybeT $ do
arg_tys <- mapM (MaybeT . lintStgArg) args
MaybeT $ checkFunApp con_ty arg_tys (mkRhsConMsg con_ty arg_tys)
where
con_ty = dataConRepType con
\end{code}
\begin{code}
lintStgExpr :: StgExpr -> LintM (Maybe Type)
lintStgExpr (StgLit l) = return (Just (literalType l))
lintStgExpr e@(StgApp fun args) = runMaybeT $ do
fun_ty <- MaybeT $ lintStgVar fun
arg_tys <- mapM (MaybeT . lintStgArg) args
MaybeT $ checkFunApp fun_ty arg_tys (mkFunAppMsg fun_ty arg_tys e)
lintStgExpr e@(StgConApp con args) = runMaybeT $ do
arg_tys <- mapM (MaybeT . lintStgArg) args
MaybeT $ checkFunApp con_ty arg_tys (mkFunAppMsg con_ty arg_tys e)
where
con_ty = dataConRepType con
lintStgExpr (StgOpApp (StgFCallOp _ _) args res_ty) = runMaybeT $ do
_maybe_arg_tys <- mapM (MaybeT . lintStgArg) args
return res_ty
lintStgExpr e@(StgOpApp (StgPrimOp op) args _) = runMaybeT $ do
arg_tys <- mapM (MaybeT . lintStgArg) args
MaybeT $ checkFunApp op_ty arg_tys (mkFunAppMsg op_ty arg_tys e)
where
op_ty = primOpType op
lintStgExpr (StgLam _ bndrs _) = do
addErrL (ptext (sLit "Unexpected StgLam") <+> ppr bndrs)
return Nothing
lintStgExpr (StgLet binds body) = do
binders <- lintStgBinds binds
addLoc (BodyOfLetRec binders) $
addInScopeVars binders $
lintStgExpr body
lintStgExpr (StgLetNoEscape _ _ binds body) = do
binders <- lintStgBinds binds
addLoc (BodyOfLetRec binders) $
addInScopeVars binders $
lintStgExpr body
lintStgExpr (StgSCC _ expr) = lintStgExpr expr
lintStgExpr e@(StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do
_ <- MaybeT $ lintStgExpr scrut
MaybeT $ liftM Just $
case alts_type of
AlgAlt tc -> check_bndr tc
PrimAlt tc -> check_bndr tc
UbxTupAlt tc -> check_bndr tc
PolyAlt -> return ()
MaybeT $ do
case scrut of
StgApp _ _ -> return ()
StgConApp _ _ -> return ()
StgOpApp _ _ _ -> return ()
_ -> addErrL (mkCaseOfCaseMsg e)
addInScopeVars [bndr] $
lintStgAlts alts scrut_ty
where
scrut_ty = idType bndr
bad_bndr = mkDefltMsg bndr
check_bndr tc = case splitTyConApp_maybe scrut_ty of
Just (bndr_tc, _) -> checkL (tc == bndr_tc) bad_bndr
Nothing -> addErrL bad_bndr
lintStgExpr e = pprPanic "lintStgExpr" (ppr e)
lintStgAlts :: [StgAlt]
-> Type
-> LintM (Maybe Type)
lintStgAlts alts scrut_ty = do
maybe_result_tys <- mapM (lintAlt scrut_ty) alts
case catMaybes (maybe_result_tys) of
[] -> return Nothing
(first_ty:tys) -> do mapM_ check tys
return (Just first_ty)
where
check ty = checkTys first_ty ty (mkCaseAltMsg alts)
lintAlt :: Type -> (AltCon, [Id], [Bool], StgExpr) -> LintM (Maybe Type)
lintAlt _ (DEFAULT, _, _, rhs)
= lintStgExpr rhs
lintAlt scrut_ty (LitAlt lit, _, _, rhs) = do
checkTys (literalType lit) scrut_ty (mkAltMsg1 scrut_ty)
lintStgExpr rhs
lintAlt scrut_ty (DataAlt con, args, _, rhs) = do
case splitTyConApp_maybe scrut_ty of
Just (tycon, tys_applied) | isAlgTyCon tycon &&
not (isNewTyCon tycon) -> do
let
cons = tyConDataCons tycon
arg_tys = dataConInstArgTys con tys_applied
checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con)
checkL (equalLength arg_tys args) (mkAlgAltMsg3 con args)
mapM_ check (zipEqual "lintAlgAlt:stg" arg_tys args)
return ()
_ ->
addErrL (mkAltMsg1 scrut_ty)
addInScopeVars args $
lintStgExpr rhs
where
check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
elem _ [] = False
elem x (y:ys) = x==y || elem x ys
\end{code}
%************************************************************************
%* *
\subsection[lintmonad]{The Lint monad}
%* *
%************************************************************************
\begin{code}
newtype LintM a = LintM
{ unLintM :: [LintLocInfo]
-> IdSet
-> Bag Message
-> (a, Bag Message)
}
data LintLocInfo
= RhsOf Id
| LambdaBodyOf [Id]
| BodyOfLetRec [Id]
dumpLoc :: LintLocInfo -> (SrcSpan, SDoc)
dumpLoc (RhsOf v) =
(srcLocSpan (getSrcLoc v), ptext (sLit " [RHS of ") <> pp_binders [v] <> char ']' )
dumpLoc (LambdaBodyOf bs) =
(srcLocSpan (getSrcLoc (head bs)), ptext (sLit " [in body of lambda with binders ") <> pp_binders bs <> char ']' )
dumpLoc (BodyOfLetRec bs) =
(srcLocSpan (getSrcLoc (head bs)), ptext (sLit " [in body of letrec with binders ") <> pp_binders bs <> char ']' )
pp_binders :: [Id] -> SDoc
pp_binders bs
= sep (punctuate comma (map pp_binder bs))
where
pp_binder b
= hsep [ppr b, dcolon, ppr (idType b)]
\end{code}
\begin{code}
initL :: LintM a -> Maybe Message
initL (LintM m)
= case (m [] emptyVarSet emptyBag) of { (_, errs) ->
if isEmptyBag errs then
Nothing
else
Just (vcat (punctuate (text "") (bagToList errs)))
}
instance Monad LintM where
return a = LintM $ \_loc _scope errs -> (a, errs)
(>>=) = thenL
(>>) = thenL_
thenL :: LintM a -> (a -> LintM b) -> LintM b
thenL m k = LintM $ \loc scope errs
-> case unLintM m loc scope errs of
(r, errs') -> unLintM (k r) loc scope errs'
thenL_ :: LintM a -> LintM b -> LintM b
thenL_ m k = LintM $ \loc scope errs
-> case unLintM m loc scope errs of
(_, errs') -> unLintM k loc scope errs'
\end{code}
\begin{code}
checkL :: Bool -> Message -> LintM ()
checkL True _ = return ()
checkL False msg = addErrL msg
addErrL :: Message -> LintM ()
addErrL msg = LintM $ \loc _scope errs -> ((), addErr errs msg loc)
addErr :: Bag Message -> Message -> [LintLocInfo] -> Bag Message
addErr errs_so_far msg locs
= errs_so_far `snocBag` mk_msg locs
where
mk_msg (loc:_) = let (l,hdr) = dumpLoc loc
in mkLocMessage l (hdr $$ msg)
mk_msg [] = msg
addLoc :: LintLocInfo -> LintM a -> LintM a
addLoc extra_loc m = LintM $ \loc scope errs
-> unLintM m (extra_loc:loc) scope errs
addInScopeVars :: [Id] -> LintM a -> LintM a
addInScopeVars ids m = LintM $ \loc scope errs
->
let
new_set = mkVarSet ids
in
unLintM m loc (scope `unionVarSet` new_set) errs
\end{code}
Checking function applications: we only check that the type has the
right *number* of arrows, we don't actually compare the types. This
is because we can't expect the types to be equal the type
applications and type lambdas that we use to calculate accurate types
have long since disappeared.
\begin{code}
checkFunApp :: Type
-> [Type]
-> Message
-> LintM (Maybe Type)
checkFunApp fun_ty arg_tys msg = LintM checkFunApp'
where
checkFunApp' loc _scope errs
= cfa fun_ty arg_tys
where
cfa fun_ty []
= (Just fun_ty, errs)
cfa fun_ty (_:arg_tys)
| Just (_arg_ty, res_ty) <- splitFunTy_maybe (dropForAlls fun_ty)
= cfa res_ty arg_tys
| isTyVarTy fun_ty
= (Just fun_ty, errs)
| otherwise
= (Nothing, addErr errs msg loc)
\end{code}
\begin{code}
checkInScope :: Id -> LintM ()
checkInScope id = LintM $ \loc scope errs
-> if isLocalId id && not (id `elemVarSet` scope) then
((), addErr errs (hsep [ppr id, ptext (sLit "is out of scope")]) loc)
else
((), errs)
checkTys :: Type -> Type -> Message -> LintM ()
checkTys _ty1 _ty2 _msg = LintM $ \_loc _scope errs
->
((), errs)
\end{code}
\begin{code}
mkCaseAltMsg :: [StgAlt] -> Message
mkCaseAltMsg _alts
= ($$) (text "In some case alternatives, type of alternatives not all same:")
(empty)
mkDefltMsg :: Id -> Message
mkDefltMsg _bndr
= ($$) (ptext (sLit "Binder of a case expression doesn't match type of scrutinee:"))
(panic "mkDefltMsg")
mkFunAppMsg :: Type -> [Type] -> StgExpr -> Message
mkFunAppMsg fun_ty arg_tys expr
= vcat [text "In a function application, function type doesn't match arg types:",
hang (ptext (sLit "Function type:")) 4 (ppr fun_ty),
hang (ptext (sLit "Arg types:")) 4 (vcat (map (ppr) arg_tys)),
hang (ptext (sLit "Expression:")) 4 (ppr expr)]
mkRhsConMsg :: Type -> [Type] -> Message
mkRhsConMsg fun_ty arg_tys
= vcat [text "In a RHS constructor application, con type doesn't match arg types:",
hang (ptext (sLit "Constructor type:")) 4 (ppr fun_ty),
hang (ptext (sLit "Arg types:")) 4 (vcat (map (ppr) arg_tys))]
mkAltMsg1 :: Type -> Message
mkAltMsg1 ty
= ($$) (text "In a case expression, type of scrutinee does not match patterns")
(ppr ty)
mkAlgAltMsg2 :: Type -> DataCon -> Message
mkAlgAltMsg2 ty con
= vcat [
text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
ppr ty,
ppr con
]
mkAlgAltMsg3 :: DataCon -> [Id] -> Message
mkAlgAltMsg3 con alts
= vcat [
text "In some algebraic case alternative, number of arguments doesn't match constructor:",
ppr con,
ppr alts
]
mkAlgAltMsg4 :: Type -> Id -> Message
mkAlgAltMsg4 ty arg
= vcat [
text "In some algebraic case alternative, type of argument doesn't match data constructor:",
ppr ty,
ppr arg
]
mkCaseOfCaseMsg :: StgExpr -> Message
mkCaseOfCaseMsg e
= text "Case of non-tail-call:" $$ ppr e
mkRhsMsg :: Id -> Type -> Message
mkRhsMsg binder ty
= vcat [hsep [ptext (sLit "The type of this binder doesn't match the type of its RHS:"),
ppr binder],
hsep [ptext (sLit "Binder's type:"), ppr (idType binder)],
hsep [ptext (sLit "Rhs type:"), ppr ty]
]
mkUnLiftedTyMsg :: Id -> StgRhs -> SDoc
mkUnLiftedTyMsg binder rhs
= (ptext (sLit "Let(rec) binder") <+> quotes (ppr binder) <+>
ptext (sLit "has unlifted type") <+> quotes (ppr (idType binder)))
$$
(ptext (sLit "RHS:") <+> ppr rhs)
\end{code}