X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FstgSyn%2FStgLint.lhs;h=9e57f9f8f6986139a6cbba07fc2f45bbed9946db;hb=cbbee4e8727c583daf32d9bf17f00afaa839ef10;hp=9dc83cd86396e6fbac166de7ddb7c05405dc8888;hpb=b7c6cdd278e18f4d55180d9237d478f2c2e25f7f;p=ghc-hetmet.git diff --git a/compiler/stgSyn/StgLint.lhs b/compiler/stgSyn/StgLint.lhs index 9dc83cd..9e57f9f 100644 --- a/compiler/stgSyn/StgLint.lhs +++ b/compiler/stgSyn/StgLint.lhs @@ -4,17 +4,8 @@ \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 ) @@ -27,13 +18,15 @@ import Literal ( literalType ) 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 SrcLoc ( srcLocSpan ) +import SrcLoc import Outputable +import FastString import Control.Monad \end{code} @@ -69,12 +62,12 @@ 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("***"), + 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 () @@ -90,7 +83,9 @@ lintStgBindings whodunnit binds 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} @@ -108,6 +103,7 @@ lintStgBinds (StgRec pairs) where binders = [b | (b,_) <- pairs] +lint_binds_help :: (Id, StgRhs) -> LintM () lint_binds_help (binder, rhs) = addLoc (RhsOf binder) $ do -- Check the rhs @@ -167,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 - 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 @@ -177,7 +173,7 @@ 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 @@ -221,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 +lintStgExpr e = pprPanic "lintStgExpr" (ppr e) lintStgAlts :: [StgAlt] -> Type -- Type of scrutinee @@ -238,6 +235,7 @@ lintStgAlts alts scrut_ty = do where check ty = checkTys first_ty ty (mkCaseAltMsg alts) +lintAlt :: Type -> (AltCon, [Id], [Bool], StgExpr) -> LintM (Maybe Type) lintAlt _ (DEFAULT, _, _, rhs) = lintStgExpr rhs @@ -293,13 +291,14 @@ data LintLocInfo | 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 @@ -414,12 +413,12 @@ checkFunApp fun_ty arg_tys msg = LintM checkFunApp' 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) @@ -427,27 +426,27 @@ checkTys ty1 ty2 msg = LintM $ \loc scope errs \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 @@ -484,15 +483,16 @@ mkCaseOfCaseMsg 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:"), + = 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}