X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreLint.lhs;h=a3ba3ae250afa9d3a7bc2ab58116b3609e5a10ae;hp=dda78c35445c2aef1fae647d48a3b12b2d73cf3e;hb=f96194794bf099020706c3816d1a5678b40addbb;hpb=1b1190e01d0c65043628d2532988d9b1b4a78384 diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index dda78c3..a3ba3ae 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -28,6 +28,7 @@ import VarEnv import VarSet import Name import Id +import IdInfo import PprCore import ErrUtils import SrcLoc @@ -55,17 +56,17 @@ place for them. They print out stuff before and after core passes, and do Core Lint when necessary. \begin{code} -endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind] +endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO () endPass = dumpAndLint dumpIfSet_core -endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind] +endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO () endPassIf cond = dumpAndLint (dumpIf_core cond) -endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind] +endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO () endIteration = dumpAndLint dumpIfSet_dyn dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ()) - -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind] + -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO () dumpAndLint dump dflags pass_name dump_flag binds = do -- Report result size if required @@ -78,8 +79,6 @@ dumpAndLint dump dflags pass_name dump_flag binds -- Type check lintCoreBindings dflags pass_name binds - - return binds \end{code} @@ -227,7 +226,10 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs) where binder_ty = idType binder maybeDmdTy = idNewStrictness_maybe binder - bndr_vars = varSetElems (idFreeVars binder) + bndr_vars = varSetElems (idFreeVars binder `unionVarSet` wkr_vars) + wkr_vars | workerExists wkr_info = unitVarSet (workerId wkr_info) + | otherwise = emptyVarSet + wkr_info = idWorkerInfo binder lintBinder var | isId var = lintIdBndr var $ \_ -> (return ()) | otherwise = return () \end{code} @@ -252,6 +254,8 @@ lintCoreExpr :: CoreExpr -> LintM OutType lintCoreExpr (Var var) = do { checkL (not (var == oneTupleDataConId)) (ptext (sLit "Illegal one-tuple")) + + ; checkDeadIdOcc var ; var' <- lookupIdInScope var ; return (idType var') } @@ -297,7 +301,7 @@ lintCoreExpr (Let (NonRec bndr rhs) body) lintCoreExpr (Let (Rec pairs) body) = lintAndScopeIds bndrs $ \_ -> - do { mapM (lintSingleBinding NotTopLevel Recursive) pairs + do { mapM_ (lintSingleBinding NotTopLevel Recursive) pairs ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) } where bndrs = map fst pairs @@ -329,6 +333,7 @@ lintCoreExpr e@(Case scrut var alt_ty alts) = Just (tycon, _) | debugIsOn && isAlgTyCon tycon && + not (isOpenTyCon tycon) && null (tyConDataCons tycon) -> pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var)) -- This can legitimately happen for type families @@ -346,7 +351,7 @@ lintCoreExpr e@(Case scrut var alt_ty alts) = else lintAndScopeId var ; scope $ \_ -> do { -- Check the alternatives - mapM (lintCoreAlt scrut_ty alt_ty) alts + mapM_ (lintCoreAlt scrut_ty alt_ty) alts ; checkCaseAlts e scrut_ty alts ; return alt_ty } } where @@ -418,6 +423,17 @@ checkKinds tyvar arg_ty tyvar_kind = tyVarKind tyvar arg_kind | isCoVar tyvar = coercionKindPredTy arg_ty | otherwise = typeKind arg_ty + +checkDeadIdOcc :: Id -> LintM () +-- Occurrences of an Id should never be dead.... +-- except when we are checking a case pattern +checkDeadIdOcc id + | isDeadOcc (idOccInfo id) + = do { in_case <- inCasePat + ; checkL in_case + (ptext (sLit "Occurrence of a dead Id") <+> ppr id) } + | otherwise + = return () \end{code} @@ -534,7 +550,7 @@ lintBinder var linterF | isTyVar var = lint_ty_bndr | otherwise = lintIdBndr var linterF where - lint_ty_bndr = do { lintTy (tyVarKind var) + lint_ty_bndr = do { _ <- lintTy (tyVarKind var) ; subst <- getTvSubst ; let (subst', tv') = substTyVarBndr subst var ; updateTvSubst subst' (linterF tv') } @@ -562,7 +578,7 @@ lintAndScopeIds ids linterF lintAndScopeId :: Var -> (Var -> LintM a) -> LintM a lintAndScopeId id linterF = do { ty <- lintTy (idType id) - ; let id' = Var.setIdType id ty + ; let id' = setIdType id ty ; addInScopeVars [id'] $ (linterF id') } @@ -622,7 +638,7 @@ data LintLocInfo | LambdaBodyOf Id -- The lambda-binder | BodyOfLetRec [Id] -- One of the binders | CaseAlt CoreAlt -- Case alternative - | CasePat CoreAlt -- *Pattern* of the case alternative + | CasePat CoreAlt -- The *pattern* of the case alternative | AnExpr CoreExpr -- Some expression | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which) | TopLevelBindings @@ -634,7 +650,7 @@ initL :: LintM a -> Maybe Message {- errors -} initL m = case unLintM m [] emptyTvSubst emptyBag of (_, errs) | isEmptyBag errs -> Nothing - | otherwise -> Just (vcat (punctuate (text "") (bagToList errs))) + | otherwise -> Just (vcat (punctuate blankLine (bagToList errs))) \end{code} \begin{code} @@ -662,6 +678,12 @@ addLoc :: LintLocInfo -> LintM a -> LintM a addLoc extra_loc m = LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs) +inCasePat :: LintM Bool -- A slight hack; see the unique call site +inCasePat = LintM $ \ loc _ errs -> (Just (is_case_pat loc), errs) + where + is_case_pat (CasePat {} : _) = True + is_case_pat _other = False + addInScopeVars :: [Var] -> LintM a -> LintM a addInScopeVars vars m | null dups @@ -695,7 +717,7 @@ lookupIdInScope id = do { subst <- getTvSubst ; case lookupInScope (getTvInScope subst) id of Just v -> return v - Nothing -> do { addErrL out_of_scope + Nothing -> do { _ <- addErrL out_of_scope ; return id } } where out_of_scope = ppr id <+> ptext (sLit "is out of scope")