[project @ 2001-03-08 12:07:38 by simonpj]

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

diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs
index 7959282..7e1f46d 100644 (file)
--- a/ghc/compiler/deSugar/DsForeign.lhs
+++ b/ghc/compiler/deSugar/DsForeign.lhs
@@ -20,30 +20,26 @@ import HsDecls              ( extNameStatic )
 import CallConv
 import TcHsSyn         ( TypecheckedForeignDecl )
 import CoreUtils       ( exprType, mkInlineMe )
-import Id              ( Id, idType, idName, mkVanillaId, mkSysLocal,
+import Id              ( Id, idType, idName, mkVanillaGlobal, mkSysLocal,
                          setInlinePragma )
-import IdInfo          ( neverInlinePrag )
+import IdInfo          ( neverInlinePrag, vanillaIdInfo )
 import Literal         ( Literal(..) )
 import Module          ( Module, moduleUserString )
 import Name            ( mkGlobalName, nameModule, nameOccName, getOccString, 
                          mkForeignExportOcc, isLocalName,
-                         NamedThing(..), Provenance(..), ExportFlag(..)
+                         NamedThing(..),
                        )
-import Type            ( unUsgTy, repType,
-                         splitTyConApp_maybe, splitFunTys, splitForAllTys,
+import Type            ( repType, splitTyConApp_maybe,
+                         tyConAppTyCon, splitFunTys, splitForAllTys,
                          Type, mkFunTys, mkForAllTys, mkTyConApp,
-                         mkTyVarTy, mkFunTy, splitAppTy, applyTy, funResultTy
-                       )
-import PrimOp          ( PrimOp(..), CCall(..), 
-                         CCallTarget(..), dynamicTarget )
-import TysWiredIn      ( unitTy, addrTy, stablePtrTyCon,
-                         addrDataCon
+                         mkFunTy, splitAppTy, applyTy, funResultTy
                        )
+import PrimOp          ( CCall(..), CCallTarget(..), dynamicTarget )
+import TysWiredIn      ( unitTy, addrTy, stablePtrTyCon )
 import TysPrim         ( addrPrimTy )
-import Unique          ( Uniquable(..), hasKey,
-                         ioTyConKey, deRefStablePtrIdKey, returnIOIdKey, 
-                         bindIOIdKey, makeStablePtrIdKey
-               )
+import PrelNames       ( hasKey, ioTyConKey, deRefStablePtrName, newStablePtrName,
+                         bindIOName, returnIOName
+                       )
 import Outputable
 
 import Maybe           ( fromJust )
@@ -213,7 +209,7 @@ dsFExport fn_id ty mod_name ext_name cconv isDyn
                 returnDs (\body -> body, orig_res_ty, res_ty)
 
        other ->        -- The function returns t, so wrap the call in returnIO
-                dsLookupGlobalValue returnIOIdKey      `thenDs` \ retIOId ->
+                dsLookupGlobalValue returnIOName       `thenDs` \ retIOId ->
                 returnDs (\body -> mkApps (Var retIOId) [Type orig_res_ty, body],
                           funResultTy (applyTy (idType retIOId) orig_res_ty), 
                                -- We don't have ioTyCon conveniently to hand
@@ -228,8 +224,8 @@ dsFExport fn_id ty mod_name ext_name cconv isDyn
      (if isDyn then 
         newSysLocalDs stbl_ptr_ty                      `thenDs` \ stbl_ptr ->
        newSysLocalDs stbl_ptr_to_ty                    `thenDs` \ stbl_value ->
-       dsLookupGlobalValue deRefStablePtrIdKey         `thenDs` \ deRefStablePtrId ->
-        dsLookupGlobalValue bindIOIdKey                        `thenDs` \ bindIOId ->
+       dsLookupGlobalValue deRefStablePtrName          `thenDs` \ deRefStablePtrId ->
+        dsLookupGlobalValue bindIOName                 `thenDs` \ bindIOId ->
        let
         the_deref_app = mkApps (Var deRefStablePtrId)
                                [ Type stbl_ptr_to_ty, Var stbl_ptr ]
@@ -263,7 +259,7 @@ dsFExport fn_id ty mod_name ext_name cconv isDyn
        helper_ty =  mkForAllTys tvs $
                     mkFunTys wrapper_arg_tys io_res_ty
 
-       f_helper_glob = mkVanillaId helper_name helper_ty
+       f_helper_glob = mkVanillaGlobal helper_name helper_ty vanillaIdInfo
                      where
                        name                = idName fn_id
                        mod     
@@ -271,8 +267,7 @@ dsFExport fn_id ty mod_name ext_name cconv isDyn
                         | otherwise        = nameModule name
 
                        occ                 = mkForeignExportOcc (nameOccName name)
-                       prov                = LocalDef src_loc Exported
-                       helper_name         = mkGlobalName uniq mod occ prov
+                       helper_name         = mkGlobalName uniq mod occ src_loc
 
        the_app = getFun_wrapper (return_io_wrapper (mkVarApps (Var i) (tvs ++ fe_args)))
        the_body = mkLams (tvs ++ wrapper_args) the_app
@@ -310,7 +305,7 @@ foreign export dynamic f :: (Addr -> Int -> IO Int) -> IO Addr
 
 f :: (Addr -> Int -> IO Int) -> IO Addr
 f cback =
-   bindIO (makeStablePtr cback)
+   bindIO (newStablePtr cback)
           (\StablePtr sp# -> IO (\s1# ->
               case _ccall_ createAdjustor cconv sp# ``f_helper'' s1# of
                  (# s2#, a# #) -> (# s2#, A# a# #)))
@@ -337,11 +332,11 @@ dsFExportDynamic i ty mod_name ext_name cconv =
      dsFExport  i export_ty mod_name fe_ext_name cconv True
        `thenDs` \ (feb, fe, h_code, c_code) ->
      newSysLocalDs arg_ty                      `thenDs` \ cback ->
-     dsLookupGlobalValue makeStablePtrIdKey    `thenDs` \ makeStablePtrId ->
+     dsLookupGlobalValue newStablePtrName      `thenDs` \ newStablePtrId ->
      let
-       mk_stbl_ptr_app    = mkApps (Var makeStablePtrId) [ Type arg_ty, Var cback ]
+       mk_stbl_ptr_app    = mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
      in
-     dsLookupGlobalValue bindIOIdKey                   `thenDs` \ bindIOId ->
+     dsLookupGlobalValue bindIOName                    `thenDs` \ bindIOId ->
      newSysLocalDs (mkTyConApp stablePtrTyCon [arg_ty]) `thenDs` \ stbl_value ->
      let
       stbl_app cont ret_ty 
@@ -370,7 +365,7 @@ dsFExportDynamic i ty mod_name ext_name cconv =
      dsCCall adjustor adj_args False False io_res_ty `thenDs` \ ccall_adj ->
      let ccall_adj_ty = exprType ccall_adj
          ccall_io_adj = mkLams [stbl_value]                 $
-                       Note (Coerce io_res_ty (unUsgTy ccall_adj_ty))
+                       Note (Coerce io_res_ty ccall_adj_ty)
                             ccall_adj
      in
      let io_app = mkLams tvs    $
@@ -489,7 +484,7 @@ unpackHObj :: Type -> SDoc
 unpackHObj t = text "rts_get" <> text (showFFIType t)
 
 showStgType :: Type -> SDoc
-showStgType t = text "Stg" <> text (showFFIType t)
+showStgType t = text "Hs" <> text (showFFIType t)
 
 showFFIType :: Type -> String
 showFFIType t = getOccString (getName tc)