X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreLint.lhs;h=5156bbcf403b5988981953a7bf0f2e315e6379d5;hb=e66a5311c7bfa0690875f2e87bbe74d053e24147;hp=de9830b7e4ed65e3437f92724eaa4b99b790665a;hpb=526c3af1dc98987b6949f4df73c0debccf9875bd;p=ghc-hetmet.git
diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index de9830b..5156bbc 100644
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -7,11 +7,7 @@
A ``lint'' pass to check for Core correctness
\begin{code}
-module CoreLint (
- lintCoreBindings,
- lintUnfolding,
- showPass, endPass, endPassIf, endIteration
- ) where
+module CoreLint ( lintCoreBindings, lintUnfolding ) where
#include "HsVersions.h"
@@ -46,45 +42,6 @@ import Data.Maybe
%************************************************************************
%* *
-\subsection{End pass}
-%* *
-%************************************************************************
-
-@showPass@ and @endPass@ don't really belong here, but it makes a convenient
-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 = dumpAndLint dumpIfSet_core
-
-endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
-endPassIf cond = dumpAndLint (dumpIf_core cond)
-
-endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
-endIteration = dumpAndLint dumpIfSet_dyn
-
-dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ())
- -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
-dumpAndLint dump dflags pass_name dump_flag binds
- = do
- -- Report result size if required
- -- This has the side effect of forcing the intermediate to be evaluated
- debugTraceMsg dflags 2 $
- (text " Result size =" <+> int (coreBindsSize binds))
-
- -- Report verbosely, if required
- dump dflags dump_flag pass_name (pprCoreBindings binds)
-
- -- Type check
- lintCoreBindings dflags pass_name binds
-
- return binds
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
%* *
%************************************************************************
@@ -114,21 +71,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 +91,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 +203,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 +235,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 +256,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) $
@@ -369,8 +288,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 ()
@@ -385,14 +306,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}
%************************************************************************
@@ -456,6 +378,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}
@@ -572,7 +505,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') }
@@ -600,12 +533,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 +593,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
@@ -671,7 +605,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}
@@ -699,6 +633,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
@@ -732,7 +672,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")
@@ -956,8 +896,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}