X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2FcoreSyn%2FCoreLint.lhs;h=8d0304a90cd860da33d3f4dc143eb8ac68d65f1f;hb=d95ce839533391e7118257537044f01cbb1d6694;hp=de9830b7e4ed65e3437f92724eaa4b99b790665a;hpb=526c3af1dc98987b6949f4df73c0debccf9875bd;p=ghc-hetmet.git diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index de9830b..8d0304a 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -114,21 +114,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 +134,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 () @@ -279,10 +246,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 +278,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]) @@ -319,29 +304,6 @@ lintCoreExpr (Let (Rec pairs) 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) $ @@ -369,8 +331,10 @@ lintCoreExpr e@(Case scrut var alt_ty alts) = Just (tycon, _) | debugIsOn && isAlgTyCon tycon && + not (isOpenTyCon tycon) && null (tyConDataCons tycon) -> - pprTrace "case binder's type has no constructors" (ppr e) + 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 () @@ -391,8 +355,9 @@ lintCoreExpr e@(Case scrut var alt_ty alts) = where pass_var f = f var -lintCoreExpr e@(Type _) - = addErrL (mkStrangeTyMsg e) +lintCoreExpr (Type ty) + = do { ty' <- lintTy ty + ; return (typeKind ty') } \end{code} %************************************************************************ @@ -456,6 +421,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} @@ -600,12 +576,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 @@ -659,7 +636,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 @@ -699,6 +676,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 @@ -956,8 +939,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}