X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FstgSyn%2FStgLint.lhs;h=29f683f2d44977ef72808ce2d56ec11afa0f4e52;hp=08dce0d7f474b7c4062aa9046b07fcf2503e82cc;hb=c5b178be60a5a44abd2f4ddf8c399857678326e2;hpb=c6dc5af607a3acd65bd8efb7d04478a2144f62a7 diff --git a/compiler/stgSyn/StgLint.lhs b/compiler/stgSyn/StgLint.lhs index 08dce0d..29f683f 100644 --- 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} -{-# 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 @@ -25,12 +18,13 @@ import Literal ( literalType ) 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 @@ -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 a = pprPanic "lintStgArg" (ppr a) +lintStgVar :: Id -> LintM (Maybe Kind) lintStgVar v = do checkInScope v return (Just (idType v)) \end{code} @@ -107,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 @@ -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 - 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 @@ -194,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 @@ -203,7 +200,7 @@ lintStgExpr e@(StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do 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 () @@ -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 +lintStgExpr e = pprPanic "lintStgExpr" (ppr e) lintStgAlts :: [StgAlt] -> Type -- Type of scrutinee @@ -237,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 @@ -292,6 +291,7 @@ 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 ']' ) dumpLoc (LambdaBodyOf bs) = @@ -316,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 @@ -387,26 +387,21 @@ checkFunApp :: Type -- The function type checkFunApp fun_ty arg_tys msg = LintM checkFunApp' where checkFunApp' loc _scope errs - = cfa res_ty expected_arg_tys arg_tys + = 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_tys) (_:arg_tys) - = cfa res_ty expected_arg_tys arg_tys + = (Nothing, addErr errs msg loc) -- Too many args \end{code} \begin{code} @@ -418,7 +413,7 @@ checkInScope id = LintM $ \loc scope errs ((), 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) @@ -426,12 +421,12 @@ 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 +mkDefltMsg _bndr = ($$) (ptext (sLit "Binder of a case expression doesn't match type of scrutinee:")) (panic "mkDefltMsg") @@ -489,6 +484,7 @@ mkRhsMsg binder 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)))