projects
/
ghc-hetmet.git
/ commitdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
| commitdiff |
tree
raw
|
patch
|
inline
| side by side (parent:
96d6d25
)
Make StgLint warning-free
author
Ian Lynagh
<igloo@earth.li>
Sun, 4 May 2008 15:13:43 +0000
(15:13 +0000)
committer
Ian Lynagh
<igloo@earth.li>
Sun, 4 May 2008 15:13:43 +0000
(15:13 +0000)
compiler/stgSyn/StgLint.lhs
patch
|
blob
|
history
diff --git
a/compiler/stgSyn/StgLint.lhs
b/compiler/stgSyn/StgLint.lhs
index
08dce0d
..
9e57f9f
100644
(file)
--- a/
compiler/stgSyn/StgLint.lhs
+++ b/
compiler/stgSyn/StgLint.lhs
@@
-4,13
+4,6
@@
\section[StgLint]{A ``lint'' pass to check for Stg correctness}
\begin{code}
\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
import StgSyn
module StgLint ( lintStgBindings ) where
import StgSyn
@@
-25,12
+18,13
@@
import Literal ( literalType )
import Maybes
import Name ( getSrcLoc )
import ErrUtils ( Message, mkLocMessage )
import Maybes
import Name ( getSrcLoc )
import ErrUtils ( Message, mkLocMessage )
+import TypeRep
import Type ( mkFunTys, splitFunTys, splitTyConApp_maybe,
isUnLiftedType, isTyVarTy, dropForAlls, Type
)
import TyCon ( isAlgTyCon, isNewTyCon, tyConDataCons )
import Util ( zipEqual, equalLength )
import Type ( mkFunTys, splitFunTys, splitTyConApp_maybe,
isUnLiftedType, isTyVarTy, dropForAlls, Type
)
import TyCon ( isAlgTyCon, isNewTyCon, tyConDataCons )
import Util ( zipEqual, equalLength )
-import SrcLoc ( srcLocSpan )
+import SrcLoc
import Outputable
import FastString
import Control.Monad
import Outputable
import FastString
import Control.Monad
@@
-89,7
+83,9
@@
lintStgBindings whodunnit binds
lintStgArg :: StgArg -> LintM (Maybe Type)
lintStgArg (StgLitArg lit) = return (Just (literalType lit))
lintStgArg (StgVarArg v) = lintStgVar v
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}
lintStgVar v = do checkInScope v
return (Just (idType v))
\end{code}
@@
-107,6
+103,7
@@
lintStgBinds (StgRec pairs)
where
binders = [b | (b,_) <- pairs]
where
binders = [b | (b,_) <- pairs]
+lint_binds_help :: (Id, StgRhs) -> LintM ()
lint_binds_help (binder, rhs)
= addLoc (RhsOf binder) $ do
-- Check the rhs
lint_binds_help (binder, rhs)
= addLoc (RhsOf binder) $ do
-- Check the rhs
@@
-166,7
+163,7
@@
lintStgExpr e@(StgConApp con args) = runMaybeT $ do
lintStgExpr (StgOpApp (StgFCallOp _ _) args res_ty) = runMaybeT $ do
-- We don't have enough type information to check
-- the application; ToDo
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
return res_ty
lintStgExpr e@(StgOpApp (StgPrimOp op) args _) = runMaybeT $ do
@@
-220,6
+217,7
@@
lintStgExpr e@(StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do
Just (bndr_tc, _) -> checkL (tc == bndr_tc) bad_bndr
Nothing -> addErrL bad_bndr
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
lintStgAlts :: [StgAlt]
-> Type -- Type of scrutinee
@@
-237,6
+235,7
@@
lintStgAlts alts scrut_ty = do
where
check ty = checkTys first_ty ty (mkCaseAltMsg alts)
where
check ty = checkTys first_ty ty (mkCaseAltMsg alts)
+lintAlt :: Type -> (AltCon, [Id], [Bool], StgExpr) -> LintM (Maybe Type)
lintAlt _ (DEFAULT, _, _, rhs)
= lintStgExpr rhs
lintAlt _ (DEFAULT, _, _, rhs)
= lintStgExpr rhs
@@
-292,6
+291,7
@@
data LintLocInfo
| LambdaBodyOf [Id] -- The lambda-binder
| BodyOfLetRec [Id] -- One of the binders
| 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 ']' )
dumpLoc (LambdaBodyOf bs) =
dumpLoc (RhsOf v) =
(srcLocSpan (getSrcLoc v), ptext (sLit " [RHS of ") <> pp_binders [v] <> char ']' )
dumpLoc (LambdaBodyOf bs) =
@@
-418,7
+418,7
@@
checkInScope id = LintM $ \loc scope errs
((), errs)
checkTys :: Type -> Type -> Message -> LintM ()
((), 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)
-> -- if (ty1 == ty2) then
((), errs)
-- else ((), addErr errs msg loc)
@@
-426,12
+426,12
@@
checkTys ty1 ty2 msg = LintM $ \loc scope errs
\begin{code}
mkCaseAltMsg :: [StgAlt] -> Message
\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
= ($$) (text "In some case alternatives, type of alternatives not all same:")
(empty) -- LATER: ppr alts
mkDefltMsg :: Id -> Message
-mkDefltMsg bndr
+mkDefltMsg _bndr
= ($$) (ptext (sLit "Binder of a case expression doesn't match type of scrutinee:"))
(panic "mkDefltMsg")
= ($$) (ptext (sLit "Binder of a case expression doesn't match type of scrutinee:"))
(panic "mkDefltMsg")
@@
-489,6
+489,7
@@
mkRhsMsg binder ty
hsep [ptext (sLit "Rhs type:"), ppr ty]
]
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)))
mkUnLiftedTyMsg binder rhs
= (ptext (sLit "Let(rec) binder") <+> quotes (ppr binder) <+>
ptext (sLit "has unlifted type") <+> quotes (ppr (idType binder)))