X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsCCall.lhs;h=0fcfdd5b91707f365674043c47f5f8dee6860e42;hb=17777c534ae9ee723b94c234d5fe207f9d68c5d1;hp=5ee47807de1f6d089bcede6277afd771cd05cd4a;hpb=43d343abeb4cb764d2550832c2a4fafa4919041d;p=ghc-hetmet.git

diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs
index 5ee4780..0fcfdd5 100644
--- a/ghc/compiler/deSugar/DsCCall.lhs
+++ b/ghc/compiler/deSugar/DsCCall.lhs
@@ -18,8 +18,8 @@ import CoreSyn
 
 import DsMonad
 
-import CoreUtils	( exprType, mkCoerce )
-import Id		( Id, mkWildId, idType )
+import CoreUtils	( exprType, mkCoerce2 )
+import Id		( Id, mkWildId )
 import MkId		( mkFCallId, realWorldPrimId, mkPrimOpId )
 import Maybes		( maybeToBool )
 import ForeignCall	( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety, CCallConv(..) )
@@ -29,14 +29,13 @@ import ForeignCall	( ForeignCall, CCallTarget(..) )
 import TcType		( tcSplitTyConApp_maybe )
 import Type		( Type, isUnLiftedType, mkFunTys, mkFunTy,
 			  tyVarsOfType, mkForAllTys, mkTyConApp, 
-			  isPrimitiveType, eqType,
-			  splitTyConApp_maybe, splitNewType_maybe
+			  isPrimitiveType, splitTyConApp_maybe, 
+			  splitNewType_maybe, splitForAllTy_maybe,
 			)
 
 import PrimOp		( PrimOp(..) )
-import TysPrim		( realWorldStatePrimTy,
-			  byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
-			  intPrimTy, foreignObjPrimTy
+import TysPrim		( realWorldStatePrimTy, intPrimTy,
+			  byteArrayPrimTyCon, mutableByteArrayPrimTyCon
 			)
 import TyCon		( TyCon, tyConDataCons )
 import TysWiredIn	( unitDataConId,
@@ -150,7 +149,7 @@ unboxArg arg
 
   -- Recursive newtypes
   | Just rep_ty <- splitNewType_maybe arg_ty
-  = unboxArg (mkCoerce rep_ty arg_ty arg)
+  = unboxArg (mkCoerce2 rep_ty arg_ty arg)
       
   -- Booleans
   | Just (tc,_) <- splitTyConApp_maybe arg_ty, 
@@ -220,11 +219,6 @@ boxResult :: [Id] -> Type -> DsM (Type, CoreExpr -> CoreExpr)
 -- the result type will be 
 --	State# RealWorld -> (# State# RealWorld #)
 
--- Here is where we arrange that ForeignPtrs which are passed to a 'safe'
--- foreign import don't get finalized until the call returns.  For each
--- argument of type ForeignObj# we arrange to touch# the argument after
--- the call.  The arg_ids passed in are the Ids passed to the actual ccall.
-
 boxResult arg_ids result_ty
   = case tcSplitTyConApp_maybe result_ty of
 	-- This split absolutely has to be a tcSplit, because we must
@@ -267,13 +261,11 @@ boxResult arg_ids result_ty
   where
     mk_alt return_result (Nothing, wrap_result)
 	= 	-- The ccall returns ()
-	  let
-		rhs_fun state_id = return_result (Var state_id) 
-					(wrap_result (panic "boxResult"))
-	  in
 	  newSysLocalDs realWorldStatePrimTy	`thenDs` \ state_id ->
-	  mkTouches arg_ids state_id rhs_fun	`thenDs` \ the_rhs ->
 	  let
+		the_rhs = return_result (Var state_id) 
+					(wrap_result (panic "boxResult"))
+
 		ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy]
 		the_alt      = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs)
 	  in
@@ -282,28 +274,16 @@ boxResult arg_ids result_ty
     mk_alt return_result (Just prim_res_ty, wrap_result)
 	=	-- The ccall returns a non-() value
 	  newSysLocalDs prim_res_ty 		`thenDs` \ result_id ->
-	  let
-		rhs_fun state_id = return_result (Var state_id) 
-					(wrap_result (Var result_id))
-	  in
 	  newSysLocalDs realWorldStatePrimTy	`thenDs` \ state_id ->
-	  mkTouches arg_ids state_id rhs_fun	`thenDs` \ the_rhs ->
 	  let
+		the_rhs = return_result (Var state_id) 
+					(wrap_result (Var result_id))
+
 		ccall_res_ty = mkTyConApp unboxedPairTyCon [realWorldStatePrimTy, prim_res_ty]
 		the_alt	     = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs)
 	  in
 	  returnDs (ccall_res_ty, the_alt)
 
-touchzh = mkPrimOpId TouchOp
-
-mkTouches []     s cont = returnDs (cont s)
-mkTouches (v:vs) s cont
-  | not (idType v `eqType` foreignObjPrimTy) = mkTouches vs s cont
-  | otherwise = newSysLocalDs realWorldStatePrimTy `thenDs` \s' -> 
-		mkTouches vs s' cont `thenDs` \ rest ->
-	        returnDs (Case (mkApps (Var touchzh) [Type foreignObjPrimTy, 
-						      Var v, Var s]) s' 
-				[(DEFAULT, [], rest)])
 
 resultWrapper :: Type
    	      -> (Maybe Type,		-- Type of the expected result, if any
@@ -328,7 +308,15 @@ resultWrapper result_ty
   = let
         (maybe_ty, wrapper) = resultWrapper rep_ty
     in
-    (maybe_ty, \e -> mkCoerce result_ty rep_ty (wrapper e))
+    (maybe_ty, \e -> mkCoerce2 result_ty rep_ty (wrapper e))
+
+  -- The type might contain foralls (eg. for dummy type arguments,
+  -- referring to 'Ptr a' is legal).
+  | Just (tyvar, rest) <- splitForAllTy_maybe result_ty
+  = let
+        (maybe_ty, wrapper) = resultWrapper rest
+    in
+    (maybe_ty, \e -> Lam tyvar (wrapper e))
 
   -- Data types with a single constructor, which has a single arg
   | Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitProductType_maybe result_ty,