2 % (c) The AQUA Project, Glasgow University, 1994-1996
4 \section[DsCCall]{Desugaring \tr{_ccall_}s and \tr{_casm_}s}
13 , can'tSeeDataConsPanic
16 #include "HsVersions.h"
23 import TcHsSyn ( maybeBoxedPrimType )
24 import CoreUtils ( coreExprType )
25 import Id ( Id, dataConArgTys, idType )
26 import Maybes ( maybeToBool )
27 import PrelVals ( packStringForCId )
28 import PrimOp ( PrimOp(..) )
30 import Type ( isUnpointedType, splitAlgTyConApp_maybe,
31 splitTyConApp_maybe, splitFunTys, splitForAllTys,
34 import TyCon ( tyConDataCons )
35 import TysPrim ( byteArrayPrimTy, realWorldStatePrimTy,
36 byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
37 import TysWiredIn ( getStatePairingConInfo,
38 unitDataCon, stringTy,
39 realWorldStateTy, stateDataCon
44 Desugaring of @ccall@s consists of adding some state manipulation,
45 unboxing any boxed primitive arguments and boxing the result if
48 The state stuff just consists of adding in
49 @PrimIO (\ s -> case s of { S# s# -> ... })@ in an appropriate place.
51 The unboxing is straightforward, as all information needed to unbox is
52 available from the type. For each boxed-primitive argument, we
55 _ccall_ foo [ r, t1, ... tm ] e1 ... em
59 case e1 of { T1# x1# ->
61 case em of { Tm# xm# -> xm#
62 ccall# foo [ r, t1#, ... tm# ] x1# ... xm#
66 The reboxing of a @_ccall_@ result is a bit tricker: the types don't
67 contain information about the state-pairing functions so we have to
68 keep a list of \tr{(type, s-p-function)} pairs. We transform as
71 ccall# foo [ r, t1#, ... tm# ] e1# ... em#
75 \ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of
76 (StateAnd<r># result# state#) -> (R# result#, realWorld#)
80 dsCCall :: FAST_STRING -- C routine to invoke
81 -> [CoreExpr] -- Arguments (desugared)
82 -> Bool -- True <=> might cause Haskell GC
83 -> Bool -- True <=> really a "_casm_"
84 -> Type -- Type of the result (a boxed-prim IO type)
87 dsCCall label args may_gc is_asm io_result_ty
88 = newSysLocalDs realWorldStatePrimTy `thenDs` \ old_s ->
90 mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) ->
92 final_args = Var old_s : unboxed_args
93 (ioOkDataCon, _, result_ty) = getIoOkDataCon io_result_ty
96 boxResult ioOkDataCon result_ty `thenDs` \ (final_result_ty, res_wrapper) ->
99 the_ccall_op = CCallOp (Left label) is_asm may_gc cCallConv
100 (map coreExprType final_args)
103 mkPrimDs the_ccall_op (map VarArg final_args) `thenDs` \ the_prim_app ->
105 the_body = foldr ($) (res_wrapper the_prim_app) arg_wrappers
107 returnDs (Lam (ValBinder old_s) the_body)
111 unboxArg :: CoreExpr -- The supplied argument
112 -> DsM (CoreExpr, -- To pass as the actual argument
113 CoreExpr -> CoreExpr -- Wrapper to unbox the arg
118 -- ADR Question: can this ever be used? None of the PrimTypes are
119 -- instances of the CCallable class.
122 -- Oh yes they are, I've just added them :-) Having _ccall_ and _casm_
123 -- that accept unboxed arguments is a Good Thing if you have a stub generator
124 -- which generates the boiler-plate box-unbox code for you, i.e., it may help
125 -- us nuke this very module :-)
127 | isUnpointedType arg_ty
128 = returnDs (arg, \body -> body)
132 = newSysLocalDs byteArrayPrimTy `thenDs` \ prim_arg ->
133 mkAppDs (Var packStringForCId) [VarArg arg] `thenDs` \ pack_appn ->
134 returnDs (Var prim_arg,
135 \body -> Case pack_appn (PrimAlts []
136 (BindDefault prim_arg body))
140 -- oops: we can't see the data constructors!!!
141 = can'tSeeDataConsPanic "argument" arg_ty
143 -- Byte-arrays, both mutable and otherwise; hack warning
145 length data_con_arg_tys == 2 &&
146 maybeToBool maybe_arg2_tycon &&
147 (arg2_tycon == byteArrayPrimTyCon ||
148 arg2_tycon == mutableByteArrayPrimTyCon)
149 -- and, of course, it is an instance of CCallable
150 = newSysLocalsDs data_con_arg_tys `thenDs` \ vars@[ixs_var, arr_cts_var] ->
151 returnDs (Var arr_cts_var,
152 \ body -> Case arg (AlgAlts [(the_data_con,vars,body)]
156 -- Data types with a single constructor, which has a single, primitive-typed arg
157 | maybeToBool maybe_boxed_prim_arg_ty
158 = newSysLocalDs the_prim_arg_ty `thenDs` \ prim_arg ->
159 returnDs (Var prim_arg,
160 \ body -> Case arg (AlgAlts [(box_data_con,[prim_arg],body)]
165 = getSrcLocDs `thenDs` \ l ->
166 pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
168 arg_ty = coreExprType arg
170 maybe_boxed_prim_arg_ty = maybeBoxedPrimType arg_ty
171 (Just (box_data_con, the_prim_arg_ty)) = maybe_boxed_prim_arg_ty
173 maybe_data_type = splitAlgTyConApp_maybe arg_ty
174 is_data_type = maybeToBool maybe_data_type
175 (Just (tycon, tycon_arg_tys, data_cons)) = maybe_data_type
176 (the_data_con : other_data_cons) = data_cons
178 data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys
179 (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
181 maybe_arg2_tycon = splitTyConApp_maybe data_con_arg_ty2
182 Just (arg2_tycon,_) = maybe_arg2_tycon
184 can'tSeeDataConsPanic thing ty
185 = pprPanic "ERROR: Can't see the data constructor(s) for _ccall_/_casm_/foreign declaration"
186 (hcat [text thing, text "; type: ", ppr ty, text "(try compiling with -fno-prune-tydecls ..)\n"])
191 boxResult :: Id -- IOok constructor
192 -> Type -- Type of desired result
193 -> DsM (Type, -- Type of the result of the ccall itself
194 CoreExpr -> CoreExpr) -- Wrapper for the ccall
196 boxResult ioOkDataCon result_ty
198 -- oops! can't see the data constructors
199 = can'tSeeDataConsPanic "result" result_ty
201 -- Data types with a single constructor, which has a single, primitive-typed arg
202 | (maybeToBool maybe_data_type) && -- Data type
203 (null other_data_cons) && -- Just one constr
204 not (null data_con_arg_tys) && null other_args_tys && -- Just one arg
205 isUnpointedType the_prim_result_ty -- of primitive type
207 newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id ->
208 newSysLocalDs the_prim_result_ty `thenDs` \ prim_result_id ->
210 mkConDs the_data_con (map TyArg tycon_arg_tys ++ [VarArg (Var prim_result_id)]) `thenDs` \ the_result ->
213 [TyArg result_ty, VarArg (Var prim_state_id), VarArg the_result]
214 `thenDs` \ the_pair ->
216 the_alt = (state_and_prim_datacon, [prim_state_id, prim_result_id], the_pair)
218 returnDs (state_and_prim_ty,
219 \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
222 -- Data types with a single nullary constructor
223 | (maybeToBool maybe_data_type) && -- Data type
224 (null other_data_cons) && -- Just one constr
225 (null data_con_arg_tys)
227 newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id ->
230 [TyArg result_ty, VarArg (Var prim_state_id), VarArg (Var unitDataCon)]
231 `thenDs` \ the_pair ->
234 the_alt = (stateDataCon, [prim_state_id], the_pair)
236 returnDs (realWorldStateTy,
237 \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
241 = pprPanic "boxResult: " (ppr result_ty)
244 maybe_data_type = splitAlgTyConApp_maybe result_ty
245 Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
246 (the_data_con : other_data_cons) = data_cons
248 data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys
249 (the_prim_result_ty : other_args_tys) = data_con_arg_tys
251 (state_and_prim_datacon, state_and_prim_ty) = getStatePairingConInfo the_prim_result_ty
254 This grimy bit of code is for digging out the IOok constructor from an
255 application of the the IO type. The constructor is needed for
256 wrapping the result of a _ccall_. The alternative is to wire-in IO,
257 which brings a whole heap of junk with it.
259 If the representation of IO changes, this will probably have to be
260 brought in line with the new definition.
262 newtype IO a = IO (State# RealWorld -> IOResult a)
264 the constructor IO has type (State# RealWorld -> IOResult a) -> IO a
267 getIoOkDataCon :: Type -- IO t
268 -> (Id, Id, Type) -- Returns (IOok, IO, t)
272 Just (ioTyCon, [t]) = splitTyConApp_maybe io_ty
273 [ioDataCon] = tyConDataCons ioTyCon
274 ioDataConTy = idType ioDataCon
275 (_, ioDataConTy') = splitForAllTys ioDataConTy
276 ([arg_ty], _) = splitFunTys ioDataConTy'
277 (_, io_result_ty) = splitFunTys arg_ty
278 Just (io_result_tycon, _) = splitTyConApp_maybe io_result_ty
279 [ioOkDataCon,ioFailDataCon] = tyConDataCons io_result_tycon
281 (ioOkDataCon, ioDataCon, t)
284 Another way to do it, more sensitive:
287 ForAll _ (FunTy (FunTy _ (AppTy (TyConTy ioResultTyCon _) _)) _) ->
288 let [ioOkDataCon,ioFailDataCon] = tyConDataCons ioResultTyCon
290 (ioOkDataCon, result_ty)
291 _ -> pprPanic "getIoOkDataCon: " (ppr PprDebug ioDataConTy)