From 79723c6692289fd01a2d0548d03a6547eae41ecb Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Fri, 22 Oct 2010 07:24:05 +0000
Subject: [PATCH] Lint should check for duplicate top-level bindings with same
 qualified name

This would have produced a more civilised error for Trac #4396
---
 compiler/coreSyn/CoreLint.lhs |   40 +++++++++++++++++++++++++++++-----------
 1 file changed, 29 insertions(+), 11 deletions(-)

diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index 234dcbb..c347ed2 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 = findDupsEq eq_ext (map Var.varName binders)
+    eq_ext n1 n2 | Just m1 <- nameModule_maybe n1
+                 , Just m2 <- nameModule_maybe n2
+                 = m1==m2 && nameOccName n1 == nameOccName n2
+                 | otherwise = False
 
     lint_bind (Rec prs)		= mapM_ (lintSingleBinding TopLevel Recursive) prs
     lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs)
@@ -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
@@ -905,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
@@ -1184,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}
-- 
1.7.10.4