Merge remote-tracking branch 'github/pr/83'
[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 GhcPrelude
22
23 import CoreSyn
24
25 import DsMonad
26 import CoreUtils
27 import MkCore
28 import MkId
29 import ForeignCall
30 import DataCon
31 import DsUtils
32
33 import TcType
34 import Type
35 import Id ( Id )
36 import Coercion
37 import PrimOp
38 import TysPrim
39 import TyCon
40 import TysWiredIn
41 import BasicTypes
42 import Literal
43 import PrelNames
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 -- Precondition: none have levity-polymorphic types
90 -> Safety -- Safety of the call
91 -> Type -- Type of the result: IO t
92 -> DsM CoreExpr -- Result, of type ???
93
94 dsCCall lbl args may_gc result_ty
95 = do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args
96 (ccall_result_ty, res_wrapper) <- boxResult result_ty
97 uniq <- newUnique
98 dflags <- getDynFlags
99 let
100 target = StaticTarget NoSourceText lbl Nothing True
101 the_fcall = CCall (CCallSpec target CCallConv may_gc)
102 the_prim_app = mkFCall dflags uniq the_fcall unboxed_args ccall_result_ty
103 return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
104
105 mkFCall :: DynFlags -> Unique -> ForeignCall
106 -> [CoreExpr] -- Args
107 -> Type -- Result type
108 -> CoreExpr
109 -- Construct the ccall. The only tricky bit is that the ccall Id should have
110 -- no free vars, so if any of the arg tys do we must give it a polymorphic type.
111 -- [I forget *why* it should have no free vars!]
112 -- For example:
113 -- mkCCall ... [s::StablePtr (a->b), x::Addr, c::Char]
114 --
115 -- Here we build a ccall thus
116 -- (ccallid::(forall a b. StablePtr (a -> b) -> Addr -> Char -> IO Addr))
117 -- a b s x c
118 mkFCall dflags uniq the_fcall val_args res_ty
119 = ASSERT( all isTyVar tyvars ) -- this must be true because the type is top-level
120 mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args
121 where
122 arg_tys = map exprType val_args
123 body_ty = (mkFunTys arg_tys res_ty)
124 tyvars = tyCoVarsOfTypeWellScoped body_ty
125 ty = mkInvForAllTys tyvars body_ty
126 the_fcall_id = mkFCallId dflags uniq the_fcall ty
127
128 unboxArg :: CoreExpr -- The supplied argument, not levity-polymorphic
129 -> DsM (CoreExpr, -- To pass as the actual argument
130 CoreExpr -> CoreExpr -- Wrapper to unbox the arg
131 )
132 -- Example: if the arg is e::Int, unboxArg will return
133 -- (x#::Int#, \W. case x of I# x# -> W)
134 -- where W is a CoreExpr that probably mentions x#
135
136 -- always returns a non-levity-polymorphic expression
137
138 unboxArg arg
139 -- Primitive types: nothing to unbox
140 | isPrimitiveType arg_ty
141 = return (arg, \body -> body)
142
143 -- Recursive newtypes
144 | Just(co, _rep_ty) <- topNormaliseNewType_maybe arg_ty
145 = unboxArg (mkCastDs arg co)
146
147 -- Booleans
148 | Just tc <- tyConAppTyCon_maybe arg_ty,
149 tc `hasKey` boolTyConKey
150 = do dflags <- getDynFlags
151 prim_arg <- newSysLocalDs intPrimTy
152 return (Var prim_arg,
153 \ body -> Case (mkWildCase arg arg_ty intPrimTy
154 [(DataAlt falseDataCon,[],mkIntLit dflags 0),
155 (DataAlt trueDataCon, [],mkIntLit dflags 1)])
156 -- In increasing tag order!
157 prim_arg
158 (exprType body)
159 [(DEFAULT,[],body)])
160
161 -- Data types with a single constructor, which has a single, primitive-typed arg
162 -- This deals with Int, Float etc; also Ptr, ForeignPtr
163 | is_product_type && data_con_arity == 1
164 = ASSERT2(isUnliftedType data_con_arg_ty1, pprType arg_ty)
165 -- Typechecker ensures this
166 do case_bndr <- newSysLocalDs arg_ty
167 prim_arg <- newSysLocalDs data_con_arg_ty1
168 return (Var prim_arg,
169 \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)]
170 )
171
172 -- Byte-arrays, both mutable and otherwise; hack warning
173 -- We're looking for values of type ByteArray, MutableByteArray
174 -- data ByteArray ix = ByteArray ix ix ByteArray#
175 -- data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)
176 | is_product_type &&
177 data_con_arity == 3 &&
178 isJust maybe_arg3_tycon &&
179 (arg3_tycon == byteArrayPrimTyCon ||
180 arg3_tycon == mutableByteArrayPrimTyCon)
181 = do case_bndr <- newSysLocalDs arg_ty
182 vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys
183 return (Var arr_cts_var,
184 \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)]
185 )
186
187 | otherwise
188 = do l <- getSrcSpanDs
189 pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
190 where
191 arg_ty = exprType arg
192 maybe_product_type = splitDataProductType_maybe arg_ty
193 is_product_type = isJust maybe_product_type
194 Just (_, _, data_con, data_con_arg_tys) = maybe_product_type
195 data_con_arity = dataConSourceArity data_con
196 (data_con_arg_ty1 : _) = data_con_arg_tys
197
198 (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys
199 maybe_arg3_tycon = tyConAppTyCon_maybe data_con_arg_ty3
200 Just arg3_tycon = maybe_arg3_tycon
201
202 boxResult :: Type
203 -> DsM (Type, CoreExpr -> CoreExpr)
204
205 -- Takes the result of the user-level ccall:
206 -- either (IO t),
207 -- or maybe just t for a side-effect-free call
208 -- Returns a wrapper for the primitive ccall itself, along with the
209 -- type of the result of the primitive ccall. This result type
210 -- will be of the form
211 -- State# RealWorld -> (# State# RealWorld, t' #)
212 -- where t' is the unwrapped form of t. If t is simply (), then
213 -- the result type will be
214 -- State# RealWorld -> (# State# RealWorld #)
215
216 boxResult result_ty
217 | Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty
218 -- isIOType_maybe handles the case where the type is a
219 -- simple wrapping of IO. E.g.
220 -- newtype Wrap a = W (IO a)
221 -- No coercion necessary because its a non-recursive newtype
222 -- (If we wanted to handle a *recursive* newtype too, we'd need
223 -- another case, and a coercion.)
224 -- The result is IO t, so wrap the result in an IO constructor
225 = do { res <- resultWrapper io_res_ty
226 ; let extra_result_tys
227 = case res of
228 (Just ty,_)
229 | isUnboxedTupleType ty
230 -> let Just ls = tyConAppArgs_maybe ty in tail ls
231 _ -> []
232
233 return_result state anss
234 = mkCoreUbxTup
235 (realWorldStatePrimTy : io_res_ty : extra_result_tys)
236 (state : anss)
237
238 ; (ccall_res_ty, the_alt) <- mk_alt return_result res
239
240 ; state_id <- newSysLocalDs realWorldStatePrimTy
241 ; let io_data_con = head (tyConDataCons io_tycon)
242 toIOCon = dataConWrapId io_data_con
243
244 wrap the_call =
245 mkApps (Var toIOCon)
246 [ Type io_res_ty,
247 Lam state_id $
248 mkWildCase (App the_call (Var state_id))
249 ccall_res_ty
250 (coreAltType the_alt)
251 [the_alt]
252 ]
253
254 ; return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) }
255
256 boxResult result_ty
257 = do -- It isn't IO, so do unsafePerformIO
258 -- It's not conveniently available, so we inline it
259 res <- resultWrapper result_ty
260 (ccall_res_ty, the_alt) <- mk_alt return_result res
261 let
262 wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId))
263 ccall_res_ty
264 (coreAltType the_alt)
265 [the_alt]
266 return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
267 where
268 return_result _ [ans] = ans
269 return_result _ _ = panic "return_result: expected single result"
270
271
272 mk_alt :: (Expr Var -> [Expr Var] -> Expr Var)
273 -> (Maybe Type, Expr Var -> Expr Var)
274 -> DsM (Type, (AltCon, [Id], Expr Var))
275 mk_alt return_result (Nothing, wrap_result)
276 = do -- The ccall returns ()
277 state_id <- newSysLocalDs realWorldStatePrimTy
278 let
279 the_rhs = return_result (Var state_id)
280 [wrap_result (panic "boxResult")]
281
282 ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy]
283 the_alt = (DataAlt (tupleDataCon Unboxed 1), [state_id], the_rhs)
284
285 return (ccall_res_ty, the_alt)
286
287 mk_alt return_result (Just prim_res_ty, wrap_result)
288 = -- The ccall returns a non-() value
289 ASSERT2( isPrimitiveType prim_res_ty, ppr prim_res_ty )
290 -- True because resultWrapper ensures it is so
291 do { result_id <- newSysLocalDs prim_res_ty
292 ; state_id <- newSysLocalDs realWorldStatePrimTy
293 ; let the_rhs = return_result (Var state_id)
294 [wrap_result (Var result_id)]
295 ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty]
296 the_alt = (DataAlt (tupleDataCon Unboxed 2), [state_id, result_id], the_rhs)
297 ; return (ccall_res_ty, the_alt) }
298
299
300 resultWrapper :: Type
301 -> DsM (Maybe Type, -- Type of the expected result, if any
302 CoreExpr -> CoreExpr) -- Wrapper for the result
303 -- resultWrapper deals with the result *value*
304 -- E.g. foreign import foo :: Int -> IO T
305 -- Then resultWrapper deals with marshalling the 'T' part
306 -- So if resultWrapper ty = (Just ty_rep, marshal)
307 -- then marshal (e :: ty_rep) :: ty
308 -- That is, 'marshal' wrape the result returned by the foreign call,
309 -- of type ty_rep, into the value Haskell expected, of type 'ty'
310 --
311 -- Invariant: ty_rep is always a primitive type
312 -- i.e. (isPrimitiveType ty_rep) is True
313
314 resultWrapper result_ty
315 -- Base case 1: primitive types
316 | isPrimitiveType result_ty
317 = return (Just result_ty, \e -> e)
318
319 -- Base case 2: the unit type ()
320 | Just (tc,_) <- maybe_tc_app
321 , tc `hasKey` unitTyConKey
322 = return (Nothing, \_ -> Var unitDataConId)
323
324 -- Base case 3: the boolean type
325 | Just (tc,_) <- maybe_tc_app
326 , tc `hasKey` boolTyConKey
327 = do { dflags <- getDynFlags
328 ; let marshal_bool e
329 = mkWildCase e intPrimTy boolTy
330 [ (DEFAULT ,[],Var trueDataConId )
331 , (LitAlt (mkMachInt dflags 0),[],Var falseDataConId)]
332 ; return (Just intPrimTy, marshal_bool) }
333
334 -- Newtypes
335 | Just (co, rep_ty) <- topNormaliseNewType_maybe result_ty
336 = do { (maybe_ty, wrapper) <- resultWrapper rep_ty
337 ; return (maybe_ty, \e -> mkCastDs (wrapper e) (mkSymCo co)) }
338
339 -- The type might contain foralls (eg. for dummy type arguments,
340 -- referring to 'Ptr a' is legal).
341 | Just (tyvar, rest) <- splitForAllTy_maybe result_ty
342 = do { (maybe_ty, wrapper) <- resultWrapper rest
343 ; return (maybe_ty, \e -> Lam tyvar (wrapper e)) }
344
345 -- Data types with a single constructor, which has a single arg
346 -- This includes types like Ptr and ForeignPtr
347 | Just (tycon, tycon_arg_tys) <- maybe_tc_app
348 , Just data_con <- isDataProductTyCon_maybe tycon -- One constructor, no existentials
349 , [unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys -- One argument
350 = do { dflags <- getDynFlags
351 ; (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty
352 ; let narrow_wrapper = maybeNarrow dflags tycon
353 marshal_con e = Var (dataConWrapId data_con)
354 `mkTyApps` tycon_arg_tys
355 `App` wrapper (narrow_wrapper e)
356 ; return (maybe_ty, marshal_con) }
357
358 | otherwise
359 = pprPanic "resultWrapper" (ppr result_ty)
360 where
361 maybe_tc_app = splitTyConApp_maybe result_ty
362
363 -- When the result of a foreign call is smaller than the word size, we
364 -- need to sign- or zero-extend the result up to the word size. The C
365 -- standard appears to say that this is the responsibility of the
366 -- caller, not the callee.
367
368 maybeNarrow :: DynFlags -> TyCon -> (CoreExpr -> CoreExpr)
369 maybeNarrow dflags tycon
370 | tycon `hasKey` int8TyConKey = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e
371 | tycon `hasKey` int16TyConKey = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e
372 | tycon `hasKey` int32TyConKey
373 && wORD_SIZE dflags > 4 = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e
374
375 | tycon `hasKey` word8TyConKey = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e
376 | tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e
377 | tycon `hasKey` word32TyConKey
378 && wORD_SIZE dflags > 4 = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e
379 | otherwise = id