Add selectors for common fields (DataCon/PatSyn) to ConLike
[ghc.git] / compiler / deSugar / DsCCall.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The AQUA Project, Glasgow University, 1994-1998
4
5
6 Desugaring foreign calls
7 -}
8
9 {-# LANGUAGE CPP #-}
10 module DsCCall
11 ( dsCCall
12 , mkFCall
13 , unboxArg
14 , boxResult
15 , resultWrapper
16 ) where
17
18 #include "HsVersions.h"
19
20
21 import CoreSyn
22
23 import DsMonad
24 import DsUtils( mkCastDs )
25 import CoreUtils
26 import MkCore
27 import Var
28 import MkId
29 import ForeignCall
30 import DataCon
31
32 import TcType
33 import Type
34 import Coercion
35 import PrimOp
36 import TysPrim
37 import TyCon
38 import TysWiredIn
39 import BasicTypes
40 import FastString ( unpackFS )
41 import Literal
42 import PrelNames
43 import VarSet
44 import DynFlags
45 import Outputable
46 import Util
47
48 import Data.Maybe
49
50 {-
51 Desugaring of @ccall@s consists of adding some state manipulation,
52 unboxing any boxed primitive arguments and boxing the result if
53 desired.
54
55 The state stuff just consists of adding in
56 @PrimIO (\ s -> case s of { S# s# -> ... })@ in an appropriate place.
57
58 The unboxing is straightforward, as all information needed to unbox is
59 available from the type. For each boxed-primitive argument, we
60 transform:
61 \begin{verbatim}
62 _ccall_ foo [ r, t1, ... tm ] e1 ... em
63 |
64 |
65 V
66 case e1 of { T1# x1# ->
67 ...
68 case em of { Tm# xm# -> xm#
69 ccall# foo [ r, t1#, ... tm# ] x1# ... xm#
70 } ... }
71 \end{verbatim}
72
73 The reboxing of a @_ccall_@ result is a bit tricker: the types don't
74 contain information about the state-pairing functions so we have to
75 keep a list of \tr{(type, s-p-function)} pairs. We transform as
76 follows:
77 \begin{verbatim}
78 ccall# foo [ r, t1#, ... tm# ] e1# ... em#
79 |
80 |
81 V
82 \ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of
83 (StateAnd<r># result# state#) -> (R# result#, realWorld#)
84 \end{verbatim}
85 -}
86
87 dsCCall :: CLabelString -- C routine to invoke
88 -> [CoreExpr] -- Arguments (desugared)
89 -> Safety -- Safety of the call
90 -> Type -- Type of the result: IO t
91 -> DsM CoreExpr -- Result, of type ???
92
93 dsCCall lbl args may_gc result_ty
94 = do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args
95 (ccall_result_ty, res_wrapper) <- boxResult result_ty
96 uniq <- newUnique
97 dflags <- getDynFlags
98 let
99 target = StaticTarget (unpackFS lbl) lbl Nothing True
100 the_fcall = CCall (CCallSpec target CCallConv may_gc)
101 the_prim_app = mkFCall dflags uniq the_fcall unboxed_args ccall_result_ty
102 return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
103
104 mkFCall :: DynFlags -> Unique -> ForeignCall
105 -> [CoreExpr] -- Args
106 -> Type -- Result type
107 -> CoreExpr
108 -- Construct the ccall. The only tricky bit is that the ccall Id should have
109 -- no free vars, so if any of the arg tys do we must give it a polymorphic type.
110 -- [I forget *why* it should have no free vars!]
111 -- For example:
112 -- mkCCall ... [s::StablePtr (a->b), x::Addr, c::Char]
113 --
114 -- Here we build a ccall thus
115 -- (ccallid::(forall a b. StablePtr (a -> b) -> Addr -> Char -> IO Addr))
116 -- a b s x c
117 mkFCall dflags uniq the_fcall val_args res_ty
118 = mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args
119 where
120 arg_tys = map exprType val_args
121 body_ty = (mkFunTys arg_tys res_ty)
122 tyvars = varSetElems (tyVarsOfType body_ty)
123 ty = mkForAllTys tyvars body_ty
124 the_fcall_id = mkFCallId dflags uniq the_fcall ty
125
126 unboxArg :: CoreExpr -- The supplied argument
127 -> DsM (CoreExpr, -- To pass as the actual argument
128 CoreExpr -> CoreExpr -- Wrapper to unbox the arg
129 )
130 -- Example: if the arg is e::Int, unboxArg will return
131 -- (x#::Int#, \W. case x of I# x# -> W)
132 -- where W is a CoreExpr that probably mentions x#
133
134 unboxArg arg
135 -- Primtive types: nothing to unbox
136 | isPrimitiveType arg_ty
137 = return (arg, \body -> body)
138
139 -- Recursive newtypes
140 | Just(co, _rep_ty) <- topNormaliseNewType_maybe arg_ty
141 = unboxArg (mkCastDs arg co)
142
143 -- Booleans
144 | Just tc <- tyConAppTyCon_maybe arg_ty,
145 tc `hasKey` boolTyConKey
146 = do dflags <- getDynFlags
147 prim_arg <- newSysLocalDs intPrimTy
148 return (Var prim_arg,
149 \ body -> Case (mkWildCase arg arg_ty intPrimTy
150 [(DataAlt falseDataCon,[],mkIntLit dflags 0),
151 (DataAlt trueDataCon, [],mkIntLit dflags 1)])
152 -- In increasing tag order!
153 prim_arg
154 (exprType body)
155 [(DEFAULT,[],body)])
156
157 -- Data types with a single constructor, which has a single, primitive-typed arg
158 -- This deals with Int, Float etc; also Ptr, ForeignPtr
159 | is_product_type && data_con_arity == 1
160 = ASSERT2(isUnLiftedType data_con_arg_ty1, pprType arg_ty)
161 -- Typechecker ensures this
162 do case_bndr <- newSysLocalDs arg_ty
163 prim_arg <- newSysLocalDs data_con_arg_ty1
164 return (Var prim_arg,
165 \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)]
166 )
167
168 -- Byte-arrays, both mutable and otherwise; hack warning
169 -- We're looking for values of type ByteArray, MutableByteArray
170 -- data ByteArray ix = ByteArray ix ix ByteArray#
171 -- data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)
172 | is_product_type &&
173 data_con_arity == 3 &&
174 isJust maybe_arg3_tycon &&
175 (arg3_tycon == byteArrayPrimTyCon ||
176 arg3_tycon == mutableByteArrayPrimTyCon)
177 = do case_bndr <- newSysLocalDs arg_ty
178 vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys
179 return (Var arr_cts_var,
180 \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)]
181 )
182
183 | otherwise
184 = do l <- getSrcSpanDs
185 pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
186 where
187 arg_ty = exprType arg
188 maybe_product_type = splitDataProductType_maybe arg_ty
189 is_product_type = isJust maybe_product_type
190 Just (_, _, data_con, data_con_arg_tys) = maybe_product_type
191 data_con_arity = dataConSourceArity data_con
192 (data_con_arg_ty1 : _) = data_con_arg_tys
193
194 (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys
195 maybe_arg3_tycon = tyConAppTyCon_maybe data_con_arg_ty3
196 Just arg3_tycon = maybe_arg3_tycon
197
198 boxResult :: Type
199 -> DsM (Type, CoreExpr -> CoreExpr)
200
201 -- Takes the result of the user-level ccall:
202 -- either (IO t),
203 -- or maybe just t for an side-effect-free call
204 -- Returns a wrapper for the primitive ccall itself, along with the
205 -- type of the result of the primitive ccall. This result type
206 -- will be of the form
207 -- State# RealWorld -> (# State# RealWorld, t' #)
208 -- where t' is the unwrapped form of t. If t is simply (), then
209 -- the result type will be
210 -- State# RealWorld -> (# State# RealWorld #)
211
212 boxResult result_ty
213 | Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty
214 -- isIOType_maybe handles the case where the type is a
215 -- simple wrapping of IO. E.g.
216 -- newtype Wrap a = W (IO a)
217 -- No coercion necessary because its a non-recursive newtype
218 -- (If we wanted to handle a *recursive* newtype too, we'd need
219 -- another case, and a coercion.)
220 -- The result is IO t, so wrap the result in an IO constructor
221 = do { res <- resultWrapper io_res_ty
222 ; let extra_result_tys
223 = case res of
224 (Just ty,_)
225 | isUnboxedTupleType ty
226 -> let Just ls = tyConAppArgs_maybe ty in tail ls
227 _ -> []
228
229 return_result state anss
230 = mkCoreConApps (tupleDataCon Unboxed (2 + length extra_result_tys))
231 (map Type (realWorldStatePrimTy : io_res_ty : extra_result_tys)
232 ++ (state : anss))
233
234 ; (ccall_res_ty, the_alt) <- mk_alt return_result res
235
236 ; state_id <- newSysLocalDs realWorldStatePrimTy
237 ; let io_data_con = head (tyConDataCons io_tycon)
238 toIOCon = dataConWrapId io_data_con
239
240 wrap the_call =
241 mkApps (Var toIOCon)
242 [ Type io_res_ty,
243 Lam state_id $
244 mkWildCase (App the_call (Var state_id))
245 ccall_res_ty
246 (coreAltType the_alt)
247 [the_alt]
248 ]
249
250 ; return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) }
251
252 boxResult result_ty
253 = do -- It isn't IO, so do unsafePerformIO
254 -- It's not conveniently available, so we inline it
255 res <- resultWrapper result_ty
256 (ccall_res_ty, the_alt) <- mk_alt return_result res
257 let
258 wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId))
259 ccall_res_ty
260 (coreAltType the_alt)
261 [the_alt]
262 return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
263 where
264 return_result _ [ans] = ans
265 return_result _ _ = panic "return_result: expected single result"
266
267
268 mk_alt :: (Expr Var -> [Expr Var] -> Expr Var)
269 -> (Maybe Type, Expr Var -> Expr Var)
270 -> DsM (Type, (AltCon, [Id], Expr Var))
271 mk_alt return_result (Nothing, wrap_result)
272 = do -- The ccall returns ()
273 state_id <- newSysLocalDs realWorldStatePrimTy
274 let
275 the_rhs = return_result (Var state_id)
276 [wrap_result (panic "boxResult")]
277
278 ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy]
279 the_alt = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs)
280
281 return (ccall_res_ty, the_alt)
282
283 mk_alt return_result (Just prim_res_ty, wrap_result)
284 -- The ccall returns a non-() value
285 | isUnboxedTupleType prim_res_ty= do
286 let
287 Just ls = tyConAppArgs_maybe prim_res_ty
288 arity = 1 + length ls
289 args_ids@(result_id:as) <- mapM newSysLocalDs ls
290 state_id <- newSysLocalDs realWorldStatePrimTy
291 let
292 the_rhs = return_result (Var state_id)
293 (wrap_result (Var result_id) : map Var as)
294 ccall_res_ty = mkTyConApp (tupleTyCon Unboxed arity)
295 (realWorldStatePrimTy : ls)
296 the_alt = ( DataAlt (tupleDataCon Unboxed arity)
297 , (state_id : args_ids)
298 , the_rhs
299 )
300 return (ccall_res_ty, the_alt)
301
302 | otherwise = do
303 result_id <- newSysLocalDs prim_res_ty
304 state_id <- newSysLocalDs realWorldStatePrimTy
305 let
306 the_rhs = return_result (Var state_id)
307 [wrap_result (Var result_id)]
308 ccall_res_ty = mkTyConApp unboxedPairTyCon [realWorldStatePrimTy, prim_res_ty]
309 the_alt = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs)
310 return (ccall_res_ty, the_alt)
311
312
313 resultWrapper :: Type
314 -> DsM (Maybe Type, -- Type of the expected result, if any
315 CoreExpr -> CoreExpr) -- Wrapper for the result
316 -- resultWrapper deals with the result *value*
317 -- E.g. foreign import foo :: Int -> IO T
318 -- Then resultWrapper deals with marshalling the 'T' part
319 resultWrapper result_ty
320 -- Base case 1: primitive types
321 | isPrimitiveType result_ty
322 = return (Just result_ty, \e -> e)
323
324 -- Base case 2: the unit type ()
325 | Just (tc,_) <- maybe_tc_app, tc `hasKey` unitTyConKey
326 = return (Nothing, \_ -> Var unitDataConId)
327
328 -- Base case 3: the boolean type
329 | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey
330 = do
331 dflags <- getDynFlags
332 return
333 (Just intPrimTy, \e -> mkWildCase e intPrimTy
334 boolTy
335 [(DEFAULT ,[],Var trueDataConId ),
336 (LitAlt (mkMachInt dflags 0),[],Var falseDataConId)])
337
338 -- Newtypes
339 | Just (co, rep_ty) <- topNormaliseNewType_maybe result_ty
340 = do (maybe_ty, wrapper) <- resultWrapper rep_ty
341 return (maybe_ty, \e -> mkCastDs (wrapper e) (mkSymCo co))
342
343 -- The type might contain foralls (eg. for dummy type arguments,
344 -- referring to 'Ptr a' is legal).
345 | Just (tyvar, rest) <- splitForAllTy_maybe result_ty
346 = do (maybe_ty, wrapper) <- resultWrapper rest
347 return (maybe_ty, \e -> Lam tyvar (wrapper e))
348
349 -- Data types with a single constructor, which has a single arg
350 -- This includes types like Ptr and ForeignPtr
351 | Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitDataProductType_maybe result_ty,
352 dataConSourceArity data_con == 1
353 = do dflags <- getDynFlags
354 let
355 (unwrapped_res_ty : _) = data_con_arg_tys
356 narrow_wrapper = maybeNarrow dflags tycon
357 (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty
358 return
359 (maybe_ty, \e -> mkApps (Var (dataConWrapId data_con))
360 (map Type tycon_arg_tys ++ [wrapper (narrow_wrapper e)]))
361
362 | otherwise
363 = pprPanic "resultWrapper" (ppr result_ty)
364 where
365 maybe_tc_app = splitTyConApp_maybe result_ty
366
367 -- When the result of a foreign call is smaller than the word size, we
368 -- need to sign- or zero-extend the result up to the word size. The C
369 -- standard appears to say that this is the responsibility of the
370 -- caller, not the callee.
371
372 maybeNarrow :: DynFlags -> TyCon -> (CoreExpr -> CoreExpr)
373 maybeNarrow dflags tycon
374 | tycon `hasKey` int8TyConKey = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e
375 | tycon `hasKey` int16TyConKey = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e
376 | tycon `hasKey` int32TyConKey
377 && wORD_SIZE dflags > 4 = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e
378
379 | tycon `hasKey` word8TyConKey = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e
380 | tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e
381 | tycon `hasKey` word32TyConKey
382 && wORD_SIZE dflags > 4 = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e
383 | otherwise = id