X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FstgSyn%2FStgLint.lhs;h=29f683f2d44977ef72808ce2d56ec11afa0f4e52;hp=e4ebb08602431bff91380deaf82a878b269e18cc;hb=8133a9f47b99f4e65ed30551de32ad72c6b61b27;hpb=222ec218baaad2fd553fa4381c3f7823c7274ea3 diff --git a/compiler/stgSyn/StgLint.lhs b/compiler/stgSyn/StgLint.lhs index e4ebb08..29f683f 100644 --- a/compiler/stgSyn/StgLint.lhs +++ b/compiler/stgSyn/StgLint.lhs @@ -4,48 +4,41 @@ \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 ) -import Id ( Id, idType, isLocalId ) +import Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList ) +import Id ( Id, idType, isLocalId ) import VarSet -import DataCon ( DataCon, dataConInstArgTys, dataConRepType ) -import CoreSyn ( AltCon(..) ) -import PrimOp ( primOpType ) -import Literal ( literalType ) +import DataCon ( DataCon, dataConInstArgTys, dataConRepType ) +import CoreSyn ( AltCon(..) ) +import PrimOp ( primOpType ) +import Literal ( literalType ) import Maybes -import Name ( getSrcLoc ) -import ErrUtils ( Message, mkLocMessage ) -import Type ( mkFunTys, splitFunTys, splitTyConApp_maybe, - isUnLiftedType, isTyVarTy, dropForAlls, Type - ) -import TyCon ( isAlgTyCon, isNewTyCon, tyConDataCons ) -import Util ( zipEqual, equalLength ) -import SrcLoc ( srcLocSpan ) +import Name ( getSrcLoc ) +import ErrUtils ( Message, mkLocMessage ) +import TypeRep +import Type ( mkFunTys, splitFunTy_maybe, splitTyConApp_maybe, + isUnLiftedType, isTyVarTy, dropForAlls + ) +import TyCon ( isAlgTyCon, isNewTyCon, tyConDataCons ) +import Util ( zipEqual, equalLength ) +import SrcLoc import Outputable +import FastString import Control.Monad \end{code} Checks for - (a) *some* type errors - (b) locally-defined variables used but not defined + (a) *some* type errors + (b) locally-defined variables used but not defined Note: unless -dverbose-stg is on, display of lint errors will result in "panic: bOGUS_LVs". -WARNING: +WARNING: ~~~~~~~~ This module has suffered bit-rot; it is likely to yield lint errors @@ -54,9 +47,9 @@ generation. Solution: don't use it! (KSW 2000-05). %************************************************************************ -%* * +%* * \subsection{``lint'' for various constructs} -%* * +%* * %************************************************************************ @lintStgBindings@ is the top-level interface function. @@ -69,11 +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("***"), - msg, - ptext SLIT("*** Offending Program ***"), - pprStgBindings binds, - ptext SLIT("*** End of Offense ***")]) + ptext (sLit "*** Stg Lint ErrMsgs: in") <+> + text whodunnit <+> ptext (sLit "***"), + msg, + ptext (sLit "*** Offending Program ***"), + pprStgBindings binds, + ptext (sLit "*** End of Offense ***")]) where lint_binds :: [StgBinding] -> LintM () @@ -89,13 +83,15 @@ 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} \begin{code} -lintStgBinds :: StgBinding -> LintM [Id] -- Returns the binders +lintStgBinds :: StgBinding -> LintM [Id] -- Returns the binders lintStgBinds (StgNonRec binder rhs) = do lint_binds_help (binder,rhs) return [binder] @@ -107,23 +103,24 @@ 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 - maybe_rhs_ty <- lintStgRhs rhs + -- Check the rhs + maybe_rhs_ty <- lintStgRhs rhs - -- Check binder doesn't have unlifted type - checkL (not (isUnLiftedType binder_ty)) - (mkUnLiftedTyMsg binder rhs) + -- Check binder doesn't have unlifted type + checkL (not (isUnLiftedType binder_ty)) + (mkUnLiftedTyMsg binder rhs) - -- Check match to RHS type - case maybe_rhs_ty of - Nothing -> return () - Just rhs_ty -> checkTys binder_ty - rhs_ty - (mkRhsMsg binder rhs_ty) + -- Check match to RHS type + case maybe_rhs_ty of + Nothing -> return () + Just rhs_ty -> checkTys binder_ty + rhs_ty + (mkRhsMsg binder rhs_ty) - return () + return () where binder_ty = idType binder \end{code} @@ -148,7 +145,7 @@ lintStgRhs (StgRhsCon _ con args) = runMaybeT $ do \end{code} \begin{code} -lintStgExpr :: StgExpr -> LintM (Maybe Type) -- Nothing if error found +lintStgExpr :: StgExpr -> LintM (Maybe Type) -- Nothing if error found lintStgExpr (StgLit l) = return (Just (literalType l)) @@ -163,10 +160,10 @@ lintStgExpr e@(StgConApp con args) = runMaybeT $ do where con_ty = dataConRepType con -lintStgExpr e@(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 +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 return res_ty lintStgExpr e@(StgOpApp (StgPrimOp op) args _) = runMaybeT $ do @@ -176,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 @@ -191,10 +188,10 @@ lintStgExpr (StgLetNoEscape _ _ binds body) = do addInScopeVars binders $ lintStgExpr body -lintStgExpr (StgSCC _ expr) = lintStgExpr expr +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,41 +200,43 @@ lintStgExpr e@(StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do UbxTupAlt tc -> check_bndr tc PolyAlt -> return () - MaybeT $ trace (showSDoc (ppr e)) $ do - -- we only allow case of tail-call or primop. + MaybeT $ do + -- we only allow case of tail-call or primop. case scrut of StgApp _ _ -> return () StgConApp _ _ -> return () StgOpApp _ _ _ -> return () - other -> addErrL (mkCaseOfCaseMsg e) + _ -> addErrL (mkCaseOfCaseMsg e) addInScopeVars [bndr] $ lintStgAlts alts scrut_ty where - scrut_ty = idType bndr + scrut_ty = idType bndr bad_bndr = mkDefltMsg bndr check_bndr tc = case splitTyConApp_maybe scrut_ty of - 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 - -> LintM (Maybe Type) -- Type of alternatives + -> Type -- Type of scrutinee + -> LintM (Maybe Type) -- Type of alternatives lintStgAlts alts scrut_ty = do maybe_result_tys <- mapM (lintAlt scrut_ty) alts - -- Check the result types + -- Check the result types case catMaybes (maybe_result_tys) of [] -> return Nothing (first_ty:tys) -> do mapM_ check tys return (Just first_ty) - where - check ty = checkTys first_ty ty (mkCaseAltMsg alts) + 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 @@ -246,37 +245,37 @@ lintAlt scrut_ty (LitAlt lit, _, _, rhs) = do lintAlt scrut_ty (DataAlt con, args, _, rhs) = do case splitTyConApp_maybe scrut_ty of - Just (tycon, tys_applied) | isAlgTyCon tycon && - not (isNewTyCon tycon) -> do - let - cons = tyConDataCons tycon - arg_tys = dataConInstArgTys con tys_applied - -- This almost certainly does not work for existential constructors - - checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) - checkL (equalLength arg_tys args) (mkAlgAltMsg3 con args) - mapM_ check (zipEqual "lintAlgAlt:stg" arg_tys args) - return () - other -> - addErrL (mkAltMsg1 scrut_ty) + Just (tycon, tys_applied) | isAlgTyCon tycon && + not (isNewTyCon tycon) -> do + let + cons = tyConDataCons tycon + arg_tys = dataConInstArgTys con tys_applied + -- This almost certainly does not work for existential constructors + + checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) + checkL (equalLength arg_tys args) (mkAlgAltMsg3 con args) + mapM_ check (zipEqual "lintAlgAlt:stg" arg_tys args) + return () + _ -> + addErrL (mkAltMsg1 scrut_ty) addInScopeVars args $ - lintStgExpr rhs + lintStgExpr rhs where check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg) -- elem: yes, the elem-list here can sometimes be long-ish, -- but as it's use-once, probably not worth doing anything different -- We give it its own copy, so it isn't overloaded. - elem _ [] = False + elem _ [] = False elem x (y:ys) = x==y || elem x ys \end{code} %************************************************************************ -%* * +%* * \subsection[lint-monad]{The Lint monad} -%* * +%* * %************************************************************************ \begin{code} @@ -288,17 +287,18 @@ newtype LintM a = LintM } data LintLocInfo - = RhsOf Id -- The variable bound - | LambdaBodyOf [Id] -- The lambda-binder - | BodyOfLetRec [Id] -- One of the binders + = RhsOf Id -- The variable bound + | 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 @@ -314,13 +314,13 @@ initL :: LintM a -> Maybe Message initL (LintM m) = case (m [] emptyVarSet emptyBag) of { (_, errs) -> if isEmptyBag errs then - Nothing + 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_ @@ -337,18 +337,18 @@ 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 = errs_so_far `snocBag` mk_msg locs where - mk_msg (loc:_) = let (l,hdr) = dumpLoc loc - in mkLocMessage l (hdr $$ msg) + mk_msg (loc:_) = let (l,hdr) = dumpLoc loc + in mkLocMessage l (hdr $$ msg) mk_msg [] = msg addLoc :: LintLocInfo -> LintM a -> LintM a @@ -362,7 +362,7 @@ addInScopeVars ids m = LintM $ \loc scope errs -- For now, it's just a "trace"; we may make -- a real error out of it... let - new_set = mkVarSet ids + new_set = mkVarSet ids in -- After adding -fliberate-case, Simon decided he likes shadowed -- names after all. WDP 94/07 @@ -379,46 +379,41 @@ applications and type lambdas that we use to calculate accurate types have long since disappeared. \begin{code} -checkFunApp :: Type -- The function type - -> [Type] -- The arg type(s) - -> Message -- Error messgae - -> LintM (Maybe Type) -- The result type +checkFunApp :: Type -- The function type + -> [Type] -- The arg type(s) + -> Message -- Error messgae + -> LintM (Maybe Type) -- The result type checkFunApp fun_ty arg_tys msg = LintM checkFunApp' where - checkFunApp' loc scope errs - = cfa res_ty expected_arg_tys arg_tys + checkFunApp' loc _scope errs + = 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_ty:expected_arg_tys) (arg_ty:arg_tys) - = cfa res_ty expected_arg_tys arg_tys + = (Nothing, addErr errs msg loc) -- Too many args \end{code} \begin{code} 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) + ((), 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,55 +421,55 @@ 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 + (empty) -- LATER: ppr alts mkDefltMsg :: Id -> Message -mkDefltMsg bndr - = ($$) (ptext SLIT("Binder of a case expression doesn't match type of scrutinee:")) - (panic "mkDefltMsg") +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 = ($$) (text "In a case expression, type of scrutinee does not match patterns") - (ppr ty) + (ppr ty) mkAlgAltMsg2 :: Type -> DataCon -> Message mkAlgAltMsg2 ty con = vcat [ - text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:", - ppr ty, - ppr con + text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:", + ppr ty, + ppr con ] mkAlgAltMsg3 :: DataCon -> [Id] -> Message mkAlgAltMsg3 con alts = vcat [ - text "In some algebraic case alternative, number of arguments doesn't match constructor:", - ppr con, - ppr alts + text "In some algebraic case alternative, number of arguments doesn't match constructor:", + ppr con, + ppr alts ] mkAlgAltMsg4 :: Type -> Id -> Message mkAlgAltMsg4 ty arg = vcat [ - text "In some algebraic case alternative, type of argument doesn't match data constructor:", - ppr ty, - ppr arg + text "In some algebraic case alternative, type of argument doesn't match data constructor:", + ppr ty, + ppr arg ] mkCaseOfCaseMsg :: StgExpr -> Message @@ -483,15 +478,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:"), - ppr binder], - hsep [ptext SLIT("Binder's type:"), ppr (idType binder)], - hsep [ptext SLIT("Rhs type:"), ppr ty] - ] + = 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] + ] +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}