X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreLint.lhs;h=a3ba3ae250afa9d3a7bc2ab58116b3609e5a10ae;hp=f7c63f8f51398c9c9c656b4d5a159c3b396c6df6;hb=f96194794bf099020706c3816d1a5678b40addbb;hpb=dbeac92f840110824f1355acfed6b95bc989151b diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index f7c63f8..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} @@ -114,21 +113,15 @@ Outstanding issues: -- may well be happening...); -Note [Type lets] -~~~~~~~~~~~~~~~~ +Note [Linting type lets] +~~~~~~~~~~~~~~~~~~~~~~~~ In the desugarer, it's very very convenient to be able to say (in effect) - let a = Int in -That is, use a type let. (See notes just below for why we want this.) - -We don't have type lets in Core, so the desugarer uses type lambda - (/\a. ) Int -However, in the lambda form, we'd get lint errors from: - (/\a. let x::a = 4 in ) Int -because (x::a) doesn't look compatible with (4::Int). - -So (HACK ALERT) the Lint phase does type-beta reduction "on the fly", -as it were. It carries a type substitution (in this example [a -> Int]) -and applies this substitution before comparing types. The functin + let a = Type Int in +That is, use a type let. See Note [Type let] in CoreSyn. + +However, when linting we need to remember that a=Int, else we might +reject a correct program. So we carry a type substitution (in this example +[a -> Int]) and apply this substitution before comparing types. The functin lintTy :: Type -> LintM Type returns a substituted type; that's the only reason it returns anything. @@ -140,33 +133,6 @@ itself is part of the TvSubst we are carrying down), and when we find an occurence of an Id, we fetch it from the in-scope set. -Why we need type let -~~~~~~~~~~~~~~~~~~~~ -It's needed when dealing with desugarer output for GADTs. Consider - data T = forall a. T a (a->Int) Bool - f :: T -> ... -> - f (T x f True) = - f (T y g False) = -After desugaring we get - f t b = case t of - T a (x::a) (f::a->Int) (b:Bool) -> - case b of - True -> - False -> (/\b. let y=x; g=f in ) a -And for a reason I now forget, the ...... can mention a; so -we want Lint to know that b=a. Ugh. - -I tried quite hard to make the necessity for this go away, by changing the -desugarer, but the fundamental problem is this: - - T a (x::a) (y::Int) -> let fail::a = ... - in (/\b. ...(case ... of - True -> x::b - False -> fail) - ) a -Now the inner case look as though it has incompatible branches. - - \begin{code} lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO () @@ -260,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} @@ -279,10 +248,14 @@ lintCoreExpr :: CoreExpr -> LintM OutType -- The returned type has the substitution from the monad -- already applied to it: -- lintCoreExpr e subst = exprType (subst e) +-- +-- The returned "type" can be a kind, if the expression is (Type ty) lintCoreExpr (Var var) = do { checkL (not (var == oneTupleDataConId)) (ptext (sLit "Illegal one-tuple")) + + ; checkDeadIdOcc var ; var' <- lookupIdInScope var ; return (idType var') } @@ -307,6 +280,20 @@ lintCoreExpr (Cast expr co) lintCoreExpr (Note _ expr) = lintCoreExpr expr +lintCoreExpr (Let (NonRec tv (Type ty)) body) + = -- See Note [Type let] in CoreSyn + do { checkL (isTyVar tv) (mkKindErrMsg tv ty) -- Not quite accurate + ; ty' <- lintTy ty + ; kind' <- lintTy (tyVarKind tv) + ; let tv' = setTyVarKind tv kind' + ; checkKinds tv' ty' + -- Now extend the substitution so we + -- take advantage of it in the body + ; addLoc (BodyOfLetRec [tv]) $ + addInScopeVars [tv'] $ + extendSubstL tv' ty' $ + lintCoreExpr body } + lintCoreExpr (Let (NonRec bndr rhs) body) = do { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs) ; addLoc (BodyOfLetRec [bndr]) @@ -314,34 +301,11 @@ 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 -lintCoreExpr e@(App fun (Type ty)) --- See Note [Type let] above - = addLoc (AnExpr e) $ - go fun [ty] - where - go (App fun (Type ty)) tys - = do { go fun (ty:tys) } - go (Lam tv body) (ty:tys) - = do { checkL (isTyVar tv) (mkKindErrMsg tv ty) -- Not quite accurate - ; ty' <- lintTy ty - ; let kind = tyVarKind tv - ; kind' <- lintTy kind - ; let tv' = setTyVarKind tv kind' - ; checkKinds tv' ty' - -- Now extend the substitution so we - -- take advantage of it in the body - ; addInScopeVars [tv'] $ - extendSubstL tv' ty' $ - go body tys } - go fun tys - = do { fun_ty <- lintCoreExpr fun - ; lintCoreArgs fun_ty (map Type tys) } - lintCoreExpr e@(App fun arg) = do { fun_ty <- lintCoreExpr fun ; addLoc (AnExpr e) $ @@ -363,6 +327,19 @@ lintCoreExpr e@(Case scrut var alt_ty alts) = do { scrut_ty <- lintCoreExpr scrut ; alt_ty <- lintTy alt_ty ; var_ty <- lintTy (idType var) + + ; let mb_tc_app = splitTyConApp_maybe (idType var) + ; case mb_tc_app of + 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 + $ return () + _otherwise -> return () + -- Don't use lintIdBndr on var, because unboxed tuple is legitimate ; subst <- getTvSubst @@ -374,14 +351,15 @@ 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 pass_var f = f var -lintCoreExpr e@(Type _) - = addErrL (mkStrangeTyMsg e) +lintCoreExpr (Type ty) + = do { ty' <- lintTy ty + ; return (typeKind ty') } \end{code} %************************************************************************ @@ -445,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} @@ -561,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') } @@ -589,12 +578,13 @@ 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') } lintTy :: InType -> LintM OutType -- Check the type, and apply the substitution to it +-- See Note [Linting type lets] -- ToDo: check the kind structure of the type lintTy ty = do { ty' <- applySubst ty @@ -648,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 @@ -660,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} @@ -688,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 @@ -721,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") @@ -945,8 +941,4 @@ dupVars :: [[Var]] -> Message dupVars vars = hang (ptext (sLit "Duplicate variables brought into scope")) 2 (ppr vars) - -mkStrangeTyMsg :: CoreExpr -> Message -mkStrangeTyMsg e - = ptext (sLit "Type where expression expected:") <+> ppr e \end{code}