\section[StgLint]{A ``lint'' pass to check for Stg correctness}
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module StgLint ( lintStgBindings ) where
-#include "HsVersions.h"
-
import StgSyn
import Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
import Maybes
import Name ( getSrcLoc )
import ErrUtils ( Message, mkLocMessage )
-import Type ( mkFunTys, splitFunTys, splitTyConApp_maybe,
- isUnLiftedType, isTyVarTy, dropForAlls, Type
+import TypeRep
+import Type ( mkFunTys, splitFunTy_maybe, splitTyConApp_maybe,
+ isUnLiftedType, isTyVarTy, dropForAlls
)
import TyCon ( isAlgTyCon, isNewTyCon, tyConDataCons )
import Util ( zipEqual, equalLength )
-import SrcLoc ( srcLocSpan )
+import SrcLoc
import Outputable
+import FastString
import Control.Monad
\end{code}
case (initL (lint_binds binds)) of
Nothing -> binds
Just msg -> pprPanic "" (vcat [
- ptext SLIT("*** Stg Lint ErrMsgs: in") <+>
- text whodunnit <+> ptext SLIT("***"),
+ ptext (sLit "*** Stg Lint ErrMsgs: in") <+>
+ text whodunnit <+> ptext (sLit "***"),
msg,
- ptext SLIT("*** Offending Program ***"),
+ ptext (sLit "*** Offending Program ***"),
pprStgBindings binds,
- ptext SLIT("*** End of Offense ***")])
+ ptext (sLit "*** End of Offense ***")])
where
lint_binds :: [StgBinding] -> LintM ()
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}
where
binders = [b | (b,_) <- pairs]
+lint_binds_help :: (Id, StgRhs) -> LintM ()
lint_binds_help (binder, rhs)
= addLoc (RhsOf binder) $ do
-- Check the rhs
where
con_ty = dataConRepType con
-lintStgExpr e@(StgOpApp (StgFCallOp _ _) args res_ty) = runMaybeT $ do
+lintStgExpr (StgOpApp (StgFCallOp _ _) args res_ty) = runMaybeT $ do
-- We don't have enough type information to check
-- the application; ToDo
- maybe_arg_tys <- mapM (MaybeT . lintStgArg) args
+ _maybe_arg_tys <- mapM (MaybeT . lintStgArg) args
return res_ty
lintStgExpr e@(StgOpApp (StgPrimOp op) args _) = runMaybeT $ do
op_ty = primOpType op
lintStgExpr (StgLam _ bndrs _) = do
- addErrL (ptext SLIT("Unexpected StgLam") <+> ppr bndrs)
+ addErrL (ptext (sLit "Unexpected StgLam") <+> ppr bndrs)
return Nothing
lintStgExpr (StgLet binds body) = do
lintStgExpr (StgSCC _ expr) = lintStgExpr expr
lintStgExpr e@(StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do
- MaybeT $ lintStgExpr scrut
+ _ <- MaybeT $ lintStgExpr scrut
MaybeT $ liftM Just $
case alts_type of
UbxTupAlt tc -> check_bndr tc
PolyAlt -> return ()
- MaybeT $ trace (showSDoc (ppr e)) $ do
+ MaybeT $ do
-- we only allow case of tail-call or primop.
case scrut of
StgApp _ _ -> return ()
StgConApp _ _ -> return ()
StgOpApp _ _ _ -> return ()
- other -> addErrL (mkCaseOfCaseMsg e)
+ _ -> addErrL (mkCaseOfCaseMsg e)
addInScopeVars [bndr] $
lintStgAlts alts scrut_ty
Just (bndr_tc, _) -> checkL (tc == bndr_tc) bad_bndr
Nothing -> addErrL bad_bndr
+lintStgExpr e = pprPanic "lintStgExpr" (ppr e)
lintStgAlts :: [StgAlt]
-> Type -- Type of scrutinee
where
check ty = checkTys first_ty ty (mkCaseAltMsg alts)
-lintAlt scrut_ty (DEFAULT, _, _, rhs)
+lintAlt :: Type -> (AltCon, [Id], [Bool], StgExpr) -> LintM (Maybe Type)
+lintAlt _ (DEFAULT, _, _, rhs)
= lintStgExpr rhs
lintAlt scrut_ty (LitAlt lit, _, _, rhs) = do
checkL (equalLength arg_tys args) (mkAlgAltMsg3 con args)
mapM_ check (zipEqual "lintAlgAlt:stg" arg_tys args)
return ()
- other ->
+ _ ->
addErrL (mkAltMsg1 scrut_ty)
addInScopeVars args $
| LambdaBodyOf [Id] -- The lambda-binder
| BodyOfLetRec [Id] -- One of the binders
+dumpLoc :: LintLocInfo -> (SrcSpan, SDoc)
dumpLoc (RhsOf v) =
- (srcLocSpan (getSrcLoc v), ptext SLIT(" [RHS of ") <> pp_binders [v] <> char ']' )
+ (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 ']' )
+ (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 ']' )
+ (srcLocSpan (getSrcLoc (head bs)), ptext (sLit " [in body of letrec with binders ") <> pp_binders bs <> char ']' )
pp_binders :: [Id] -> SDoc
if isEmptyBag errs then
Nothing
else
- Just (vcat (punctuate (text "") (bagToList errs)))
+ Just (vcat (punctuate blankLine (bagToList errs)))
}
instance Monad LintM where
- return a = LintM $ \loc scope errs -> (a, errs)
+ return a = LintM $ \_loc _scope errs -> (a, errs)
(>>=) = thenL
(>>) = thenL_
\begin{code}
checkL :: Bool -> Message -> LintM ()
-checkL True msg = return ()
+checkL True _ = return ()
checkL False msg = addErrL msg
addErrL :: Message -> LintM ()
-addErrL msg = LintM $ \loc scope errs -> ((), addErr errs msg loc)
+addErrL msg = LintM $ \loc _scope errs -> ((), addErr errs msg loc)
addErr :: Bag Message -> Message -> [LintLocInfo] -> Bag Message
addErr errs_so_far msg locs
checkFunApp fun_ty arg_tys msg = LintM checkFunApp'
where
- checkFunApp' loc scope errs
- = cfa res_ty expected_arg_tys arg_tys
+ checkFunApp' loc _scope errs
+ = cfa fun_ty arg_tys
where
- (expected_arg_tys, res_ty) = splitFunTys (dropForAlls fun_ty)
+ cfa fun_ty [] -- Args have run out; that's fine
+ = (Just fun_ty, errs)
- cfa res_ty expected [] -- Args have run out; that's fine
- = (Just (mkFunTys expected res_ty), errs)
+ cfa fun_ty (_:arg_tys)
+ | Just (_arg_ty, res_ty) <- splitFunTy_maybe (dropForAlls fun_ty)
+ = cfa res_ty arg_tys
- cfa res_ty [] arg_tys -- Expected arg tys ran out first;
- -- first see if res_ty is a tyvar template;
- -- otherwise, maybe res_ty is a
- -- dictionary type which is actually a function?
- | isTyVarTy res_ty
- = (Just res_ty, errs)
+ | isTyVarTy fun_ty -- Expected arg tys ran out first;
+ = (Just fun_ty, errs) -- first see if fun_ty is a tyvar template;
+ -- otherwise, maybe fun_ty is a
+ -- dictionary type which is actually a function?
| otherwise
- = case splitFunTys res_ty of
- ([], _) -> (Nothing, addErr errs msg loc) -- Too many args
- (new_expected, new_res) -> cfa new_res new_expected arg_tys
-
- cfa res_ty (expected_arg_ty:expected_arg_tys) (arg_ty:arg_tys)
- = cfa res_ty expected_arg_tys arg_tys
+ = (Nothing, addErr errs msg loc) -- Too many args
\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)
+ ((), 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
+checkTys _ty1 _ty2 _msg = LintM $ \_loc _scope errs
-> -- if (ty1 == ty2) then
((), errs)
-- else ((), addErr errs msg loc)
\begin{code}
mkCaseAltMsg :: [StgAlt] -> Message
-mkCaseAltMsg alts
+mkCaseAltMsg _alts
= ($$) (text "In some case alternatives, type of alternatives not all same:")
(empty) -- LATER: ppr alts
mkDefltMsg :: Id -> Message
-mkDefltMsg bndr
- = ($$) (ptext SLIT("Binder of a case expression doesn't match type of scrutinee:"))
+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)]
+ 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))]
+ 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
mkRhsMsg :: Id -> Type -> Message
mkRhsMsg binder ty
- = vcat [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
+ = 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]
+ 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 "Let(rec) binder") <+> quotes (ppr binder) <+>
+ ptext (sLit "has unlifted type") <+> quotes (ppr (idType binder)))
$$
- (ptext SLIT("RHS:") <+> ppr rhs)
+ (ptext (sLit "RHS:") <+> ppr rhs)
\end{code}
projects / ghc-hetmet.git / blobdiff