2 % (c) The AQUA Project, Glasgow University, 1994-1996
4 \section[DsCCall]{Desugaring \tr{_ccall_}s and \tr{_casm_}s}
7 #include "HsVersions.h"
9 module DsCCall ( dsCCall ) where
18 import CoreUtils ( coreExprType )
19 import Id ( getInstantiatedDataConSig, mkTupleCon )
20 import Maybes ( maybeToBool )
21 import PprStyle ( PprStyle(..) )
22 import PprType ( GenType{-instances-}, GenTyVar{-instance-} )
23 import PrelInfo ( byteArrayPrimTy, getStatePairingConInfo,
24 packStringForCId, realWorldStatePrimTy,
25 realWorldStateTy, realWorldTy, stateDataCon,
28 import PrimOp ( PrimOp(..) )
29 import Type ( isPrimType, maybeAppDataTyCon, eqTy )
30 import TyVar ( GenTyVar{-instance-} )
31 import Unique ( Unique{-instances-} )
32 import Util ( pprPanic, panic )
34 maybeBoxedPrimType = panic "DsCCall.maybeBoxedPrimType"
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 @\ 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 type)
80 dsCCall label args may_gc is_asm result_ty
81 = newSysLocalDs realWorldStateTy `thenDs` \ old_s ->
83 mapAndUnzipDs unboxArg (Var old_s : args) `thenDs` \ (final_args, arg_wrappers) ->
85 boxResult result_ty `thenDs` \ (final_result_ty, res_wrapper) ->
88 the_ccall_op = CCallOp label is_asm may_gc
89 (map coreExprType final_args)
93 [] -- ***NOTE*** no ty apps; the types are inside the_ccall_op.
94 final_args `thenDs` \ the_prim_app ->
96 the_body = foldr apply (res_wrapper the_prim_app) arg_wrappers
98 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.
114 = returnDs (arg, \body -> body)
117 | arg_ty `eqTy` stringTy
118 -- ToDo (ADR): - allow synonyms of Strings too?
119 = newSysLocalDs byteArrayPrimTy `thenDs` \ prim_arg ->
120 mkAppDs (Var packStringForCId) [] [arg] `thenDs` \ pack_appn ->
121 returnDs (Var prim_arg,
122 \body -> Case pack_appn (PrimAlts []
123 (BindDefault prim_arg body))
127 -- oops: we can't see the data constructors!!!
128 = can't_see_datacons_error "argument" arg_ty
130 -- Byte-arrays, both mutable and otherwise
131 -- (HACKy method -- but we really don't want the TyCons wired-in...) [WDP 94/10]
133 length data_con_arg_tys == 2 &&
134 not (isPrimType data_con_arg_ty1) &&
135 isPrimType data_con_arg_ty2
136 -- and, of course, it is an instance of _CCallable
137 -- ( tycon == byteArrayTyCon ||
138 -- tycon == mutableByteArrayTyCon )
139 = newSysLocalsDs data_con_arg_tys `thenDs` \ vars@[ixs_var, arr_cts_var] ->
140 returnDs (Var arr_cts_var,
141 \ body -> Case arg (AlgAlts [(the_data_con,vars,body)]
145 -- Data types with a single constructor, which has a single, primitive-typed arg
146 | maybeToBool maybe_boxed_prim_arg_ty
147 = newSysLocalDs the_prim_arg_ty `thenDs` \ prim_arg ->
148 returnDs (Var prim_arg,
149 \ body -> Case arg (AlgAlts [(box_data_con,[prim_arg],body)]
152 -- ... continued below ....
155 As an experiment, I'm going to unpack any "acceptably small"
156 enumeration. This code will never get used in the main version
157 because enumerations would have triggered type errors but I've
158 disabled type-checking in my version. ADR
160 To Will: It might be worth leaving this in (but commented out) until
161 we decide what's happening with enumerations. ADR
166 -- Data types with a nullary constructors (enumeration)
167 | isEnumerationType arg_ty && -- enumeration
168 (length data_cons) <= 5 -- "acceptably short"
169 = newSysLocalDs the_prim_arg_ty `thenDs` \ prim_arg ->
172 alts = [ (con, [], mkMachInt i) | (con,i) <- data_cons `zip` [0..] ]
173 arg_tag = Case arg (AlgAlts alts) NoDefault
176 returnDs (Var prim_arg,
177 \ body -> Case arg_tag (PrimAlts [(prim_arg, body)] NoDefault)
183 -- ... continued from above ....
185 = pprPanic "unboxArg: " (ppr PprDebug arg_ty)
187 arg_ty = coreExprType arg
189 maybe_boxed_prim_arg_ty = maybeBoxedPrimType arg_ty
190 (Just (box_data_con, the_prim_arg_ty)) = maybe_boxed_prim_arg_ty
192 maybe_data_type = maybeAppDataTyCon arg_ty
193 is_data_type = maybeToBool maybe_data_type
194 (Just (tycon, tycon_arg_tys, data_cons)) = maybe_data_type
195 (the_data_con : other_data_cons) = data_cons
197 (_, data_con_arg_tys, _) = getInstantiatedDataConSig the_data_con tycon_arg_tys
198 (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
200 can't_see_datacons_error thing ty
201 = error (ppShow 100 (ppBesides [ppStr "ERROR: Can't see the data constructor(s) for _ccall_/_casm_ ", ppStr thing, ppStr "; type: ", ppr PprForUser ty]))
206 tuple_con_2 = mkTupleCon 2 -- out here to avoid CAF (sigh)
207 covar_tuple_con_0 = Var (mkTupleCon 0) -- ditto
209 boxResult :: Type -- Type of desired result
210 -> DsM (Type, -- Type of the result of the ccall itself
211 CoreExpr -> CoreExpr) -- Wrapper for the ccall
215 -- oops! can't see the data constructors
216 = can't_see_datacons_error "result" result_ty
218 -- Data types with a single constructor, which has a single, primitive-typed arg
219 | (maybeToBool maybe_data_type) && -- Data type
220 (null other_data_cons) && -- Just one constr
221 not (null data_con_arg_tys) && null other_args_tys && -- Just one arg
222 isPrimType the_prim_result_ty -- of primitive type
224 newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id ->
225 newSysLocalDs the_prim_result_ty `thenDs` \ prim_result_id ->
227 mkConDs stateDataCon [realWorldTy] [Var prim_state_id] `thenDs` \ new_state ->
228 mkConDs the_data_con tycon_arg_tys [Var prim_result_id] `thenDs` \ the_result ->
231 [result_ty, realWorldStateTy]
232 [the_result, new_state] `thenDs` \ the_pair ->
234 the_alt = (state_and_prim_datacon, [prim_state_id, prim_result_id], the_pair)
236 returnDs (state_and_prim_ty,
237 \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
240 -- Data types with a single nullary constructor
241 | (maybeToBool maybe_data_type) && -- Data type
242 (null other_data_cons) && -- Just one constr
243 (null data_con_arg_tys)
245 newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id ->
247 mkConDs stateDataCon [realWorldTy] [Var prim_state_id] `thenDs` \ new_state ->
250 [result_ty, realWorldStateTy]
251 [covar_tuple_con_0, new_state] `thenDs` \ the_pair ->
254 the_alt = (stateDataCon, [prim_state_id], the_pair)
256 returnDs (realWorldStateTy,
257 \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
263 -- Data types with several nullary constructors (Enumerated types)
264 | isEnumerationType result_ty && -- Enumeration
265 (length data_cons) <= 5 -- fairly short
267 newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id ->
268 newSysLocalDs intPrimTy `thenDs` \ prim_result_id ->
270 mkConDs stateDataCon [realWorldTy] [Var prim_state_id] `thenDs` \ new_state ->
273 alts = [ (mkMachInt i, con) | (i, con) <- [0..] `zip` data_cons ]
274 the_result = Case prim_result_id (PrimAlts alts) NoDefault
277 mkConDs (mkTupleCon 2)
278 [result_ty, realWorldStateTy]
279 [the_result, new_state] `thenDs` \ the_pair ->
281 the_alt = (state_and_prim_datacon, [prim_state_id, prim_result_id], the_pair)
283 returnDs (state_and_prim_ty,
284 \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
289 = pprPanic "boxResult: " (ppr PprDebug result_ty)
292 maybe_data_type = maybeAppDataTyCon result_ty
293 Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
294 (the_data_con : other_data_cons) = data_cons
296 (_, data_con_arg_tys, _) = getInstantiatedDataConSig the_data_con tycon_arg_tys
297 (the_prim_result_ty : other_args_tys) = data_con_arg_tys
299 (state_and_prim_datacon, state_and_prim_ty) = getStatePairingConInfo the_prim_result_ty