X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsCCall.lhs;h=fca20df03dd1f04fd83a2d8fb521af8d1d9fb751;hb=8a2809c29de9f23eba7ca682b48390033a9d40f6;hp=2ee9d08fb013dfa3de4d58a205ec5168994bdd9e;hpb=f2dcf256399e9a2de6343c625630b51f8abf4863;p=ghc-hetmet.git

diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs
index 2ee9d08..fca20df 100644
--- a/compiler/deSugar/DsCCall.lhs
+++ b/compiler/deSugar/DsCCall.lhs
@@ -1,7 +1,9 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The AQUA Project, Glasgow University, 1994-1998
 %
-\section[DsCCall]{Desugaring C calls}
+
+Desugaring foreign calls
 
 \begin{code}
 module DsCCall 
@@ -19,48 +21,25 @@ import CoreSyn
 
 import DsMonad
 
-import CoreUtils	( exprType, coreAltType, mkCoerce2 )
-import Id		( Id, mkWildId )
-import MkId		( mkFCallId, realWorldPrimId, mkPrimOpId )
-import Maybes		( maybeToBool )
-import ForeignCall	( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety, 
-			  CCallConv(..), CLabelString )
-import DataCon		( splitProductType_maybe, dataConSourceArity, dataConWrapId )
-
-import TcType		( tcSplitIOType_maybe )
-import Type		( Type, isUnLiftedType, mkFunTys, mkFunTy,
-			  tyVarsOfType, mkForAllTys, mkTyConApp, 
-			  isPrimitiveType, splitTyConApp_maybe, 
-			  splitRecNewType_maybe, splitForAllTy_maybe,
-			  isUnboxedTupleType
-			)
-
-import PrimOp		( PrimOp(..) )
-import TysPrim		( realWorldStatePrimTy, intPrimTy,
-			  byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
-			  addrPrimTy
-			)
-import TyCon		( TyCon, tyConDataCons, tyConName )
-import TysWiredIn	( unitDataConId,
-			  unboxedSingletonDataCon, unboxedPairDataCon,
-			  unboxedSingletonTyCon, unboxedPairTyCon,
-			  trueDataCon, falseDataCon, 
-			  trueDataConId, falseDataConId,
-			  listTyCon, charTyCon, boolTy, 
-			  tupleTyCon, tupleCon
-			)
-import BasicTypes       ( Boxity(..) )
-import Literal		( mkMachInt )
-import PrelNames	( Unique, hasKey, boolTyConKey, unitTyConKey,
-			  int8TyConKey, int16TyConKey, int32TyConKey,
-			  word8TyConKey, word16TyConKey, word32TyConKey
-			  -- dotnet interop
-			  , marshalStringName, unmarshalStringName
-			  , marshalObjectName, unmarshalObjectName
-			  , objectTyConName
-			)
-import VarSet		( varSetElems )
-import Constants	( wORD_SIZE)
+import CoreUtils
+import Id
+import MkId
+import Maybes
+import ForeignCall
+import DataCon
+
+import TcType
+import Type
+import Coercion
+import PrimOp
+import TysPrim
+import TyCon
+import TysWiredIn
+import BasicTypes
+import Literal
+import PrelNames
+import VarSet
+import Constants
 import Outputable
 
 #ifdef DEBUG
@@ -109,7 +88,7 @@ dsCCall :: CLabelString	-- C routine to invoke
 	-> [CoreExpr]	-- Arguments (desugared)
 	-> Safety	-- Safety of the call
 	-> Type		-- Type of the result: IO t
-	-> DsM CoreExpr
+	-> DsM CoreExpr	-- Result, of type ???
 
 dsCCall lbl args may_gc result_ty
   = mapAndUnzipDs unboxArg args	       `thenDs` \ (unboxed_args, arg_wrappers) ->
@@ -160,8 +139,8 @@ unboxArg arg
   = returnDs (arg, \body -> body)
 
   -- Recursive newtypes
-  | Just rep_ty <- splitRecNewType_maybe arg_ty
-  = unboxArg (mkCoerce2 rep_ty arg_ty arg)
+  | Just(rep_ty, co) <- splitNewTypeRepCo_maybe arg_ty
+  = unboxArg (mkCoerce co arg)
       
   -- Booleans
   | Just (tc,_) <- splitTyConApp_maybe arg_ty, 
@@ -399,9 +378,9 @@ resultWrapper result_ty
 				    (LitAlt (mkMachInt 0),[],Var falseDataConId)])
 
   -- Recursive newtypes
-  | Just rep_ty <- splitRecNewType_maybe result_ty
+  | Just (rep_ty, co) <- splitNewTypeRepCo_maybe result_ty
   = resultWrapper rep_ty `thenDs` \ (maybe_ty, wrapper) ->
-    returnDs (maybe_ty, \e -> mkCoerce2 result_ty rep_ty (wrapper e))
+    returnDs (maybe_ty, \e -> mkCoerce (mkSymCoercion co) (wrapper e))
 
   -- The type might contain foralls (eg. for dummy type arguments,
   -- referring to 'Ptr a' is legal).