X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsForeign.lhs;h=189672a97880df22fe7a36295bbe3aeaefc78e08;hb=ea659be5faea43df1b2c113d2f22947dff23367e;hp=ee7e66814b3d9cfb22771e65b156b073f2dab7cb;hpb=9adbdb312507dcc7d5777e36376535918549103b;p=ghc-hetmet.git

diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs
index ee7e668..189672a 100644
--- a/ghc/compiler/deSugar/DsForeign.lhs
+++ b/ghc/compiler/deSugar/DsForeign.lhs
@@ -29,20 +29,16 @@ import Name		( mkGlobalName, nameModule, nameOccName, getOccString,
 			  mkForeignExportOcc, isLocalName,
 			  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 PrelNames	( Uniquable(..), hasKey,
-			  ioTyConKey, deRefStablePtrIdKey, returnIOIdKey, 
-			  bindIOIdKey, makeStablePtrIdKey
+import PrelNames	( hasKey, ioTyConKey, deRefStablePtrName, newStablePtrName,
+			  bindIOName, returnIOName
 			)
 import Outputable
 
@@ -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 ]
@@ -309,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# #)))
@@ -336,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 
@@ -369,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	 $
@@ -488,12 +484,8 @@ 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)
- where
-  tc = case splitTyConApp_maybe (repType t) of
-	    Just (tc,_) -> tc
-	    Nothing	-> pprPanic "showFFIType" (ppr t)
+showFFIType t = getOccString (getName (tyConAppTyCon t))
 \end{code}