X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreLint.lhs;h=2d45eb35d2731d1054d2e9eb3e9391d5b3bbad8b;hb=a7eb3064144ef4b2975d4fec7c7ae6104cfa213a;hp=8f5538c599aa654a486e2ca7626e03791da88abc;hpb=67fee0f2a808a26a7e2d906394ec287a0fba6461;p=ghc-hetmet.git

diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index 8f5538c..2d45eb3 100644
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -256,6 +256,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')
         }
@@ -333,6 +335,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
@@ -422,6 +425,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}
 
 
@@ -566,7 +580,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')
        }
 
@@ -626,7 +640,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
@@ -666,6 +680,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