2 % (c) The AQUA Project, Glasgow University, 1994-1996
4 \section[DsCCall]{Desugaring \tr{_ccall_}s and \tr{_casm_}s}
7 module DsCCall ( dsCCall ) where
9 #include "HsVersions.h"
16 import TcHsSyn ( maybeBoxedPrimType )
17 import CoreUtils ( coreExprType )
18 import Id ( Id(..), dataConArgTys, idType )
19 import Maybes ( maybeToBool )
20 import PprType ( GenType{-instances-} )
21 import PrelVals ( packStringForCId )
22 import PrimOp ( PrimOp(..) )
23 import Type ( isUnpointedType, splitAlgTyConApp_maybe,
24 splitTyConApp_maybe, splitFunTys, splitForAllTys,
27 import TyCon ( tyConDataCons )
28 import TysPrim ( byteArrayPrimTy, realWorldStatePrimTy,
29 byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
30 import TysWiredIn ( getStatePairingConInfo,
31 unitDataCon, stringTy,
32 realWorldStateTy, stateDataCon
37 Desugaring of @ccall@s consists of adding some state manipulation,
38 unboxing any boxed primitive arguments and boxing the result if
41 The state stuff just consists of adding in
42 @PrimIO (\ s -> case s of { S# s# -> ... })@ in an appropriate place.
44 The unboxing is straightforward, as all information needed to unbox is
45 available from the type. For each boxed-primitive argument, we
48 _ccall_ foo [ r, t1, ... tm ] e1 ... em
52 case e1 of { T1# x1# ->
54 case em of { Tm# xm# -> xm#
55 ccall# foo [ r, t1#, ... tm# ] x1# ... xm#
59 The reboxing of a @_ccall_@ result is a bit tricker: the types don't
60 contain information about the state-pairing functions so we have to
61 keep a list of \tr{(type, s-p-function)} pairs. We transform as
64 ccall# foo [ r, t1#, ... tm# ] e1# ... em#
68 \ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of
69 (StateAnd<r># result# state#) -> (R# result#, realWorld#)
73 dsCCall :: FAST_STRING -- C routine to invoke
74 -> [CoreExpr] -- Arguments (desugared)
75 -> Bool -- True <=> might cause Haskell GC
76 -> Bool -- True <=> really a "_casm_"
77 -> Type -- Type of the result (a boxed-prim IO type)
80 dsCCall label args may_gc is_asm io_result_ty
81 = newSysLocalDs realWorldStatePrimTy `thenDs` \ old_s ->
83 mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) ->
85 final_args = Var old_s : unboxed_args
86 (ioOkDataCon, result_ty) = getIoOkDataCon io_result_ty
89 boxResult ioOkDataCon result_ty `thenDs` \ (final_result_ty, res_wrapper) ->
92 the_ccall_op = CCallOp label is_asm may_gc
93 (map coreExprType final_args)
96 mkPrimDs the_ccall_op (map VarArg final_args) `thenDs` \ the_prim_app ->
98 the_body = foldr ($) (res_wrapper the_prim_app) arg_wrappers
100 returnDs (Lam (ValBinder old_s) the_body)
104 unboxArg :: CoreExpr -- The supplied argument
105 -> DsM (CoreExpr, -- To pass as the actual argument
106 CoreExpr -> CoreExpr -- Wrapper to unbox the arg
111 -- ADR Question: can this ever be used? None of the PrimTypes are
112 -- instances of the CCallable class.
115 -- Oh yes they are, I've just added them :-) Having _ccall_ and _casm_
116 -- that accept unboxed arguments is a Good Thing if you have a stub generator
117 -- which generates the boiler-plate box-unbox code for you, i.e., it may help
118 -- us nuke this very module :-)
120 | isUnpointedType arg_ty
121 = returnDs (arg, \body -> body)
125 -- ToDo (ADR): - allow synonyms of Strings too?
126 = newSysLocalDs byteArrayPrimTy `thenDs` \ prim_arg ->
127 mkAppDs (Var packStringForCId) [VarArg arg] `thenDs` \ pack_appn ->
128 returnDs (Var prim_arg,
129 \body -> Case pack_appn (PrimAlts []
130 (BindDefault prim_arg body))
134 -- oops: we can't see the data constructors!!!
135 = can't_see_datacons_error "argument" arg_ty
137 -- Byte-arrays, both mutable and otherwise; hack warning
139 length data_con_arg_tys == 2 &&
140 maybeToBool maybe_arg2_tycon &&
141 (arg2_tycon == byteArrayPrimTyCon ||
142 arg2_tycon == mutableByteArrayPrimTyCon)
143 -- and, of course, it is an instance of CCallable
144 = newSysLocalsDs data_con_arg_tys `thenDs` \ vars@[ixs_var, arr_cts_var] ->
145 returnDs (Var arr_cts_var,
146 \ body -> Case arg (AlgAlts [(the_data_con,vars,body)]
150 -- Data types with a single constructor, which has a single, primitive-typed arg
151 | maybeToBool maybe_boxed_prim_arg_ty
152 = newSysLocalDs the_prim_arg_ty `thenDs` \ prim_arg ->
153 returnDs (Var prim_arg,
154 \ body -> Case arg (AlgAlts [(box_data_con,[prim_arg],body)]
159 = getSrcLocDs `thenDs` \ l ->
160 pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
162 arg_ty = coreExprType arg
164 maybe_boxed_prim_arg_ty = maybeBoxedPrimType arg_ty
165 (Just (box_data_con, the_prim_arg_ty)) = maybe_boxed_prim_arg_ty
167 maybe_data_type = splitAlgTyConApp_maybe arg_ty
168 is_data_type = maybeToBool maybe_data_type
169 (Just (tycon, tycon_arg_tys, data_cons)) = maybe_data_type
170 (the_data_con : other_data_cons) = data_cons
172 data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys
173 (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
175 maybe_arg2_tycon = splitTyConApp_maybe data_con_arg_ty2
176 Just (arg2_tycon,_) = maybe_arg2_tycon
178 can't_see_datacons_error thing ty
179 = pprPanic "ERROR: Can't see the data constructor(s) for _ccall_/_casm_ "
180 (hcat [text thing, text "; type: ", ppr ty, text "(try compiling with -fno-prune-tydecls ..)\n"])
185 boxResult :: Id -- IOok constructor
186 -> Type -- Type of desired result
187 -> DsM (Type, -- Type of the result of the ccall itself
188 CoreExpr -> CoreExpr) -- Wrapper for the ccall
190 boxResult ioOkDataCon result_ty
192 -- oops! can't see the data constructors
193 = can't_see_datacons_error "result" result_ty
195 -- Data types with a single constructor, which has a single, primitive-typed arg
196 | (maybeToBool maybe_data_type) && -- Data type
197 (null other_data_cons) && -- Just one constr
198 not (null data_con_arg_tys) && null other_args_tys && -- Just one arg
199 isUnpointedType the_prim_result_ty -- of primitive type
201 newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id ->
202 newSysLocalDs the_prim_result_ty `thenDs` \ prim_result_id ->
204 mkConDs the_data_con (map TyArg tycon_arg_tys ++ [VarArg (Var prim_result_id)]) `thenDs` \ the_result ->
207 [TyArg result_ty, VarArg (Var prim_state_id), VarArg the_result]
208 `thenDs` \ the_pair ->
210 the_alt = (state_and_prim_datacon, [prim_state_id, prim_result_id], the_pair)
212 returnDs (state_and_prim_ty,
213 \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
216 -- Data types with a single nullary constructor
217 | (maybeToBool maybe_data_type) && -- Data type
218 (null other_data_cons) && -- Just one constr
219 (null data_con_arg_tys)
221 newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id ->
224 [TyArg result_ty, VarArg (Var prim_state_id), VarArg (Var unitDataCon)]
225 `thenDs` \ the_pair ->
228 the_alt = (stateDataCon, [prim_state_id], the_pair)
230 returnDs (realWorldStateTy,
231 \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
235 = pprPanic "boxResult: " (ppr result_ty)
238 maybe_data_type = splitAlgTyConApp_maybe result_ty
239 Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
240 (the_data_con : other_data_cons) = data_cons
242 data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys
243 (the_prim_result_ty : other_args_tys) = data_con_arg_tys
245 (state_and_prim_datacon, state_and_prim_ty) = getStatePairingConInfo the_prim_result_ty
248 This grimy bit of code is for digging out the IOok constructor from an
249 application of the the IO type. The constructor is needed for
250 wrapping the result of a _ccall_. The alternative is to wire-in IO,
251 which brings a whole heap of junk with it.
253 If the representation of IO changes, this will probably have to be
254 brought in line with the new definition.
256 newtype IO a = IO (State# RealWorld -> IOResult a)
258 the constructor IO has type (State# RealWorld -> IOResult a) -> IO a
261 getIoOkDataCon :: Type -- IO t
262 -> (Id,Type) -- Returns (IOok, t)
266 Just (ioTyCon, [t]) = splitTyConApp_maybe io_ty
267 [ioDataCon] = tyConDataCons ioTyCon
268 ioDataConTy = idType ioDataCon
269 (_, ioDataConTy') = splitForAllTys ioDataConTy
270 ([arg_ty], _) = splitFunTys ioDataConTy'
271 (_, io_result_ty) = splitFunTys arg_ty
272 Just (io_result_tycon, _) = splitTyConApp_maybe io_result_ty
273 [ioOkDataCon,ioFailDataCon] = tyConDataCons io_result_tycon
278 Another way to do it, more sensitive:
281 ForAll _ (FunTy (FunTy _ (AppTy (TyConTy ioResultTyCon _) _)) _) ->
282 let [ioOkDataCon,ioFailDataCon] = tyConDataCons ioResultTyCon
284 (ioOkDataCon, result_ty)
285 _ -> pprPanic "getIoOkDataCon: " (ppr PprDebug ioDataConTy)