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
13 import CmdLineOpts (opt_PprUserLength)
19 import CoreUtils ( coreExprType )
20 import Id ( dataConArgTys, dataConTyCon, idType )
21 import Maybes ( maybeToBool )
22 import Outputable ( PprStyle(..), Outputable(..) )
23 import PprType ( GenType{-instances-} )
25 import PrelVals ( packStringForCId )
26 import PrimOp ( PrimOp(..) )
27 import Type ( isPrimType, maybeAppDataTyConExpandingDicts, maybeAppTyCon,
28 eqTy, maybeBoxedPrimType, SYN_IE(Type), GenType(..),
29 splitFunTy, splitForAllTy, splitAppTys )
30 import TyCon ( tyConDataCons )
31 import TysPrim ( byteArrayPrimTy, realWorldTy, realWorldStatePrimTy,
32 byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
33 import TysWiredIn ( getStatePairingConInfo,
34 unitDataCon, stringTy,
35 realWorldStateTy, stateDataCon
37 import Util ( pprPanic, pprError, panic )
41 Desugaring of @ccall@s consists of adding some state manipulation,
42 unboxing any boxed primitive arguments and boxing the result if
45 The state stuff just consists of adding in
46 @PrimIO (\ s -> case s of { S# s# -> ... })@ in an appropriate place.
48 The unboxing is straightforward, as all information needed to unbox is
49 available from the type. For each boxed-primitive argument, we
52 _ccall_ foo [ r, t1, ... tm ] e1 ... em
56 case e1 of { T1# x1# ->
58 case em of { Tm# xm# -> xm#
59 ccall# foo [ r, t1#, ... tm# ] x1# ... xm#
63 The reboxing of a @_ccall_@ result is a bit tricker: the types don't
64 contain information about the state-pairing functions so we have to
65 keep a list of \tr{(type, s-p-function)} pairs. We transform as
68 ccall# foo [ r, t1#, ... tm# ] e1# ... em#
72 \ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of
73 (StateAnd<r># result# state#) -> (R# result#, realWorld#)
77 dsCCall :: FAST_STRING -- C routine to invoke
78 -> [CoreExpr] -- Arguments (desugared)
79 -> Bool -- True <=> might cause Haskell GC
80 -> Bool -- True <=> really a "_casm_"
81 -> Type -- Type of the result (a boxed-prim IO type)
84 dsCCall label args may_gc is_asm io_result_ty
85 = newSysLocalDs realWorldStatePrimTy `thenDs` \ old_s ->
87 mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) ->
89 final_args = Var old_s : unboxed_args
90 (ioOkDataCon, result_ty) = getIoOkDataCon io_result_ty
93 boxResult ioOkDataCon result_ty `thenDs` \ (final_result_ty, res_wrapper) ->
96 the_ccall_op = CCallOp label is_asm may_gc
97 (map coreExprType final_args)
100 mkPrimDs the_ccall_op (map VarArg final_args) `thenDs` \ the_prim_app ->
102 the_body = foldr ($) (res_wrapper the_prim_app) arg_wrappers
104 returnDs (Lam (ValBinder old_s) the_body)
108 unboxArg :: CoreExpr -- The supplied argument
109 -> DsM (CoreExpr, -- To pass as the actual argument
110 CoreExpr -> CoreExpr -- Wrapper to unbox the arg
115 -- ADR Question: can this ever be used? None of the PrimTypes are
116 -- instances of the CCallable class.
119 -- Oh yes they are, I've just added them :-) Having _ccall_ and _casm_
120 -- that accept unboxed arguments is a Good Thing if you have a stub generator
121 -- which generates the boiler-plate box-unbox code for you, i.e., it may help
122 -- us nuke this very module :-)
125 = returnDs (arg, \body -> body)
128 | arg_ty `eqTy` stringTy
129 -- ToDo (ADR): - allow synonyms of Strings too?
130 = newSysLocalDs byteArrayPrimTy `thenDs` \ prim_arg ->
131 mkAppDs (Var packStringForCId) [VarArg arg] `thenDs` \ pack_appn ->
132 returnDs (Var prim_arg,
133 \body -> Case pack_appn (PrimAlts []
134 (BindDefault prim_arg body))
138 -- oops: we can't see the data constructors!!!
139 = can't_see_datacons_error "argument" arg_ty
141 -- Byte-arrays, both mutable and otherwise; hack warning
143 length data_con_arg_tys == 2 &&
144 maybeToBool maybe_arg2_tycon &&
145 (arg2_tycon == byteArrayPrimTyCon ||
146 arg2_tycon == mutableByteArrayPrimTyCon)
147 -- and, of course, it is an instance of CCallable
148 = newSysLocalsDs data_con_arg_tys `thenDs` \ vars@[ixs_var, arr_cts_var] ->
149 returnDs (Var arr_cts_var,
150 \ body -> Case arg (AlgAlts [(the_data_con,vars,body)]
154 -- Data types with a single constructor, which has a single, primitive-typed arg
155 | maybeToBool maybe_boxed_prim_arg_ty
156 = newSysLocalDs the_prim_arg_ty `thenDs` \ prim_arg ->
157 returnDs (Var prim_arg,
158 \ body -> Case arg (AlgAlts [(box_data_con,[prim_arg],body)]
163 = pprPanic "unboxArg: " (ppr PprDebug arg_ty)
165 arg_ty = coreExprType arg
167 maybe_boxed_prim_arg_ty = maybeBoxedPrimType arg_ty
168 (Just (box_data_con, the_prim_arg_ty)) = maybe_boxed_prim_arg_ty
170 maybe_data_type = maybeAppDataTyConExpandingDicts arg_ty
171 is_data_type = maybeToBool maybe_data_type
172 (Just (tycon, tycon_arg_tys, data_cons)) = maybe_data_type
173 (the_data_con : other_data_cons) = data_cons
175 data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys
176 (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
178 maybe_arg2_tycon = maybeAppTyCon data_con_arg_ty2
179 Just (arg2_tycon,_) = maybe_arg2_tycon
181 can't_see_datacons_error thing ty
182 = pprError "ERROR: Can't see the data constructor(s) for _ccall_/_casm_ "
183 (hcat [text thing, text "; type: ", ppr (PprForUser opt_PprUserLength) ty, text "(try compiling with -fno-prune-tydecls ..)\n"])
188 boxResult :: Id -- IOok constructor
189 -> Type -- Type of desired result
190 -> DsM (Type, -- Type of the result of the ccall itself
191 CoreExpr -> CoreExpr) -- Wrapper for the ccall
193 boxResult ioOkDataCon result_ty
195 -- oops! can't see the data constructors
196 = can't_see_datacons_error "result" result_ty
198 -- Data types with a single constructor,
199 -- which has a single, primitive-typed arg.
200 | (maybeToBool maybe_data_type) && -- Data type
201 (null other_data_cons) && -- Just one constr
202 not (null data_con_arg_tys) && null other_args_tys && -- Just one arg
203 isPrimType the_prim_result_ty -- of primitive type
205 newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id ->
206 newSysLocalDs the_prim_result_ty `thenDs` \ prim_result_id ->
208 mkConDs the_data_con (map TyArg tycon_arg_tys ++ [VarArg (Var prim_result_id)]) `thenDs` \ the_result ->
211 [TyArg result_ty, VarArg (Var prim_state_id), VarArg the_result]
212 `thenDs` \ the_pair ->
214 the_alt = (state_and_prim_datacon, [prim_state_id, prim_result_id], the_pair)
216 returnDs (state_and_prim_ty,
217 \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
220 -- Data types with a single nullary constructor
221 | (maybeToBool maybe_data_type) && -- Data type
222 (null other_data_cons) && -- Just one constr
223 (null data_con_arg_tys)
225 newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id ->
228 [TyArg result_ty, VarArg (Var prim_state_id), VarArg (Var unitDataCon)]
229 `thenDs` \ the_pair ->
232 the_alt = (stateDataCon, [prim_state_id], the_pair)
234 returnDs (realWorldStateTy,
235 \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
239 = pprPanic "boxResult: " (ppr PprDebug result_ty)
242 maybe_data_type = maybeAppDataTyConExpandingDicts result_ty
243 Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
244 (the_data_con : other_data_cons) = data_cons
246 data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys
247 (the_prim_result_ty : other_args_tys) = data_con_arg_tys
249 (state_and_prim_datacon, state_and_prim_ty) = getStatePairingConInfo the_prim_result_ty
252 This grimy bit of code is for digging out the IOok constructor from an
253 application of the the IO type. The constructor is needed for
254 wrapping the result of a _ccall_. The alternative is to wire-in IO,
255 which brings a whole heap of junk with it.
257 If the representation of IO changes, this will probably have to be
258 brought in line with the new definition.
260 newtype IO a = IO (State# RealWorld -> IOResult a)
262 the constructor IO has type (State# RealWorld -> IOResult a) -> IO a
265 getIoOkDataCon :: Type -> (Id,Type)
266 getIoOkDataCon io_result_ty =
268 AppTy (TyConTy ioTyCon _) result_ty = io_result_ty
269 [ioDataCon] = tyConDataCons ioTyCon
270 ioDataConTy = idType ioDataCon
271 (_,ioDataConTy') = splitForAllTy ioDataConTy
272 ([arg],_) = splitFunTy ioDataConTy'
273 (_,AppTy (TyConTy ioResultTyCon _) _) = splitFunTy arg
274 [ioOkDataCon,ioFailDataCon] = tyConDataCons ioResultTyCon
276 (ioOkDataCon, result_ty)
280 Another way to do it, more sensitive:
283 ForAll _ (FunTy (FunTy _ (AppTy (TyConTy ioResultTyCon _) _)) _) ->
284 let [ioOkDataCon,ioFailDataCon] = tyConDataCons ioResultTyCon
286 (ioOkDataCon, result_ty)
287 _ -> pprPanic "getIoOkDataCon: " (ppr PprDebug ioDataConTy)