X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsCCall.lhs;h=58ebc26b2b0890342a201ddfc406f5398a15bdbf;hp=27dff948394a72451cacebe797a8545d33b4115c;hb=8133a9f47b99f4e65ed30551de32ad72c6b61b27;hpb=703ca1542c8e0983cc9d8eebce6e9f3dd3fd71e2

diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs
index 27dff94..58ebc26 100644
--- a/compiler/deSugar/DsCCall.lhs
+++ b/compiler/deSugar/DsCCall.lhs
@@ -88,10 +88,10 @@ dsCCall :: CLabelString	-- C routine to invoke
 
 dsCCall lbl args may_gc result_ty
   = do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args
-       (ccall_result_ty, res_wrapper) <- boxResult id Nothing result_ty
+       (ccall_result_ty, res_wrapper) <- boxResult result_ty
        uniq <- newUnique
        let
-           target = StaticTarget lbl
+           target = StaticTarget lbl Nothing
            the_fcall    = CCall (CCallSpec target CCallConv may_gc)
            the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
        return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
@@ -231,10 +231,7 @@ unboxArg arg
 
 
 \begin{code}
-boxResult :: ((Maybe Type, CoreExpr -> CoreExpr)
-		 -> (Maybe Type, CoreExpr -> CoreExpr))
-	  -> Maybe Id
-	  -> Type
+boxResult :: Type
 	  -> DsM (Type, CoreExpr -> CoreExpr)
 
 -- Takes the result of the user-level ccall: 
@@ -247,11 +244,8 @@ boxResult :: ((Maybe Type, CoreExpr -> CoreExpr)
 -- where t' is the unwrapped form of t.  If t is simply (), then
 -- the result type will be 
 --	State# RealWorld -> (# State# RealWorld #)
---
--- The gruesome 'augment' and 'mbTopCon' are to do with .NET foreign calls
--- It looks a mess: I wonder if it could be refactored.
 
-boxResult augment mbTopCon result_ty
+boxResult result_ty
   | Just (io_tycon, io_res_ty, co) <- tcSplitIOType_maybe result_ty
 	-- isIOType_maybe handles the case where the type is a 
 	-- simple wrapping of IO.  E.g.
@@ -261,9 +255,8 @@ boxResult augment mbTopCon result_ty
 	-- another case, and a coercion.)
    	-- The result is IO t, so wrap the result in an IO constructor
   = do	{ res <- resultWrapper io_res_ty
-	; let aug_res = augment res
-	      extra_result_tys 
-		= case aug_res of
+	; let extra_result_tys 
+		= case res of
 		     (Just ty,_) 
 		       | isUnboxedTupleType ty 
 		       -> let (Just (_, ls)) = splitTyConApp_maybe ty in tail ls
@@ -274,13 +267,13 @@ boxResult augment mbTopCon result_ty
 	         	   (map Type (realWorldStatePrimTy : io_res_ty : extra_result_tys)
 			      ++ (state : anss)) 
 
-	; (ccall_res_ty, the_alt) <- mk_alt return_result aug_res
+	; (ccall_res_ty, the_alt) <- mk_alt return_result res
 
 	; state_id <- newSysLocalDs realWorldStatePrimTy
 	; let io_data_con = head (tyConDataCons io_tycon)
-	      toIOCon     = mbTopCon `orElse` dataConWrapId io_data_con
+	      toIOCon     = dataConWrapId io_data_con
 
-	      wrap the_call = mkCoerceI (mkSymCoI co) $
+	      wrap the_call = mkCoerce (mkSymCo co) $
 			      mkApps (Var toIOCon)
 			    	     [ Type io_res_ty, 
 			    	       Lam state_id $
@@ -292,11 +285,11 @@ boxResult augment mbTopCon result_ty
 
 	; return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) }
 
-boxResult augment _mbTopCon result_ty
+boxResult result_ty
   = do -- It isn't IO, so do unsafePerformIO
        -- It's not conveniently available, so we inline it
        res <- resultWrapper result_ty
-       (ccall_res_ty, the_alt) <- mk_alt return_result (augment res)
+       (ccall_res_ty, the_alt) <- mk_alt return_result res
        let
            wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId)) 
                                      	   ccall_res_ty
@@ -379,7 +372,7 @@ resultWrapper result_ty
   -- Recursive newtypes
   | Just (rep_ty, co) <- splitNewTypeRepCo_maybe result_ty
   = do (maybe_ty, wrapper) <- resultWrapper rep_ty
-       return (maybe_ty, \e -> mkCoerce (mkSymCoercion co) (wrapper e))
+       return (maybe_ty, \e -> mkCoerce (mkSymCo co) (wrapper e))
 
   -- The type might contain foralls (eg. for dummy type arguments,
   -- referring to 'Ptr a' is legal).