Kill off zipTopTCvSubst in favour of zipOpenTCvSubst
[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 CoreUtils
25 import MkCore
26 import MkId
27 import ForeignCall
28 import DataCon
29 import DsUtils
30
31 import TcType
32 import Type
33 import Id ( Id )
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 = ASSERT( all isTyVar tyvars ) -- this must be true because the type is top-level
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 = tyCoVarsOfTypeWellScoped body_ty
123 ty = mkInvForAllTys 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 = mkCoreUbxTup
231 (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 = mkTupleTy Unboxed [realWorldStatePrimTy]
279 the_alt = (DataAlt (tupleDataCon Unboxed 1), [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 = mkTupleTy Unboxed (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 = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty]
308 the_alt = (DataAlt (tupleDataCon Unboxed 2), [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