[project @ 2000-01-10 16:23:32 by sewardj]

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

diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs
index b6abdbf..b5a1154 100644 (file)
--- a/ghc/compiler/deSugar/DsForeign.lhs
+++ b/ghc/compiler/deSugar/DsForeign.lhs
@@ -24,13 +24,13 @@ import Const                ( Con(..), mkMachInt )
 import DataCon         ( DataCon, dataConId )
 import Id              ( Id, idType, idName, mkWildId, mkVanillaId )
 import Const           ( Literal(..) )
-import Module          ( Module )
+import Module          ( Module, moduleUserString )
 import Name            ( mkGlobalName, nameModule, nameOccName, getOccString, 
                          mkForeignExportOcc, isLocalName,
                          NamedThing(..), Provenance(..), ExportFlag(..)
                        )
 import PrelInfo                ( deRefStablePtr_NAME, bindIO_NAME, makeStablePtr_NAME, realWorldPrimId )
-import Type            ( splitAlgTyConApp_maybe, 
+import Type            ( splitAlgTyConApp_maybe,  unUsgTy,
                          splitTyConApp_maybe, splitFunTys, splitForAllTys,
                          Type, mkFunTys, mkForAllTys, mkTyConApp,
                          mkTyVarTy, mkFunTy, splitAppTy
@@ -43,6 +43,10 @@ import TysWiredIn    ( unitTyCon, addrTy, stablePtrTyCon,
                        )
 import Unique
 import Outputable
+
+#if __GLASGOW_HASKELL__ >= 404
+import GlaExts         ( fromInt )
+#endif
 \end{code}
 
 Desugaring of @foreign@ declarations is naturally split up into
@@ -137,7 +141,7 @@ dsFImport nm ty may_not_gc ext_name cconv =
     (case ext_name of
        Dynamic       -> getUniqueDs `thenDs` \ u -> 
                        returnDs (Right u)
-       ExtName fs _  -> returnDs (Left fs))    `thenDs` \ label ->
+       ExtName fs _  -> returnDs (Left fs))    `thenDs` \ lbl ->
     let
        val_args   = Var the_state_arg : unboxed_args
        final_args = Type inst_ty : val_args
@@ -146,7 +150,7 @@ dsFImport nm ty may_not_gc ext_name cconv =
        -- it at the full type, including the state argument
        inst_ty = mkFunTys (map coreExprType val_args) final_result_ty
 
-       the_ccall_op = CCallOp label False (not may_not_gc) cconv
+       the_ccall_op = CCallOp lbl False (not may_not_gc) cconv
 
        the_prim_app = mkPrimApp the_ccall_op (final_args :: [CoreArg])
 
@@ -293,7 +297,8 @@ dsFExport i ty mod_name ext_name cconv isDyn =
          ExtName fs _ -> fs
          Dynamic      -> panic "dsFExport: Dynamic - shouldn't ever happen."
 
-      (h_stub, c_stub) = fexportEntry c_nm f_helper_glob
+      (h_stub, c_stub) = fexportEntry (moduleUserString mod)
+                                     c_nm f_helper_glob
                                       wrapper_arg_tys the_result_ty cconv isDyn
      in
      returnDs (NonRec f_helper_glob the_body, h_stub, c_stub)
@@ -423,7 +428,7 @@ dsFExportDynamic i ty mod_name ext_name cconv =
      let ccall_io_adj = 
            mkLams [stbl_value]              $
            bindNonRec x_ccall_adj ccall_adj $
-           Note (Coerce (mkTyConApp ioTyCon [res_ty]) ccall_adj_ty)
+           Note (Coerce (mkTyConApp ioTyCon [res_ty]) (unUsgTy ccall_adj_ty))
                 (Var x_ccall_adj)
      in
      newSysLocalDs (coreExprType ccall_io_adj)   `thenDs` \ x_ccall_io_adj ->
@@ -457,14 +462,15 @@ The C stub constructs the application of the exported Haskell function
 using the hugs/ghc rts invocation API.
 
 \begin{code}
-fexportEntry :: FAST_STRING 
+fexportEntry :: String
+            -> FAST_STRING
             -> Id 
             -> [Type] 
             -> Maybe Type 
             -> CallConv 
             -> Bool
             -> (SDoc, SDoc)
-fexportEntry c_nm helper args res cc isDyn = (header_bits, c_bits)
+fexportEntry mod_nm c_nm helper args res cc isDyn = (header_bits, c_bits)
  where
    -- name of the (Haskell) helper function generated by the desugarer.
   h_nm     = ppr helper <> text "_closure"
@@ -510,7 +516,7 @@ fexportEntry c_nm helper args res cc isDyn = (header_bits, c_bits)
 
   returnResult = 
     text "rts_checkSchedStatus" <> 
-    parens (doubleQuotes (ptext c_nm) <> comma <> text "rc") <> semi $$
+    parens (doubleQuotes (text mod_nm <> char '.' <> ptext c_nm) <> comma <> text "rc") <> semi $$
     (case res of
       Nothing -> text "return"
       Just _  -> text "return" <> parens (res_name)) <> semi