Initial checkin of HetMet / -XModalTypes modifications

[ghc-hetmet.git] / compiler / deSugar / DsForeign.lhs

diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index 4d0a148..2c2d7f2 100644 (file)
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -525,7 +525,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 +550,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 +589,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 +609,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)