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

diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index 2d45eb3..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"
 
@@ -28,7 +24,6 @@ import VarEnv
 import VarSet
 import Name
 import Id
-import IdInfo
 import PprCore
 import ErrUtils
 import SrcLoc
@@ -47,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}
 %*									*
 %************************************************************************
@@ -228,10 +184,7 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
    where
     binder_ty                  = idType binder
     maybeDmdTy                 = idNewStrictness_maybe binder
-    bndr_vars                  = varSetElems (idFreeVars binder `unionVarSet` wkr_vars)
-    wkr_vars | workerExists wkr_info = unitVarSet (workerId wkr_info)
-	     | otherwise	     = emptyVarSet
-    wkr_info = idWorkerInfo binder
+    bndr_vars                  = varSetElems (idFreeVars binder)
     lintBinder var | isId var  = lintIdBndr var $ \_ -> (return ())
 	           | otherwise = return ()
 \end{code}
@@ -303,7 +256,7 @@ 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
@@ -353,7 +306,7 @@ 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
@@ -552,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') }
@@ -652,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}
@@ -719,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")