X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreLint.lhs;h=8d0304a90cd860da33d3f4dc143eb8ac68d65f1f;hb=4f51ac1246f9a9b2bd172e2d6957d95942d12d23;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}