X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreLint.lhs;h=bd88b5f10866d2ace7292246d6ee8fd62173734a;hb=62f6cc1dec4223532fbd15de64db4fb036932944;hp=042a4c4039c59823e2b6cdad29a8b8f094b978b2;hpb=ad94d40948668032189ad22a0ad741ac1f645f50;p=ghc-hetmet.git

diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index 042a4c4..bd88b5f 100644
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -1,3 +1,4 @@
+
 %
 % (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
@@ -10,13 +11,13 @@ A ``lint'' pass to check for Core correctness
 -- The above warning supression flag is a temporary kludge.
 -- While working on this module you are encouraged to remove it and fix
 -- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
 -- for details
 
 module CoreLint (
 	lintCoreBindings,
 	lintUnfolding, 
-	showPass, endPass
+	showPass, endPass, endIteration
     ) where
 
 #include "HsVersions.h"
@@ -42,13 +43,10 @@ import Coercion
 import TyCon
 import BasicTypes
 import StaticFlags
+import ListSetOps
 import DynFlags
 import Outputable
-
-#ifdef DEBUG
-import Util             ( notNull )
-#endif
-
+import Util
 import Data.Maybe
 \end{code}
 
@@ -64,7 +62,14 @@ and do Core Lint when necessary.
 
 \begin{code}
 endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
-endPass dflags pass_name dump_flag binds
+endPass = dumpAndLint dumpIfSet_core
+
+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
@@ -72,7 +77,7 @@ endPass dflags pass_name dump_flag binds
 		(text "    Result size =" <+> int (coreBindsSize binds))
 
 	-- Report verbosely, if required
-	dumpIfSet_core dflags dump_flag pass_name (pprCoreBindings binds)
+	dump dflags dump_flag pass_name (pprCoreBindings binds)
 
 	-- Type check
 	lintCoreBindings dflags pass_name binds
@@ -181,7 +186,8 @@ lintCoreBindings dflags whoDunnit binds
 	-- Put all the top-level binders in scope at the start
 	-- This is because transformation rules can bring something
 	-- into use 'unexpectedly'
-    lint_binds binds = addInScopeVars (bindersOfBinds binds) $
+    lint_binds binds = addLoc TopLevelBindings $
+		       addInScopeVars (bindersOfBinds binds) $
 		       mapM lint_bind binds 
 
     lint_bind (Rec prs)		= mapM_ (lintSingleBinding TopLevel Recursive) prs
@@ -370,8 +376,8 @@ lintCoreExpr e@(Case scrut var alt_ty alts) =
                    else lintAndScopeId var
      ; scope $ \_ ->
        do { -- Check the alternatives
-            checkCaseAlts e scrut_ty alts
-          ; 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
@@ -520,9 +526,10 @@ lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
 	  {    -- Check the pattern
 		 -- Scrutinee type must be a tycon applicn; checked by caller
 		 -- This code is remarkably compact considering what it does!
-		 -- NB: args must be in scope here so that the lintCoreArgs line works.
-	         -- NB: relies on existential type args coming *after* ordinary type args
-
+		 -- NB: args must be in scope here so that the lintCoreArgs
+		 --     line works. 
+	         -- NB: relies on existential type args coming *after*
+	         --     ordinary type args 
 	  ; con_result_ty <- lintCoreArgs con_payload_ty (varsToCoreExprs args)
 	  ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty) 
  	  }
@@ -645,6 +652,7 @@ data LintLocInfo
   | CasePat CoreAlt	-- *Pattern* of the case alternative
   | AnExpr CoreExpr	-- Some expression
   | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
+  | TopLevelBindings
 \end{code}
 
                  
@@ -682,8 +690,13 @@ addLoc extra_loc m =
   LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs)
 
 addInScopeVars :: [Var] -> LintM a -> LintM a
-addInScopeVars vars m = 
-  LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs)
+addInScopeVars vars m
+  | null dups
+  = LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs)
+  | otherwise
+  = addErrL (dupVars dups)
+  where
+    (_, dups) = removeDups compare vars 
 
 updateTvSubst :: TvSubst -> LintM a -> LintM a
 updateTvSubst subst' m = 
@@ -771,6 +784,8 @@ dumpLoc (CasePat (con, args, rhs))
 
 dumpLoc (ImportedUnfolding locn)
   = (locn, brackets (ptext SLIT("in an imported unfolding")))
+dumpLoc TopLevelBindings
+  = (noSrcLoc, empty)
 
 pp_binders :: [Var] -> SDoc
 pp_binders bs = sep (punctuate comma (map pp_binder bs))
@@ -923,6 +938,10 @@ mkCastErr from_ty expr_ty
 	  ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
     ]
 
+dupVars vars
+  = hang (ptext SLIT("Duplicate variables brought into scope"))
+       2 (ppr vars)
+
 mkStrangeTyMsg e
   = ptext SLIT("Type where expression expected:") <+> ppr e
 \end{code}