X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcForeign.lhs;h=d78bb20fac10d3cf658d49a3474679b8dab65e59;hb=3f1b316d7035c55cd712cd39a9981339bcef2e8c;hp=c78b469d8810e5926e62c2acd890b6c22939c068;hpb=e68a891932d615590d9b1ab5752ada8142db5053;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs
index c78b469..d78bb20 100644
--- a/compiler/typecheck/TcForeign.lhs
+++ b/compiler/typecheck/TcForeign.lhs
@@ -12,6 +12,13 @@ is restricted to what the outside world understands (read C), and this
 module checks to see if a foreign declaration has got a legal type.
 
 \begin{code}
+{-# OPTIONS -w #-}
+-- 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/Commentary/CodingStyle#Warnings
+-- for details
+
 module TcForeign 
 	( 
 	  tcForeignImports
@@ -34,14 +41,14 @@ import Type
 import SMRep
 import MachOp
 #endif
-import OccName
 import Name
+import OccName
 import TcType
-import ForeignCall
 import DynFlags
 import Outputable
 import SrcLoc
 import Bag
+import Unique
 \end{code}
 
 \begin{code}
@@ -216,8 +223,17 @@ tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
    newUnique			`thenM` \ uniq ->
    getModule			`thenM` \ mod ->
    let
-        gnm  = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm)) 
-			      (srcSpanStart loc)
+          -- We need to give a name to the new top-level binding that
+          -- is *stable* (i.e. the compiler won't change it later),
+          -- because this name will be referred to by the C code stub.
+          -- Furthermore, the name must be unique (see #1533).  If the
+          -- same function is foreign-exported multiple times, the
+          -- top-level bindings generated must not have the same name.
+          -- Hence we create an External name (doesn't change), and we
+          -- append a Unique to the string right here.
+        uniq_str = showSDoc (pprUnique uniq)
+        occ = mkVarOcc (occNameString (getOccName nm) ++ '_' : uniq_str)
+        gnm  = mkExternalName uniq mod (mkForeignExportOcc occ) loc
 	id   = mkExportedLocalId gnm sig_ty
 	bind = L loc (VarBind id rhs)
    in
@@ -266,7 +282,7 @@ mustBeIO = False
 
 checkForeignRes non_io_result_ok pred_res_ty ty
 	-- (IO t) is ok, and so is any newtype wrapping thereof
-  | Just (io, res_ty) <- tcSplitIOType_maybe ty,
+  | Just (io, res_ty, _) <- tcSplitIOType_maybe ty,
     pred_res_ty res_ty
   = returnM ()