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