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 ( dataConArgTys, mkTupleCon )
20 import Maybes ( maybeToBool )
21 import PprStyle ( PprStyle(..) )
22 import PprType ( GenType{-instances-} )
23 import PrelInfo ( byteArrayPrimTy, getStatePairingConInfo,
24 packStringForCId, realWorldStatePrimTy,
25 realWorldStateTy, realWorldTy, stateDataCon,
28 import PrimOp ( PrimOp(..) )
29 import Type ( isPrimType, maybeAppDataTyCon, eqTy )
30 import Util ( pprPanic, pprError, panic )
32 maybeBoxedPrimType = panic "DsCCall.maybeBoxedPrimType"
35 Desugaring of @ccall@s consists of adding some state manipulation,
36 unboxing any boxed primitive arguments and boxing the result if
39 The state stuff just consists of adding in
40 @\ s -> case s of { S# s# -> ... }@ in an appropriate place.
42 The unboxing is straightforward, as all information needed to unbox is
43 available from the type. For each boxed-primitive argument, we
46 _ccall_ foo [ r, t1, ... tm ] e1 ... em
50 case e1 of { T1# x1# ->
52 case em of { Tm# xm# -> xm#
53 ccall# foo [ r, t1#, ... tm# ] x1# ... xm#
57 The reboxing of a @_ccall_@ result is a bit tricker: the types don't
58 contain information about the state-pairing functions so we have to
59 keep a list of \tr{(type, s-p-function)} pairs. We transform as
62 ccall# foo [ r, t1#, ... tm# ] e1# ... em#
66 \ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of
67 (StateAnd<r># result# state#) -> (R# result#, realWorld#)
71 dsCCall :: FAST_STRING -- C routine to invoke
72 -> [CoreExpr] -- Arguments (desugared)
73 -> Bool -- True <=> might cause Haskell GC
74 -> Bool -- True <=> really a "_casm_"
75 -> Type -- Type of the result (a boxed-prim type)
78 dsCCall label args may_gc is_asm result_ty
79 = newSysLocalDs realWorldStateTy `thenDs` \ old_s ->
81 mapAndUnzipDs unboxArg (Var old_s : args) `thenDs` \ (final_args, arg_wrappers) ->
83 boxResult result_ty `thenDs` \ (final_result_ty, res_wrapper) ->
86 the_ccall_op = CCallOp label is_asm may_gc
87 (map coreExprType final_args)
91 [] -- ***NOTE*** no ty apps; the types are inside the_ccall_op.
92 final_args `thenDs` \ the_prim_app ->
94 the_body = foldr apply (res_wrapper the_prim_app) arg_wrappers
96 returnDs (Lam (ValBinder old_s) the_body)
102 unboxArg :: CoreExpr -- The supplied argument
103 -> DsM (CoreExpr, -- To pass as the actual argument
104 CoreExpr -> CoreExpr -- Wrapper to unbox the arg
109 -- ADR Question: can this ever be used? None of the PrimTypes are
110 -- instances of the CCallable class.
112 = returnDs (arg, \body -> body)
115 | arg_ty `eqTy` stringTy
116 -- ToDo (ADR): - allow synonyms of Strings too?
117 = newSysLocalDs byteArrayPrimTy `thenDs` \ prim_arg ->
118 mkAppDs (Var packStringForCId) [] [arg] `thenDs` \ pack_appn ->
119 returnDs (Var prim_arg,
120 \body -> Case pack_appn (PrimAlts []
121 (BindDefault prim_arg body))
125 -- oops: we can't see the data constructors!!!
126 = can't_see_datacons_error "argument" arg_ty
128 -- Byte-arrays, both mutable and otherwise
129 -- (HACKy method -- but we really don't want the TyCons wired-in...) [WDP 94/10]
131 length data_con_arg_tys == 2 &&
132 not (isPrimType data_con_arg_ty1) &&
133 isPrimType data_con_arg_ty2
134 -- and, of course, it is an instance of CCallable
135 -- ( tycon == byteArrayTyCon ||
136 -- tycon == mutableByteArrayTyCon )
137 = newSysLocalsDs data_con_arg_tys `thenDs` \ vars@[ixs_var, arr_cts_var] ->
138 returnDs (Var arr_cts_var,
139 \ body -> Case arg (AlgAlts [(the_data_con,vars,body)]
143 -- Data types with a single constructor, which has a single, primitive-typed arg
144 | maybeToBool maybe_boxed_prim_arg_ty
145 = newSysLocalDs the_prim_arg_ty `thenDs` \ prim_arg ->
146 returnDs (Var prim_arg,
147 \ body -> Case arg (AlgAlts [(box_data_con,[prim_arg],body)]
150 -- ... continued below ....
153 As an experiment, I'm going to unpack any "acceptably small"
154 enumeration. This code will never get used in the main version
155 because enumerations would have triggered type errors but I've
156 disabled type-checking in my version. ADR
158 To Will: It might be worth leaving this in (but commented out) until
159 we decide what's happening with enumerations. ADR
164 -- Data types with a nullary constructors (enumeration)
165 | isEnumerationType arg_ty && -- enumeration
166 (length data_cons) <= 5 -- "acceptably short"
167 = newSysLocalDs the_prim_arg_ty `thenDs` \ prim_arg ->
170 alts = [ (con, [], mkMachInt i) | (con,i) <- data_cons `zip` [0..] ]
171 arg_tag = Case arg (AlgAlts alts) NoDefault
174 returnDs (Var prim_arg,
175 \ body -> Case arg_tag (PrimAlts [(prim_arg, body)] NoDefault)
181 -- ... continued from above ....
183 = pprPanic "unboxArg: " (ppr PprDebug arg_ty)
185 arg_ty = coreExprType arg
187 maybe_boxed_prim_arg_ty = maybeBoxedPrimType arg_ty
188 (Just (box_data_con, the_prim_arg_ty)) = maybe_boxed_prim_arg_ty
190 maybe_data_type = maybeAppDataTyCon arg_ty
191 is_data_type = maybeToBool maybe_data_type
192 (Just (tycon, tycon_arg_tys, data_cons)) = maybe_data_type
193 (the_data_con : other_data_cons) = data_cons
195 data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys
196 (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
198 can't_see_datacons_error thing ty
199 = pprError "ERROR: Can't see the data constructor(s) for _ccall_/_casm_ "
200 (ppBesides [ppStr thing, ppStr "; type: ", ppr PprForUser ty])
205 tuple_con_2 = mkTupleCon 2 -- out here to avoid CAF (sigh)
206 covar_tuple_con_0 = Var (mkTupleCon 0) -- ditto
208 boxResult :: Type -- Type of desired result
209 -> DsM (Type, -- Type of the result of the ccall itself
210 CoreExpr -> CoreExpr) -- Wrapper for the ccall
214 -- oops! can't see the data constructors
215 = can't_see_datacons_error "result" result_ty
217 -- Data types with a single constructor, which has a single, primitive-typed arg
218 | (maybeToBool maybe_data_type) && -- Data type
219 (null other_data_cons) && -- Just one constr
220 not (null data_con_arg_tys) && null other_args_tys && -- Just one arg
221 isPrimType the_prim_result_ty -- of primitive type
223 newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id ->
224 newSysLocalDs the_prim_result_ty `thenDs` \ prim_result_id ->
226 mkConDs stateDataCon [realWorldTy] [Var prim_state_id] `thenDs` \ new_state ->
227 mkConDs the_data_con tycon_arg_tys [Var prim_result_id] `thenDs` \ the_result ->
230 [result_ty, realWorldStateTy]
231 [the_result, new_state] `thenDs` \ the_pair ->
233 the_alt = (state_and_prim_datacon, [prim_state_id, prim_result_id], the_pair)
235 returnDs (state_and_prim_ty,
236 \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
239 -- Data types with a single nullary constructor
240 | (maybeToBool maybe_data_type) && -- Data type
241 (null other_data_cons) && -- Just one constr
242 (null data_con_arg_tys)
244 newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id ->
246 mkConDs stateDataCon [realWorldTy] [Var prim_state_id] `thenDs` \ new_state ->
249 [result_ty, realWorldStateTy]
250 [covar_tuple_con_0, new_state] `thenDs` \ the_pair ->
253 the_alt = (stateDataCon, [prim_state_id], the_pair)
255 returnDs (realWorldStateTy,
256 \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
262 -- Data types with several nullary constructors (Enumerated types)
263 | isEnumerationType result_ty && -- Enumeration
264 (length data_cons) <= 5 -- fairly short
266 newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id ->
267 newSysLocalDs intPrimTy `thenDs` \ prim_result_id ->
269 mkConDs stateDataCon [realWorldTy] [Var prim_state_id] `thenDs` \ new_state ->
272 alts = [ (mkMachInt i, con) | (i, con) <- [0..] `zip` data_cons ]
273 the_result = Case prim_result_id (PrimAlts alts) NoDefault
276 mkConDs (mkTupleCon 2)
277 [result_ty, realWorldStateTy]
278 [the_result, new_state] `thenDs` \ the_pair ->
280 the_alt = (state_and_prim_datacon, [prim_state_id, prim_result_id], the_pair)
282 returnDs (state_and_prim_ty,
283 \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
288 = pprPanic "boxResult: " (ppr PprDebug result_ty)
291 maybe_data_type = maybeAppDataTyCon result_ty
292 Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
293 (the_data_con : other_data_cons) = data_cons
295 data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys
296 (the_prim_result_ty : other_args_tys) = data_con_arg_tys
298 (state_and_prim_datacon, state_and_prim_ty) = getStatePairingConInfo the_prim_result_ty