X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreLint.lhs;h=5cc82a2ae220f623627bc573880cc7ce006499d5;hb=841e81e28f8cc711f624fdca122219a5bbde2fae;hp=3205ca8389e827173711d50be019d12748cc6988;hpb=8d6feaef4dce4c9256817be8e7e6da25c21d23d7;p=ghc-hetmet.git

diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index 3205ca8..5cc82a2 100644
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -98,14 +98,30 @@ find an occurence of an Id, we fetch it from the in-scope set.
 lintCoreBindings :: [CoreBind] -> (Bag Message, Bag Message)
 --   Returns (warnings, errors)
 lintCoreBindings binds
-  = initL (lint_binds binds)
-  where
+  = initL $ 
+    addLoc TopLevelBindings $
+    addInScopeVars binders  $
 	-- 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 = addLoc TopLevelBindings $
-		       addInScopeVars (bindersOfBinds binds) $
-		       mapM lint_bind binds 
+    do { checkL (null dups) (dupVars dups)
+       ; checkL (null ext_dups) (dupExtVars ext_dups)
+       ; mapM lint_bind binds }
+  where
+    binders = bindersOfBinds binds
+    (_, dups) = removeDups compare binders
+
+    -- dups_ext checks for names with different uniques
+    -- but but the same External name M.n.  We don't
+    -- allow this at top level:
+    --    M.n{r3}  = ...
+    --    M.n{r29} = ...
+    -- becuase they both get the same linker symbol
+    ext_dups = snd (removeDups ord_ext (map Var.varName binders))
+    ord_ext n1 n2 | Just m1 <- nameModule_maybe n1
+                  , Just m2 <- nameModule_maybe n2
+                  = compare (m1, nameOccName n1) (m2, nameOccName n2)
+                  | otherwise = LT
 
     lint_bind (Rec prs)		= mapM_ (lintSingleBinding TopLevel Recursive) prs
     lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs)
@@ -211,7 +227,7 @@ lintCoreExpr (Var var)
   = do	{ checkL (not (var == oneTupleDataConId))
 		 (ptext (sLit "Illegal one-tuple"))
 
-	; checkDeadIdOcc var
+        ; checkDeadIdOcc var
 	; var' <- lookupIdInScope var
         ; return (idType var') }
 
@@ -260,10 +276,12 @@ lintCoreExpr (Let (NonRec bndr rhs) body)
 
 lintCoreExpr (Let (Rec pairs) body) 
   = lintAndScopeIds bndrs	$ \_ ->
-    do	{ mapM_ (lintSingleBinding NotTopLevel Recursive) pairs	
+    do	{ checkL (null dups) (dupVars dups)
+        ; mapM_ (lintSingleBinding NotTopLevel Recursive) pairs	
 	; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }
   where
     bndrs = map fst pairs
+    (_, dups) = removeDups compare bndrs
 
 lintCoreExpr e@(App fun arg)
   = do	{ fun_ty <- lintCoreExpr fun
@@ -272,8 +290,9 @@ lintCoreExpr e@(App fun arg)
 
 lintCoreExpr (Lam var expr)
   = addLoc (LambdaBodyOf var) $
-    lintBinders [var] $ \[var'] -> 
-    do { body_ty <- lintCoreExpr expr
+    lintBinders [var] $ \ vars' ->
+    do { let [var'] = vars'  
+       ; body_ty <- lintCoreExpr expr
        ; if isId var' then 
              return (mkFunTy (idType var') body_ty) 
 	 else
@@ -904,12 +923,7 @@ inCasePat = LintM $ \ loc _ errs -> (Just (is_case_pat loc), errs)
 
 addInScopeVars :: [Var] -> LintM a -> LintM a
 addInScopeVars vars m
-  | null dups
   = LintM (\ loc subst errs -> unLintM m loc (extendTvInScopeList subst vars) errs)
-  | otherwise
-  = failWithL (dupVars dups)
-  where
-    (_, dups) = removeDups compare vars 
 
 addInScopeVar :: Var -> LintM a -> LintM a
 addInScopeVar var m
@@ -1183,4 +1197,9 @@ dupVars :: [[Var]] -> Message
 dupVars vars
   = hang (ptext (sLit "Duplicate variables brought into scope"))
        2 (ppr vars)
+
+dupExtVars :: [[Name]] -> Message
+dupExtVars vars
+  = hang (ptext (sLit "Duplicate top-level variables with the same qualified name"))
+       2 (ppr vars)
 \end{code}