X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FstgSyn%2FStgLint.lhs;h=cb08c40ba2d11b85e06969c26f94a1154b1ba09d;hp=23e8f3b39a87764fdae17bfbc277bc2e6fff981f;hb=f96194794bf099020706c3816d1a5678b40addbb;hpb=30c122df62ec75f9ed7f392f24c2925675bf1d06 diff --git a/compiler/stgSyn/StgLint.lhs b/compiler/stgSyn/StgLint.lhs index 23e8f3b..cb08c40 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,12 +18,13 @@ import Literal ( literalType ) import Maybes import Name ( getSrcLoc ) import ErrUtils ( Message, mkLocMessage ) +import TypeRep import Type ( mkFunTys, splitFunTys, splitTyConApp_maybe, - isUnLiftedType, isTyVarTy, dropForAlls, Type + isUnLiftedType, isTyVarTy, dropForAlls ) import TyCon ( isAlgTyCon, isNewTyCon, tyConDataCons ) import Util ( zipEqual, equalLength ) -import SrcLoc ( srcLocSpan ) +import SrcLoc import Outputable import FastString import Control.Monad @@ -70,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 () @@ -91,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} @@ -109,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 @@ -168,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 @@ -178,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 @@ -196,7 +191,7 @@ lintStgExpr (StgLetNoEscape _ _ 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 @@ -222,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 @@ -239,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 @@ -294,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 @@ -318,7 +316,7 @@ initL (LintM m) if isEmptyBag errs then Nothing else - Just (vcat (punctuate (text "") (bagToList errs))) + Just (vcat (punctuate blankLine (bagToList errs))) } instance Monad LintM where @@ -415,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) @@ -428,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 @@ -485,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}