diff options
Diffstat (limited to 'compiler/stgSyn/StgLint.lhs')
| -rw-r--r-- | compiler/stgSyn/StgLint.lhs | 71 |
1 files changed, 34 insertions, 37 deletions
diff --git a/compiler/stgSyn/StgLint.lhs b/compiler/stgSyn/StgLint.lhs index ea1fab7eea..852202f5f7 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 -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module StgLint ( lintStgBindings ) where import StgSyn @@ -33,6 +26,7 @@ import SrcLoc import Outputable import FastString import Control.Monad +import Data.Function #include "HsVersions.h" \end{code} @@ -90,7 +84,6 @@ 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 @@ -121,10 +114,10 @@ lint_binds_help (binder, rhs) (mkUnLiftedTyMsg binder rhs) -- Check match to RHS type - -- Actually we *can't* check the RHS type, because - -- unsafeCoerce means it really might not match at all - -- notably; eg x::Int = (error @Bool "urk") |> unsafeCoerce... - -- case maybe_rhs_ty of + -- Actually we *can't* check the RHS type, because + -- unsafeCoerce means it really might not match at all + -- notably; eg x::Int = (error @Bool "urk") |> unsafeCoerce... + -- case maybe_rhs_ty of -- Nothing -> return () -- Just rhs_ty -> checkTys binder_ty -- rhs_ty @@ -182,7 +175,7 @@ lintStgExpr (StgOpApp _ args res_ty) = runMaybeT $ do _maybe_arg_tys <- mapM (MaybeT . lintStgArg) args return res_ty -lintStgExpr (StgLam _ bndrs _) = do +lintStgExpr (StgLam bndrs _) = do addErrL (ptext (sLit "Unexpected StgLam") <+> ppr bndrs) return Nothing @@ -203,18 +196,19 @@ lintStgExpr (StgSCC _ _ _ expr) = lintStgExpr expr lintStgExpr (StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do _ <- MaybeT $ lintStgExpr scrut - MaybeT $ liftM Just $ + in_scope <- MaybeT $ liftM Just $ case alts_type of - AlgAlt tc -> check_bndr tc - PrimAlt tc -> check_bndr tc - UbxTupAlt tc -> check_bndr tc - PolyAlt -> return () + AlgAlt tc -> check_bndr tc >> return True + PrimAlt tc -> check_bndr tc >> return True + UbxTupAlt _ -> return False -- Binder is always dead in this case + PolyAlt -> return True - MaybeT $ addInScopeVars [bndr] $ + MaybeT $ addInScopeVars [bndr | in_scope] $ lintStgAlts alts scrut_ty where - scrut_ty = idType bndr - check_bndr tc = case tyConAppTyCon_maybe (repType scrut_ty) of + scrut_ty = idType bndr + UnaryRep scrut_rep = repType scrut_ty -- Not used if scrutinee is unboxed tuple + check_bndr tc = case tyConAppTyCon_maybe scrut_rep of Just bndr_tc -> checkL (tc == bndr_tc) bad_bndr Nothing -> addErrL bad_bndr where @@ -237,8 +231,8 @@ lintStgAlts alts scrut_ty = do return (Just first_ty) where -- check ty = checkTys first_ty ty (mkCaseAltMsg alts) - -- We can't check that the alternatives have the - -- same type, becuase they don't, with unsafeCoerce# + -- We can't check that the alternatives have the + -- same type, becuase they don't, with unsafeCoerce# lintAlt :: Type -> (AltCon, [Id], [Bool], StgExpr) -> LintM (Maybe Type) lintAlt _ (DEFAULT, _, _, rhs) @@ -398,8 +392,8 @@ checkFunApp fun_ty arg_tys msg where (mb_ty, mb_msg) = cfa True fun_ty arg_tys - cfa :: Bool -> Type -> [Type] -> (Maybe Type -- Accurate result? - , Maybe MsgDoc) -- Errors? + cfa :: Bool -> Type -> [Type] -> (Maybe Type -- Accurate result? + , Maybe MsgDoc) -- Errors? cfa accurate fun_ty [] -- Args have run out; that's fine = (if accurate then Just fun_ty else Nothing, Nothing) @@ -438,28 +432,31 @@ stgEqType :: Type -> Type -> Bool -- Fundamentally this is a losing battle because of unsafeCoerce stgEqType orig_ty1 orig_ty2 - = go rep_ty1 rep_ty2 + = gos (repType orig_ty1) (repType orig_ty2) where - rep_ty1 = deepRepType orig_ty1 - rep_ty2 = deepRepType orig_ty2 + gos :: RepType -> RepType -> Bool + gos (UbxTupleRep tys1) (UbxTupleRep tys2) + = equalLength tys1 tys2 && and (zipWith go tys1 tys2) + gos (UnaryRep ty1) (UnaryRep ty2) = go ty1 ty2 + gos _ _ = False + + go :: UnaryType -> UnaryType -> Bool go ty1 ty2 | Just (tc1, tc_args1) <- splitTyConApp_maybe ty1 , Just (tc2, tc_args2) <- splitTyConApp_maybe ty2 , let res = if tc1 == tc2 - then equalLength tc_args1 tc_args2 - && and (zipWith go tc_args1 tc_args2) - else -- TyCons don't match; but don't bleat if either is a - -- family TyCon because a coercion might have made it - -- equal to something else - (isFamilyTyCon tc1 || isFamilyTyCon tc2) + then equalLength tc_args1 tc_args2 && and (zipWith (gos `on` repType) tc_args1 tc_args2) + else -- TyCons don't match; but don't bleat if either is a + -- family TyCon because a coercion might have made it + -- equal to something else + (isFamilyTyCon tc1 || isFamilyTyCon tc2) = if res then True else - pprTrace "stgEqType: unequal" (vcat [ppr orig_ty1, ppr orig_ty2, ppr rep_ty1 - , ppr rep_ty2, ppr ty1, ppr ty2]) + pprTrace "stgEqType: unequal" (vcat [ppr ty1, ppr ty2]) False | otherwise = True -- Conservatively say "fine". - -- Type variables in particular + -- Type variables in particular checkInScope :: Id -> LintM () checkInScope id = LintM $ \loc scope errs |