2 % (c) The AQUA Project, Glasgow University, 1994-1998
4 \section[DsCCall]{Desugaring C calls}
15 #include "HsVersions.h"
22 import CoreUtils ( exprType, mkCoerce2 )
23 import Id ( Id, mkWildId )
24 import MkId ( mkFCallId, realWorldPrimId, mkPrimOpId )
25 import Maybes ( maybeToBool )
26 import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety,
27 CCallConv(..), CLabelString )
28 import DataCon ( splitProductType_maybe, dataConSourceArity, dataConWrapId )
29 import ForeignCall ( ForeignCall, CCallTarget(..) )
31 import TcType ( tcSplitTyConApp_maybe )
32 import Type ( Type, isUnLiftedType, mkFunTys, mkFunTy,
33 tyVarsOfType, mkForAllTys, mkTyConApp,
34 isPrimitiveType, splitTyConApp_maybe,
35 splitRecNewType_maybe, splitForAllTy_maybe,
39 import PrimOp ( PrimOp(..) )
40 import TysPrim ( realWorldStatePrimTy, intPrimTy,
41 byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
44 import TyCon ( TyCon, tyConDataCons, tyConName )
45 import TysWiredIn ( unitDataConId,
46 unboxedSingletonDataCon, unboxedPairDataCon,
47 unboxedSingletonTyCon, unboxedPairTyCon,
48 trueDataCon, falseDataCon,
49 trueDataConId, falseDataConId,
53 import BasicTypes ( Boxity(..) )
54 import Literal ( mkMachInt )
55 import PrelNames ( Unique, hasKey, ioTyConKey, boolTyConKey, unitTyConKey,
56 int8TyConKey, int16TyConKey, int32TyConKey,
57 word8TyConKey, word16TyConKey, word32TyConKey
59 , marshalStringName, unmarshalStringName
60 , marshalObjectName, unmarshalObjectName
63 import VarSet ( varSetElems )
64 import Constants ( wORD_SIZE)
73 Desugaring of @ccall@s consists of adding some state manipulation,
74 unboxing any boxed primitive arguments and boxing the result if
77 The state stuff just consists of adding in
78 @PrimIO (\ s -> case s of { S# s# -> ... })@ in an appropriate place.
80 The unboxing is straightforward, as all information needed to unbox is
81 available from the type. For each boxed-primitive argument, we
84 _ccall_ foo [ r, t1, ... tm ] e1 ... em
88 case e1 of { T1# x1# ->
90 case em of { Tm# xm# -> xm#
91 ccall# foo [ r, t1#, ... tm# ] x1# ... xm#
95 The reboxing of a @_ccall_@ result is a bit tricker: the types don't
96 contain information about the state-pairing functions so we have to
97 keep a list of \tr{(type, s-p-function)} pairs. We transform as
100 ccall# foo [ r, t1#, ... tm# ] e1# ... em#
104 \ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of
105 (StateAnd<r># result# state#) -> (R# result#, realWorld#)
109 dsCCall :: CLabelString -- C routine to invoke
110 -> [CoreExpr] -- Arguments (desugared)
111 -> Safety -- Safety of the call
112 -> Type -- Type of the result: IO t
115 dsCCall lbl args may_gc result_ty
116 = mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) ->
117 boxResult [] id Nothing result_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
118 newUnique `thenDs` \ uniq ->
120 target = StaticTarget lbl
121 the_fcall = CCall (CCallSpec target CCallConv may_gc)
122 the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
124 returnDs (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
126 mkFCall :: Unique -> ForeignCall
127 -> [CoreExpr] -- Args
128 -> Type -- Result type
130 -- Construct the ccall. The only tricky bit is that the ccall Id should have
131 -- no free vars, so if any of the arg tys do we must give it a polymorphic type.
132 -- [I forget *why* it should have no free vars!]
134 -- mkCCall ... [s::StablePtr (a->b), x::Addr, c::Char]
136 -- Here we build a ccall thus
137 -- (ccallid::(forall a b. StablePtr (a -> b) -> Addr -> Char -> IO Addr))
139 mkFCall uniq the_fcall val_args res_ty
140 = mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args
142 arg_tys = map exprType val_args
143 body_ty = (mkFunTys arg_tys res_ty)
144 tyvars = varSetElems (tyVarsOfType body_ty)
145 ty = mkForAllTys tyvars body_ty
146 the_fcall_id = mkFCallId uniq the_fcall ty
150 unboxArg :: CoreExpr -- The supplied argument
151 -> DsM (CoreExpr, -- To pass as the actual argument
152 CoreExpr -> CoreExpr -- Wrapper to unbox the arg
154 -- Example: if the arg is e::Int, unboxArg will return
155 -- (x#::Int#, \W. case x of I# x# -> W)
156 -- where W is a CoreExpr that probably mentions x#
159 -- Primtive types: nothing to unbox
160 | isPrimitiveType arg_ty
161 = returnDs (arg, \body -> body)
163 -- Recursive newtypes
164 | Just rep_ty <- splitRecNewType_maybe arg_ty
165 = unboxArg (mkCoerce2 rep_ty arg_ty arg)
168 | Just (tc,_) <- splitTyConApp_maybe arg_ty,
169 tc `hasKey` boolTyConKey
170 = newSysLocalDs intPrimTy `thenDs` \ prim_arg ->
171 returnDs (Var prim_arg,
172 \ body -> Case (Case arg (mkWildId arg_ty)
173 [(DataAlt falseDataCon,[],mkIntLit 0),
174 (DataAlt trueDataCon, [],mkIntLit 1)])
178 -- Data types with a single constructor, which has a single, primitive-typed arg
179 -- This deals with Int, Float etc; also Ptr, ForeignPtr
180 | is_product_type && data_con_arity == 1
181 = ASSERT2(isUnLiftedType data_con_arg_ty1, pprType arg_ty)
182 -- Typechecker ensures this
183 newSysLocalDs arg_ty `thenDs` \ case_bndr ->
184 newSysLocalDs data_con_arg_ty1 `thenDs` \ prim_arg ->
185 returnDs (Var prim_arg,
186 \ body -> Case arg case_bndr [(DataAlt data_con,[prim_arg],body)]
189 -- Byte-arrays, both mutable and otherwise; hack warning
190 -- We're looking for values of type ByteArray, MutableByteArray
191 -- data ByteArray ix = ByteArray ix ix ByteArray#
192 -- data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)
194 data_con_arity == 3 &&
195 maybeToBool maybe_arg3_tycon &&
196 (arg3_tycon == byteArrayPrimTyCon ||
197 arg3_tycon == mutableByteArrayPrimTyCon)
198 -- and, of course, it is an instance of CCallable
199 = newSysLocalDs arg_ty `thenDs` \ case_bndr ->
200 newSysLocalsDs data_con_arg_tys `thenDs` \ vars@[l_var, r_var, arr_cts_var] ->
201 returnDs (Var arr_cts_var,
202 \ body -> Case arg case_bndr [(DataAlt data_con,vars,body)]
205 | Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty,
207 Just (cc,[]) <- splitTyConApp_maybe arg_ty,
209 -- String; dotnet only
210 = dsLookupGlobalId marshalStringName `thenDs` \ unpack_id ->
211 newSysLocalDs addrPrimTy `thenDs` \ prim_string ->
212 returnDs (Var prim_string,
215 io_ty = exprType body
216 (Just (_,[io_arg])) = tcSplitTyConApp_maybe io_ty
218 mkApps (Var unpack_id)
221 , Lam prim_string body
223 | Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty,
224 tyConName tc == objectTyConName
225 -- Object; dotnet only
226 = dsLookupGlobalId marshalObjectName `thenDs` \ unpack_id ->
227 newSysLocalDs addrPrimTy `thenDs` \ prim_obj ->
228 returnDs (Var prim_obj,
231 io_ty = exprType body
232 (Just (_,[io_arg])) = tcSplitTyConApp_maybe io_ty
234 mkApps (Var unpack_id)
241 = getSrcSpanDs `thenDs` \ l ->
242 pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
244 arg_ty = exprType arg
245 maybe_product_type = splitProductType_maybe arg_ty
246 is_product_type = maybeToBool maybe_product_type
247 Just (_, _, data_con, data_con_arg_tys) = maybe_product_type
248 data_con_arity = dataConSourceArity data_con
249 (data_con_arg_ty1 : _) = data_con_arg_tys
251 (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys
252 maybe_arg3_tycon = splitTyConApp_maybe data_con_arg_ty3
253 Just (arg3_tycon,_) = maybe_arg3_tycon
259 -> ((Maybe Type, CoreExpr -> CoreExpr) -> (Maybe Type, CoreExpr -> CoreExpr))
262 -> DsM (Type, CoreExpr -> CoreExpr)
264 -- Takes the result of the user-level ccall:
266 -- or maybe just t for an side-effect-free call
267 -- Returns a wrapper for the primitive ccall itself, along with the
268 -- type of the result of the primitive ccall. This result type
269 -- will be of the form
270 -- State# RealWorld -> (# State# RealWorld, t' #)
271 -- where t' is the unwrapped form of t. If t is simply (), then
272 -- the result type will be
273 -- State# RealWorld -> (# State# RealWorld #)
275 boxResult arg_ids augment mbTopCon result_ty
276 = case tcSplitTyConApp_maybe result_ty of
277 -- This split absolutely has to be a tcSplit, because we must
278 -- see the IO type; and it's a newtype which is transparent to splitTyConApp.
280 -- The result is IO t, so wrap the result in an IO constructor
281 Just (io_tycon, [io_res_ty]) | io_tycon `hasKey` ioTyConKey
282 -> resultWrapper io_res_ty `thenDs` \ res ->
283 let aug_res = augment res
287 | isUnboxedTupleType ty ->
288 let (Just (_, ls)) = splitTyConApp_maybe ty in tail ls
291 mk_alt (return_result extra_result_tys) aug_res
292 `thenDs` \ (ccall_res_ty, the_alt) ->
293 newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
295 io_data_con = head (tyConDataCons io_tycon)
298 Nothing -> dataConWrapId io_data_con
304 Case (App the_call (Var state_id))
305 (mkWildId ccall_res_ty)
309 returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
311 return_result ts state anss
312 = mkConApp (tupleCon Unboxed (2 + length ts))
313 (Type realWorldStatePrimTy : Type io_res_ty : map Type ts ++
315 -- It isn't, so do unsafePerformIO
316 -- It's not conveniently available, so we inline it
317 other -> resultWrapper result_ty `thenDs` \ res ->
318 mk_alt return_result (augment res) `thenDs` \ (ccall_res_ty, the_alt) ->
320 wrap = \ the_call -> Case (App the_call (Var realWorldPrimId))
321 (mkWildId ccall_res_ty)
324 returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
326 return_result state [ans] = ans
327 return_result _ _ = panic "return_result: expected single result"
329 mk_alt return_result (Nothing, wrap_result)
330 = -- The ccall returns ()
331 newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
333 the_rhs = return_result (Var state_id)
334 [wrap_result (panic "boxResult")]
336 ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy]
337 the_alt = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs)
339 returnDs (ccall_res_ty, the_alt)
341 mk_alt return_result (Just prim_res_ty, wrap_result)
342 -- The ccall returns a non-() value
343 | isUnboxedTupleType prim_res_ty
345 Just (_, ls) = splitTyConApp_maybe prim_res_ty
346 arity = 1 + length ls
348 mappM newSysLocalDs ls `thenDs` \ args_ids@(result_id:as) ->
349 newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
351 the_rhs = return_result (Var state_id)
352 (wrap_result (Var result_id) : map Var as)
353 ccall_res_ty = mkTyConApp (tupleTyCon Unboxed arity)
354 (realWorldStatePrimTy : ls)
355 the_alt = ( DataAlt (tupleCon Unboxed arity)
356 , (state_id : args_ids)
360 returnDs (ccall_res_ty, the_alt)
362 = newSysLocalDs prim_res_ty `thenDs` \ result_id ->
363 newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
365 the_rhs = return_result (Var state_id)
366 [wrap_result (Var result_id)]
368 ccall_res_ty = mkTyConApp unboxedPairTyCon [realWorldStatePrimTy, prim_res_ty]
369 the_alt = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs)
371 returnDs (ccall_res_ty, the_alt)
374 resultWrapper :: Type
375 -> DsM (Maybe Type, -- Type of the expected result, if any
376 CoreExpr -> CoreExpr) -- Wrapper for the result
377 resultWrapper result_ty
378 -- Base case 1: primitive types
379 | isPrimitiveType result_ty
380 = returnDs (Just result_ty, \e -> e)
382 -- Base case 2: the unit type ()
383 | Just (tc,_) <- maybe_tc_app, tc `hasKey` unitTyConKey
384 = returnDs (Nothing, \e -> Var unitDataConId)
386 -- Base case 3: the boolean type
387 | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey
389 (Just intPrimTy, \e -> Case e (mkWildId intPrimTy)
390 [(DEFAULT ,[],Var trueDataConId ),
391 (LitAlt (mkMachInt 0),[],Var falseDataConId)])
393 -- Recursive newtypes
394 | Just rep_ty <- splitRecNewType_maybe result_ty
395 = resultWrapper rep_ty `thenDs` \ (maybe_ty, wrapper) ->
396 returnDs (maybe_ty, \e -> mkCoerce2 result_ty rep_ty (wrapper e))
398 -- The type might contain foralls (eg. for dummy type arguments,
399 -- referring to 'Ptr a' is legal).
400 | Just (tyvar, rest) <- splitForAllTy_maybe result_ty
401 = resultWrapper rest `thenDs` \ (maybe_ty, wrapper) ->
402 returnDs (maybe_ty, \e -> Lam tyvar (wrapper e))
404 -- Data types with a single constructor, which has a single arg
405 -- This includes types like Ptr and ForeignPtr
406 | Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitProductType_maybe result_ty,
407 dataConSourceArity data_con == 1
409 (unwrapped_res_ty : _) = data_con_arg_tys
410 narrow_wrapper = maybeNarrow tycon
412 resultWrapper unwrapped_res_ty `thenDs` \ (maybe_ty, wrapper) ->
414 (maybe_ty, \e -> mkApps (Var (dataConWrapId data_con))
415 (map Type tycon_arg_tys ++ [wrapper (narrow_wrapper e)]))
417 -- Strings; 'dotnet' only.
418 | Just (tc, [arg_ty]) <- maybe_tc_app, tc == listTyCon,
419 Just (cc,[]) <- splitTyConApp_maybe arg_ty, cc == charTyCon
420 = dsLookupGlobalId unmarshalStringName `thenDs` \ pack_id ->
421 returnDs (Just addrPrimTy,
422 \ e -> App (Var pack_id) e)
424 -- Objects; 'dotnet' only.
425 | Just (tc, [arg_ty]) <- maybe_tc_app,
426 tyConName tc == objectTyConName
427 = dsLookupGlobalId unmarshalObjectName `thenDs` \ pack_id ->
428 returnDs (Just addrPrimTy,
429 \ e -> App (Var pack_id) e)
432 = pprPanic "resultWrapper" (ppr result_ty)
434 maybe_tc_app = splitTyConApp_maybe result_ty
436 -- When the result of a foreign call is smaller than the word size, we
437 -- need to sign- or zero-extend the result up to the word size. The C
438 -- standard appears to say that this is the responsibility of the
439 -- caller, not the callee.
441 maybeNarrow :: TyCon -> (CoreExpr -> CoreExpr)
443 | tycon `hasKey` int8TyConKey = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e
444 | tycon `hasKey` int16TyConKey = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e
445 | tycon `hasKey` int32TyConKey
446 && wORD_SIZE > 4 = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e
448 | tycon `hasKey` word8TyConKey = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e
449 | tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e
450 | tycon `hasKey` word32TyConKey
451 && wORD_SIZE > 4 = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e