X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsForeign.lhs;h=462da0e051e5ab16bc115537cb321ecfbae48eaa;hb=60e9e613cf99e45f86a84bbba5ef3cadab40b1af;hp=725681e83c302ed5564dd142612de648a38399f3;hpb=21ea19b80bf4e16898406bd3241e8ab3de0c6c66;p=ghc-hetmet.git

diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index 725681e..462da0e 100644
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -28,12 +28,14 @@ import SMRep		( argMachRep, typeCgRep )
 import CoreUtils	( exprType, mkInlineMe )
 import Id		( Id, idType, idName, mkSysLocal, setInlinePragma )
 import Literal		( Literal(..), mkStringLit )
-import Module		( moduleFS )
+import Module		( moduleNameFS, moduleName )
 import Name		( getOccString, NamedThing(..) )
 import Type		( repType, coreEqType )
+import Coercion         ( mkUnsafeCoercion )
 import TcType		( Type, mkFunTys, mkForAllTys, mkTyConApp,
 			  mkFunTy, tcSplitTyConApp_maybe, tcSplitIOType_maybe,
 			  tcSplitForAllTys, tcSplitFunTys, tcTyConAppArgs,
+			  isBoolTy
 			)
 
 import BasicTypes       ( Boxity(..) )
@@ -45,7 +47,7 @@ import ForeignCall	( ForeignCall(..), CCallSpec(..),
 			  ccallConvAttribute
 			)
 import TysWiredIn	( unitTy, tupleTyCon )
-import TysPrim		( addrPrimTy, mkStablePtrPrimTy, alphaTy )
+import TysPrim		( addrPrimTy, mkStablePtrPrimTy, alphaTy, intPrimTy )
 import PrelNames	( stablePtrTyConName, newStablePtrName, bindIOName,
 			  checkDotnetResName )
 import BasicTypes	( Activation( NeverActive ) )
@@ -82,10 +84,9 @@ dsForeigns fos
   combine stubs (L loc decl) = putSrcSpanDs loc (combine1 stubs decl)
 
   combine1 (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f) 
-	   (ForeignImport id _ spec depr)
+	   (ForeignImport id _ spec)
     = traceIf (text "fi start" <+> ppr id)	`thenDs` \ _ ->
       dsFImport (unLoc id) spec	                `thenDs` \ (bs, h, c, mbhd) -> 
-      warnDepr depr				`thenDs` \ _                ->
       traceIf (text "fi end" <+> ppr id)	`thenDs` \ _ ->
       returnDs (ForeignStubs (h $$ acc_h)
       			     (c $$ acc_c)
@@ -94,10 +95,9 @@ dsForeigns fos
 		bs ++ acc_f)
 
   combine1 (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f) 
-	   (ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv)) depr)
+	   (ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv)))
     = dsFExport id (idType id) 
 		ext_nm cconv False                 `thenDs` \(h, c, _, _) ->
-      warnDepr depr				   `thenDs` \_              ->
       returnDs (ForeignStubs (h $$ acc_h) (c $$ acc_c) acc_hdrs (id:acc_feb), 
 		acc_f)
 
@@ -105,11 +105,6 @@ dsForeigns fos
   addH (Just e) ls
    | e `elem` ls = ls
    | otherwise   = e:ls
-
-  warnDepr False = returnDs ()
-  warnDepr True  = dsWarn msg
-     where
-       msg = ptext SLIT("foreign declaration uses deprecated non-standard syntax")
 \end{code}
 
 
@@ -330,7 +325,7 @@ f :: Fun -> IO (FunPtr Fun)
 f cback =
    bindIO (newStablePtr cback)
           (\StablePtr sp# -> IO (\s1# ->
-              case _ccall_ createAdjustor cconv sp# ``f_helper'' s1# of
+              case _ccall_ createAdjustor cconv sp# ``f_helper'' <arg info> s1# of
                  (# s2#, a# #) -> (# s2#, A# a# #)))
 
 foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun)
@@ -350,10 +345,10 @@ dsFExportDynamic :: Id
 		 -> DsM ([Binding], SDoc, SDoc)
 dsFExportDynamic id cconv
   =  newSysLocalDs ty				 `thenDs` \ fe_id ->
-     getModuleDs				`thenDs` \ mod_name -> 
+     getModuleDs				`thenDs` \ mod -> 
      let 
         -- hack: need to get at the name of the C stub we're about to generate.
-       fe_nm	   = mkFastString (unpackFS (zEncodeFS (moduleFS mod_name)) ++ "_" ++ toCName fe_id)
+       fe_nm	   = mkFastString (unpackFS (zEncodeFS (moduleNameFS (moduleName mod))) ++ "_" ++ toCName fe_id)
      in
      newSysLocalDs arg_ty			`thenDs` \ cback ->
      dsLookupGlobalId newStablePtrName		`thenDs` \ newStablePtrId ->
@@ -408,8 +403,9 @@ dsFExportDynamic id cconv
 	-- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
      let ccall_adj_ty = exprType ccall_adj
          ccall_io_adj = mkLams [stbl_value]		     $
-			Note (Coerce io_res_ty ccall_adj_ty)
-			     ccall_adj
+			(pprTrace "DsForeign: why is there an unsafeCoerce here?" (text "") $
+			(Cast ccall_adj (mkUnsafeCoercion ccall_adj_ty io_res_ty )))
+
          io_app = mkLams tvs	 $
 		  mkLams [cback] $
 		  stbl_app ccall_io_adj res_ty
@@ -629,16 +625,19 @@ ret_addr_arg = (text "original_return_addr", text "void*", undefined,
 		typeMachRep addrPrimTy)
 
 -- This function returns the primitive type associated with the boxed
--- type argument to a foreign export (eg. Int ==> Int#).  It assumes
--- that all the types we are interested in have a single constructor
--- with a single primitive-typed argument, which is true for all of the legal
--- foreign export argument types (see TcType.legalFEArgTyCon).
+-- type argument to a foreign export (eg. Int ==> Int#).
 getPrimTyOf :: Type -> Type
-getPrimTyOf ty =
-  case splitProductType_maybe (repType ty) of
+getPrimTyOf ty
+  | isBoolTy rep_ty = intPrimTy
+  -- Except for Bool, the types we are interested in have a single constructor
+  -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).
+  | otherwise =
+  case splitProductType_maybe rep_ty of
      Just (_, _, data_con, [prim_ty]) ->
 	ASSERT(dataConSourceArity data_con == 1)
 	ASSERT2(isUnLiftedType prim_ty, ppr prim_ty)
 	prim_ty
      _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)
+  where
+	rep_ty = repType ty
 \end{code}