Tidy up the treatment of dead binders

[ghc-hetmet.git] / compiler / coreSyn / CoreLint.lhs

diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index dda78c3..2b2a6e8 100644 (file)
--- 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
@@ -227,7 +228,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}
@@ -252,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')
         }
@@ -418,6 +424,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}
 
 
@@ -562,7 +579,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')
        }
 
@@ -622,7 +639,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
@@ -662,6 +679,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