X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FstgSyn%2FStgLint.lhs;h=cb08c40ba2d11b85e06969c26f94a1154b1ba09d;hp=2007433c296a81c84e22d31b803db423c77005da;hb=f96194794bf099020706c3816d1a5678b40addbb;hpb=c85f986ca64b6590150aab711713c9c08b70cf9d diff --git a/compiler/stgSyn/StgLint.lhs b/compiler/stgSyn/StgLint.lhs index 2007433..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,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 + 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} @@ -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 @@ -164,10 +160,10 @@ lintStgExpr e@(StgConApp con args) = runMaybeT $ do 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 @@ -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 @@ -195,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 @@ -210,7 +206,7 @@ lintStgExpr e@(StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do StgApp _ _ -> return () StgConApp _ _ -> return () StgOpApp _ _ _ -> return () - other -> addErrL (mkCaseOfCaseMsg e) + _ -> addErrL (mkCaseOfCaseMsg e) addInScopeVars [bndr] $ lintStgAlts alts scrut_ty @@ -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,7 +235,8 @@ lintStgAlts alts scrut_ty = do 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 @@ -258,7 +256,7 @@ lintAlt scrut_ty (DataAlt con, args, _, 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 $ @@ -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 @@ -317,11 +316,11 @@ 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 - return a = LintM $ \loc scope errs -> (a, errs) + return a = LintM $ \_loc _scope errs -> (a, errs) (>>=) = thenL (>>) = thenL_ @@ -338,11 +337,11 @@ thenL_ m k = LintM $ \loc scope errs \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 @@ -387,7 +386,7 @@ checkFunApp :: Type -- The function type checkFunApp fun_ty arg_tys msg = LintM checkFunApp' where - checkFunApp' loc scope errs + checkFunApp' loc _scope errs = cfa res_ty expected_arg_tys arg_tys where (expected_arg_tys, res_ty) = splitFunTys (dropForAlls fun_ty) @@ -406,7 +405,7 @@ checkFunApp fun_ty arg_tys msg = LintM checkFunApp' ([], _) -> (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) = cfa res_ty expected_arg_tys arg_tys \end{code} @@ -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}