X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=inline;f=ghc%2Fcompiler%2FdeSugar%2FDsCCall.lhs;h=73630c661ce6a31de326773a1d776a0c26a27da4;hb=ce3cab1dc3f3d03d43cf1b8cfc848c1ccaa00a84;hp=91f0101ed321aeaf2c57bbb52fc7927b0aff0f10;hpb=14ac360a0651770f9297134e55bf5ba796689035;p=ghc-hetmet.git

diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs
index 91f0101..73630c6 100644
--- a/ghc/compiler/deSugar/DsCCall.lhs
+++ b/ghc/compiler/deSugar/DsCCall.lhs
@@ -4,7 +4,14 @@
 \section[DsCCall]{Desugaring \tr{_ccall_}s and \tr{_casm_}s}
 
 \begin{code}
-module DsCCall ( dsCCall ) where
+module DsCCall 
+	( 
+	   dsCCall 
+	,  getIoOkDataCon
+	,  unboxArg
+	,  boxResult
+	,  can'tSeeDataConsPanic
+	) where
 
 #include "HsVersions.h"
 
@@ -19,6 +26,7 @@ import Id		( Id, dataConArgTys, idType )
 import Maybes		( maybeToBool )
 import PrelVals		( packStringForCId )
 import PrimOp		( PrimOp(..) )
+import CallConv
 import Type		( isUnpointedType, splitAlgTyConApp_maybe, 
 			  splitTyConApp_maybe, splitFunTys, splitForAllTys,
 			  Type
@@ -82,13 +90,13 @@ dsCCall label args may_gc is_asm io_result_ty
     mapAndUnzipDs unboxArg args	`thenDs` \ (unboxed_args, arg_wrappers) ->
     let
 	 final_args = Var old_s : unboxed_args
-	 (ioOkDataCon, result_ty) = getIoOkDataCon io_result_ty
+	 (ioOkDataCon, _, result_ty) = getIoOkDataCon io_result_ty
     in
 
     boxResult ioOkDataCon result_ty `thenDs` \ (final_result_ty, res_wrapper) ->
 
     let
-	the_ccall_op = CCallOp label is_asm may_gc
+	the_ccall_op = CCallOp (Just label) is_asm may_gc cCallConv
 			       (map coreExprType final_args)
 			       final_result_ty
     in
@@ -121,7 +129,6 @@ unboxArg arg
 
   -- Strings
   | arg_ty == stringTy
-  -- ToDo (ADR): - allow synonyms of Strings too?
   = newSysLocalDs byteArrayPrimTy		`thenDs` \ prim_arg ->
     mkAppDs (Var packStringForCId) [VarArg arg]	`thenDs` \ pack_appn ->
     returnDs (Var prim_arg,
@@ -131,7 +138,7 @@ unboxArg arg
 
   | null data_cons
     -- oops: we can't see the data constructors!!!
-  = can't_see_datacons_error "argument" arg_ty
+  = can'tSeeDataConsPanic "argument" arg_ty
 
   -- Byte-arrays, both mutable and otherwise; hack warning
   | is_data_type &&
@@ -174,8 +181,8 @@ unboxArg arg
     maybe_arg2_tycon = splitTyConApp_maybe data_con_arg_ty2
     Just (arg2_tycon,_) = maybe_arg2_tycon
 
-can't_see_datacons_error thing ty
-  = pprPanic "ERROR: Can't see the data constructor(s) for _ccall_/_casm_ "
+can'tSeeDataConsPanic thing ty
+  = pprPanic "ERROR: Can't see the data constructor(s) for _ccall_/_casm_/foreign declaration"
 	     (hcat [text thing, text "; type: ", ppr ty, text "(try compiling with -fno-prune-tydecls ..)\n"])
 \end{code}
 
@@ -189,7 +196,7 @@ boxResult :: Id				-- IOok constructor
 boxResult ioOkDataCon result_ty
   | null data_cons
   -- oops! can't see the data constructors
-  = can't_see_datacons_error "result" result_ty
+  = can'tSeeDataConsPanic "result" result_ty
 
   -- Data types with a single constructor, which has a single, primitive-typed arg
   | (maybeToBool maybe_data_type) &&				-- Data type
@@ -257,8 +264,8 @@ newtype IO a = IO (State# RealWorld -> IOResult a)
 the constructor IO has type (State# RealWorld -> IOResult a) -> IO a
 
 \begin{code}
-getIoOkDataCon :: Type 		-- IO t
-	       -> (Id,Type)	-- Returns (IOok, t)
+getIoOkDataCon :: Type 		 -- IO t
+	       -> (Id, Id, Type) -- Returns (IOok, IO, t)
 
 getIoOkDataCon io_ty
   = let 
@@ -271,7 +278,7 @@ getIoOkDataCon io_ty
 	Just (io_result_tycon, _)	= splitTyConApp_maybe io_result_ty
 	[ioOkDataCon,ioFailDataCon]     = tyConDataCons io_result_tycon
     in
-    (ioOkDataCon, t)
+    (ioOkDataCon, ioDataCon, t)
 \end{code}
 
 Another way to do it, more sensitive: