X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsForeign.lhs;h=aee1594b765b002ca778471619777cbfaca8e106;hp=4d0a148e1598f2ba80de82a371f92275b3be457e;hb=b2524b3960999fffdb3767900f58825903f6560f;hpb=92267aa26adb1ab5a6d8004a80fdf6aa06ea4e44

diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index 4d0a148..aee1594 100644
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -28,7 +28,6 @@ import Type
 import TyCon
 import Coercion
 import TcType
-import Var
 
 import CmmExpr
 import CmmUtils
@@ -140,7 +139,7 @@ dsCImport id (CLabel cid) cconv _ = do
                  IsFunction
              _ -> IsData
    (resTy, foRhs) <- resultWrapper ty
-   ASSERT(fromJust resTy `coreEqType` addrPrimTy)    -- typechecker ensures this
+   ASSERT(fromJust resTy `eqType` addrPrimTy)    -- typechecker ensures this
     let
         rhs = foRhs (Lit (MachLabel cid stdcall_info fod))
         stdcall_info = fun_type_arg_stdcall_info cconv ty
@@ -382,9 +381,9 @@ dsFExportDynamic id cconv = do
     ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])
         -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
 
-    let io_app = mkLams tvs                $
-                 Lam cback                 $
-                 mkCoerceI (mkSymCoI co)   $
+    let io_app = mkLams tvs                  $
+                 Lam cback                   $
+                 mkCoerce (mkSymCo co) $
                  mkApps (Var bindIOId)
                         [ Type stable_ptr_ty
                         , Type res_ty       
@@ -483,7 +482,7 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
 	 typeCmmType (mkStablePtrPrimTy alphaTy))
 
   -- stuff to do with the return type of the C function
-  res_hty_is_unit = res_hty `coreEqType` unitTy	-- Look through any newtypes
+  res_hty_is_unit = res_hty `eqType` unitTy	-- Look through any newtypes
 
   cResType | res_hty_is_unit = text "void"
 	   | otherwise	     = showStgType res_hty
@@ -525,7 +524,7 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
   the_cfun
      = case maybe_target of
           Nothing    -> text "(StgClosure*)deRefStablePtr(the_stableptr)"
-          Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"
+          Just hs_fn -> char '&' <> ppr hs_fn <> text (closureSuffix hs_fn)
 
   cap = text "cap" <> comma
 
@@ -550,9 +549,8 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
   extern_decl
      = case maybe_target of
           Nothing -> empty
-          Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi
+          Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text (closureSuffix hs_fn) <> semi
 
-   
   -- finally, the whole darn thing
   c_bits =
     space $$
@@ -590,6 +588,10 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
      , rbrace
      ]
 
+closureSuffix :: Id -> String
+closureSuffix hs_fn =
+    if depth==0 then "_closure" else "_"++(show depth)++"closure"
+        where depth = getNameDepth (Var.varName hs_fn)
 
 foreignExportInitialiser :: Id -> SDoc
 foreignExportInitialiser hs_fn =
@@ -606,11 +608,10 @@ foreignExportInitialiser hs_fn =
          <> text "() __attribute__((constructor));"
     , text "static void stginit_export_" <> ppr hs_fn <> text "()"
     , braces (text "getStablePtr"
-       <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure")
+       <> parens (text "(StgPtr) &" <> ppr hs_fn <> text (closureSuffix hs_fn))
        <> semi)
     ]
 
-
 mkHObj :: Type -> SDoc
 mkHObj t = text "rts_mk" <> text (showFFIType t)
 
@@ -675,7 +676,7 @@ getPrimTyOf ty
 -- e.g. 'W' is a signed 32-bit integer.
 primTyDescChar :: Type -> Char
 primTyDescChar ty
- | ty `coreEqType` unitTy = 'v'
+ | ty `eqType` unitTy = 'v'
  | otherwise
  = case typePrimRep (getPrimTyOf ty) of
      IntRep	 -> signed_word