From c85f986ca64b6590150aab711713c9c08b70cf9d Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Wed, 20 Feb 2008 17:11:40 +0000 Subject: [PATCH] Whitespace --- compiler/stgSyn/StgLint.lhs | 219 ++++++++++++++++++++++--------------------- 1 file changed, 110 insertions(+), 109 deletions(-) diff --git a/compiler/stgSyn/StgLint.lhs b/compiler/stgSyn/StgLint.lhs index e4ebb08..2007433 100644 --- a/compiler/stgSyn/StgLint.lhs +++ b/compiler/stgSyn/StgLint.lhs @@ -17,35 +17,35 @@ module StgLint ( lintStgBindings ) where 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 Type ( mkFunTys, splitFunTys, splitTyConApp_maybe, + isUnLiftedType, isTyVarTy, dropForAlls, Type + ) +import TyCon ( isAlgTyCon, isNewTyCon, tyConDataCons ) +import Util ( zipEqual, equalLength ) +import SrcLoc ( srcLocSpan ) import Outputable 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 +54,9 @@ generation. Solution: don't use it! (KSW 2000-05). %************************************************************************ -%* * +%* * \subsection{``lint'' for various constructs} -%* * +%* * %************************************************************************ @lintStgBindings@ is the top-level interface function. @@ -69,11 +69,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 () @@ -95,7 +96,7 @@ lintStgVar v = do checkInScope 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] @@ -109,21 +110,21 @@ lintStgBinds (StgRec pairs) 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 +149,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)) @@ -164,8 +165,8 @@ lintStgExpr e@(StgConApp con args) = runMaybeT $ do 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 + -- We don't have enough type information to check + -- the application; ToDo maybe_arg_tys <- mapM (MaybeT . lintStgArg) args return res_ty @@ -191,7 +192,7 @@ 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 @@ -204,7 +205,7 @@ lintStgExpr e@(StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do PolyAlt -> return () MaybeT $ trace (showSDoc (ppr e)) $ do - -- we only allow case of tail-call or primop. + -- we only allow case of tail-call or primop. case scrut of StgApp _ _ -> return () StgConApp _ _ -> return () @@ -214,28 +215,28 @@ lintStgExpr e@(StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do 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 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) = lintStgExpr rhs @@ -246,37 +247,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 () + 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) + 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,9 +289,9 @@ 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 (RhsOf v) = (srcLocSpan (getSrcLoc v), ptext SLIT(" [RHS of ") <> pp_binders [v] <> char ']' ) @@ -314,9 +315,9 @@ 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 (text "") (bagToList errs))) } instance Monad LintM where @@ -347,8 +348,8 @@ 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 +363,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,10 +380,10 @@ 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 @@ -391,19 +392,19 @@ checkFunApp fun_ty arg_tys msg = LintM checkFunApp' where (expected_arg_tys, res_ty) = splitFunTys (dropForAlls fun_ty) - cfa res_ty expected [] -- Args have run out; that's fine + cfa res_ty expected [] -- Args have run out; that's fine = (Just (mkFunTys expected res_ty), errs) - 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? + 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) | 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 + ([], _) -> (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 @@ -413,9 +414,9 @@ 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) + ((), errs) checkTys :: Type -> Type -> Message -> LintM () checkTys ty1 ty2 msg = LintM $ \loc scope errs @@ -428,53 +429,53 @@ checkTys ty1 ty2 msg = LintM $ \loc scope errs mkCaseAltMsg :: [StgAlt] -> Message 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") + (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 @@ -484,13 +485,13 @@ 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] - ] + ppr binder], + hsep [ptext SLIT("Binder's type:"), ppr (idType binder)], + hsep [ptext SLIT("Rhs type:"), ppr ty] + ] mkUnLiftedTyMsg binder rhs - = (ptext SLIT("Let(rec) binder") <+> quotes (ppr binder) <+> + = (ptext SLIT("Let(rec) binder") <+> quotes (ppr binder) <+> ptext SLIT("has unlifted type") <+> quotes (ppr (idType binder))) $$ (ptext SLIT("RHS:") <+> ppr rhs) -- 1.7.10.4