26c84c764d1c54154eac35dafbe1d274e6b059a8
[ghc.git] / compiler / deSugar / DsForeign.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The AQUA Project, Glasgow University, 1998
4
5
6 Desugaring foreign declarations (see also DsCCall).
7 -}
8
9 {-# LANGUAGE CPP #-}
10
11 module DsForeign ( dsForeigns ) where
12
13 #include "HsVersions.h"
14 import TcRnMonad -- temp
15
16 import CoreSyn
17
18 import DsCCall
19 import DsMonad
20
21 import HsSyn
22 import DataCon
23 import CoreUnfold
24 import Id
25 import Literal
26 import Module
27 import Name
28 import Type
29 import TyCon
30 import Coercion
31 import TcEnv
32 import TcType
33
34 import CmmExpr
35 import CmmUtils
36 import HscTypes
37 import ForeignCall
38 import TysWiredIn
39 import TysPrim
40 import PrelNames
41 import BasicTypes
42 import SrcLoc
43 import Outputable
44 import FastString
45 import DynFlags
46 import Platform
47 import Config
48 import OrdList
49 import Pair
50 import Util
51 import Hooks
52
53 import Data.Maybe
54 import Data.List
55
56 {-
57 Desugaring of @foreign@ declarations is naturally split up into
58 parts, an @import@ and an @export@ part. A @foreign import@
59 declaration
60 \begin{verbatim}
61 foreign import cc nm f :: prim_args -> IO prim_res
62 \end{verbatim}
63 is the same as
64 \begin{verbatim}
65 f :: prim_args -> IO prim_res
66 f a1 ... an = _ccall_ nm cc a1 ... an
67 \end{verbatim}
68 so we reuse the desugaring code in @DsCCall@ to deal with these.
69 -}
70
71 type Binding = (Id, CoreExpr) -- No rec/nonrec structure;
72 -- the occurrence analyser will sort it all out
73
74 dsForeigns :: [LForeignDecl Id]
75 -> DsM (ForeignStubs, OrdList Binding)
76 dsForeigns fos = getHooked dsForeignsHook dsForeigns' >>= ($ fos)
77
78 dsForeigns' :: [LForeignDecl Id]
79 -> DsM (ForeignStubs, OrdList Binding)
80 dsForeigns' []
81 = return (NoStubs, nilOL)
82 dsForeigns' fos = do
83 fives <- mapM do_ldecl fos
84 let
85 (hs, cs, idss, bindss) = unzip4 fives
86 fe_ids = concat idss
87 fe_init_code = map foreignExportInitialiser fe_ids
88 --
89 return (ForeignStubs
90 (vcat hs)
91 (vcat cs $$ vcat fe_init_code),
92 foldr (appOL . toOL) nilOL bindss)
93 where
94 do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl)
95
96 do_decl (ForeignImport { fd_name = id, fd_co = co, fd_fi = spec }) = do
97 traceIf (text "fi start" <+> ppr id)
98 let id' = unLoc id
99 (bs, h, c) <- dsFImport id' co spec
100 traceIf (text "fi end" <+> ppr id)
101 return (h, c, [], bs)
102
103 do_decl (ForeignExport { fd_name = L _ id, fd_co = co
104 , fd_fe = CExport (L _ (CExportStatic _ ext_nm cconv)) _ }) = do
105 (h, c, _, _) <- dsFExport id co ext_nm cconv False
106 return (h, c, [id], [])
107
108 {-
109 ************************************************************************
110 * *
111 \subsection{Foreign import}
112 * *
113 ************************************************************************
114
115 Desugaring foreign imports is just the matter of creating a binding
116 that on its RHS unboxes its arguments, performs the external call
117 (using the @CCallOp@ primop), before boxing the result up and returning it.
118
119 However, we create a worker/wrapper pair, thus:
120
121 foreign import f :: Int -> IO Int
122 ==>
123 f x = IO ( \s -> case x of { I# x# ->
124 case fw s x# of { (# s1, y# #) ->
125 (# s1, I# y# #)}})
126
127 fw s x# = ccall f s x#
128
129 The strictness/CPR analyser won't do this automatically because it doesn't look
130 inside returned tuples; but inlining this wrapper is a Really Good Idea
131 because it exposes the boxing to the call site.
132 -}
133
134 dsFImport :: Id
135 -> Coercion
136 -> ForeignImport
137 -> DsM ([Binding], SDoc, SDoc)
138 dsFImport id co (CImport cconv safety mHeader spec _) =
139 dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader
140
141 dsCImport :: Id
142 -> Coercion
143 -> CImportSpec
144 -> CCallConv
145 -> Safety
146 -> Maybe Header
147 -> DsM ([Binding], SDoc, SDoc)
148 dsCImport id co (CLabel cid) cconv _ _ = do
149 dflags <- getDynFlags
150 let ty = pFst $ coercionKind co
151 fod = case tyConAppTyCon_maybe (dropForAlls ty) of
152 Just tycon
153 | tyConUnique tycon == funPtrTyConKey ->
154 IsFunction
155 _ -> IsData
156 (resTy, foRhs) <- resultWrapper ty
157 ASSERT(fromJust resTy `eqType` addrPrimTy) -- typechecker ensures this
158 let
159 rhs = foRhs (Lit (MachLabel cid stdcall_info fod))
160 rhs' = Cast rhs co
161 stdcall_info = fun_type_arg_stdcall_info dflags cconv ty
162 in
163 return ([(id, rhs')], empty, empty)
164
165 dsCImport id co (CFunction target) cconv@PrimCallConv safety _
166 = dsPrimCall id co (CCall (CCallSpec target cconv safety))
167 dsCImport id co (CFunction target) cconv safety mHeader
168 = dsFCall id co (CCall (CCallSpec target cconv safety)) mHeader
169 dsCImport id co CWrapper cconv _ _
170 = dsFExportDynamic id co cconv
171
172 -- For stdcall labels, if the type was a FunPtr or newtype thereof,
173 -- then we need to calculate the size of the arguments in order to add
174 -- the @n suffix to the label.
175 fun_type_arg_stdcall_info :: DynFlags -> CCallConv -> Type -> Maybe Int
176 fun_type_arg_stdcall_info dflags StdCallConv ty
177 | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty,
178 tyConUnique tc == funPtrTyConKey
179 = let
180 (bndrs, _) = tcSplitPiTys arg_ty
181 fe_arg_tys = mapMaybe binderRelevantType_maybe bndrs
182 in Just $ sum (map (widthInBytes . typeWidth . typeCmmType dflags . getPrimTyOf) fe_arg_tys)
183 fun_type_arg_stdcall_info _ _other_conv _
184 = Nothing
185
186 {-
187 ************************************************************************
188 * *
189 \subsection{Foreign calls}
190 * *
191 ************************************************************************
192 -}
193
194 dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header
195 -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
196 dsFCall fn_id co fcall mDeclHeader = do
197 let
198 ty = pFst $ coercionKind co
199 (all_bndrs, io_res_ty) = tcSplitPiTys ty
200 (named_bndrs, arg_tys) = partitionBindersIntoBinders all_bndrs
201 tvs = ASSERT( fst (span isNamedBinder all_bndrs)
202 `equalLength` named_bndrs )
203 -- ensure that the named binders all come first
204 map (binderVar "dsFCall") named_bndrs
205 -- Must use tcSplit* functions because we want to
206 -- see that (IO t) in the corner
207
208 args <- newSysLocalsDs arg_tys
209 (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args)
210
211 let
212 work_arg_ids = [v | Var v <- val_args] -- All guaranteed to be vars
213
214 (ccall_result_ty, res_wrapper) <- boxResult io_res_ty
215
216 ccall_uniq <- newUnique
217 work_uniq <- newUnique
218
219 dflags <- getDynFlags
220 (fcall', cDoc) <-
221 case fcall of
222 CCall (CCallSpec (StaticTarget _ cName mUnitId isFun)
223 CApiConv safety) ->
224 do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName)
225 let fcall' = CCall (CCallSpec
226 (StaticTarget (unpackFS wrapperName)
227 wrapperName mUnitId
228 True)
229 CApiConv safety)
230 c = includes
231 $$ fun_proto <+> braces (cRet <> semi)
232 includes = vcat [ text "#include <" <> ftext h <> text ">"
233 | Header _ h <- nub headers ]
234 fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes
235 cRet
236 | isVoidRes = cCall
237 | otherwise = text "return" <+> cCall
238 cCall = if isFun
239 then ppr cName <> parens argVals
240 else if null arg_tys
241 then ppr cName
242 else panic "dsFCall: Unexpected arguments to FFI value import"
243 raw_res_ty = case tcSplitIOType_maybe io_res_ty of
244 Just (_ioTyCon, res_ty) -> res_ty
245 Nothing -> io_res_ty
246 isVoidRes = raw_res_ty `eqType` unitTy
247 (mHeader, cResType)
248 | isVoidRes = (Nothing, text "void")
249 | otherwise = toCType raw_res_ty
250 pprCconv = ccallConvAttribute CApiConv
251 mHeadersArgTypeList
252 = [ (header, cType <+> char 'a' <> int n)
253 | (t, n) <- zip arg_tys [1..]
254 , let (header, cType) = toCType t ]
255 (mHeaders, argTypeList) = unzip mHeadersArgTypeList
256 argTypes = if null argTypeList
257 then text "void"
258 else hsep $ punctuate comma argTypeList
259 mHeaders' = mDeclHeader : mHeader : mHeaders
260 headers = catMaybes mHeaders'
261 argVals = hsep $ punctuate comma
262 [ char 'a' <> int n
263 | (_, n) <- zip arg_tys [1..] ]
264 return (fcall', c)
265 _ ->
266 return (fcall, empty)
267 let
268 -- Build the worker
269 worker_ty = mkForAllTys named_bndrs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
270 the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty
271 work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app)
272 work_id = mkSysLocal (fsLit "$wccall") work_uniq worker_ty
273
274 -- Build the wrapper
275 work_app = mkApps (mkVarApps (Var work_id) tvs) val_args
276 wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
277 wrap_rhs = mkLams (tvs ++ args) wrapper_body
278 wrap_rhs' = Cast wrap_rhs co
279 fn_id_w_inl = fn_id `setIdUnfolding` mkInlineUnfolding (Just (length args)) wrap_rhs'
280
281 return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, cDoc)
282
283 {-
284 ************************************************************************
285 * *
286 \subsection{Primitive calls}
287 * *
288 ************************************************************************
289
290 This is for `@foreign import prim@' declarations.
291
292 Currently, at the core level we pretend that these primitive calls are
293 foreign calls. It may make more sense in future to have them as a distinct
294 kind of Id, or perhaps to bundle them with PrimOps since semantically and
295 for calling convention they are really prim ops.
296 -}
297
298 dsPrimCall :: Id -> Coercion -> ForeignCall
299 -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
300 dsPrimCall fn_id co fcall = do
301 let
302 ty = pFst $ coercionKind co
303 (bndrs, io_res_ty) = tcSplitPiTys ty
304 (tvs, arg_tys) = partitionBinders bndrs
305 -- Must use tcSplit* functions because we want to
306 -- see that (IO t) in the corner
307
308 MASSERT( fst (span isNamedBinder bndrs) `equalLength` tvs )
309 args <- newSysLocalsDs arg_tys
310
311 ccall_uniq <- newUnique
312 dflags <- getDynFlags
313 let
314 call_app = mkFCall dflags ccall_uniq fcall (map Var args) io_res_ty
315 rhs = mkLams tvs (mkLams args call_app)
316 rhs' = Cast rhs co
317 return ([(fn_id, rhs')], empty, empty)
318
319 {-
320 ************************************************************************
321 * *
322 \subsection{Foreign export}
323 * *
324 ************************************************************************
325
326 The function that does most of the work for `@foreign export@' declarations.
327 (see below for the boilerplate code a `@foreign export@' declaration expands
328 into.)
329
330 For each `@foreign export foo@' in a module M we generate:
331 \begin{itemize}
332 \item a C function `@foo@', which calls
333 \item a Haskell stub `@M.\$ffoo@', which calls
334 \end{itemize}
335 the user-written Haskell function `@M.foo@'.
336 -}
337
338 dsFExport :: Id -- Either the exported Id,
339 -- or the foreign-export-dynamic constructor
340 -> Coercion -- Coercion between the Haskell type callable
341 -- from C, and its representation type
342 -> CLabelString -- The name to export to C land
343 -> CCallConv
344 -> Bool -- True => foreign export dynamic
345 -- so invoke IO action that's hanging off
346 -- the first argument's stable pointer
347 -> DsM ( SDoc -- contents of Module_stub.h
348 , SDoc -- contents of Module_stub.c
349 , String -- string describing type to pass to createAdj.
350 , Int -- size of args to stub function
351 )
352
353 dsFExport fn_id co ext_name cconv isDyn = do
354 let
355 ty = pSnd $ coercionKind co
356 (bndrs, orig_res_ty) = tcSplitPiTys ty
357 fe_arg_tys' = mapMaybe binderRelevantType_maybe bndrs
358 -- We must use tcSplits here, because we want to see
359 -- the (IO t) in the corner of the type!
360 fe_arg_tys | isDyn = tail fe_arg_tys'
361 | otherwise = fe_arg_tys'
362
363 -- Look at the result type of the exported function, orig_res_ty
364 -- If it's IO t, return (t, True)
365 -- If it's plain t, return (t, False)
366 (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of
367 -- The function already returns IO t
368 Just (_ioTyCon, res_ty) -> (res_ty, True)
369 -- The function returns t
370 Nothing -> (orig_res_ty, False)
371
372 dflags <- getDynFlags
373 return $
374 mkFExportCBits dflags ext_name
375 (if isDyn then Nothing else Just fn_id)
376 fe_arg_tys res_ty is_IO_res_ty cconv
377
378 {-
379 @foreign import "wrapper"@ (previously "foreign export dynamic") lets
380 you dress up Haskell IO actions of some fixed type behind an
381 externally callable interface (i.e., as a C function pointer). Useful
382 for callbacks and stuff.
383
384 \begin{verbatim}
385 type Fun = Bool -> Int -> IO Int
386 foreign import "wrapper" f :: Fun -> IO (FunPtr Fun)
387
388 -- Haskell-visible constructor, which is generated from the above:
389 -- SUP: No check for NULL from createAdjustor anymore???
390
391 f :: Fun -> IO (FunPtr Fun)
392 f cback =
393 bindIO (newStablePtr cback)
394 (\StablePtr sp# -> IO (\s1# ->
395 case _ccall_ createAdjustor cconv sp# ``f_helper'' <arg info> s1# of
396 (# s2#, a# #) -> (# s2#, A# a# #)))
397
398 foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun)
399
400 -- and the helper in C: (approximately; see `mkFExportCBits` below)
401
402 f_helper(StablePtr s, HsBool b, HsInt i)
403 {
404 Capability *cap;
405 cap = rts_lock();
406 rts_evalIO(&cap,
407 rts_apply(rts_apply(deRefStablePtr(s),
408 rts_mkBool(b)), rts_mkInt(i)));
409 rts_unlock(cap);
410 }
411 \end{verbatim}
412 -}
413
414 dsFExportDynamic :: Id
415 -> Coercion
416 -> CCallConv
417 -> DsM ([Binding], SDoc, SDoc)
418 dsFExportDynamic id co0 cconv = do
419 MASSERT( fst (span isNamedBinder bndrs) `equalLength` tvs )
420 -- make sure that the named binders all come first
421 fe_id <- newSysLocalDs ty
422 mod <- getModule
423 dflags <- getDynFlags
424 let
425 -- hack: need to get at the name of the C stub we're about to generate.
426 -- TODO: There's no real need to go via String with
427 -- (mkFastString . zString). In fact, is there a reason to convert
428 -- to FastString at all now, rather than sticking with FastZString?
429 fe_nm = mkFastString (zString (zEncodeFS (moduleNameFS (moduleName mod))) ++ "_" ++ toCName dflags fe_id)
430
431 cback <- newSysLocalDs arg_ty
432 newStablePtrId <- dsLookupGlobalId newStablePtrName
433 stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName
434 let
435 stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]
436 export_ty = mkFunTy stable_ptr_ty arg_ty
437 bindIOId <- dsLookupGlobalId bindIOName
438 stbl_value <- newSysLocalDs stable_ptr_ty
439 (h_code, c_code, typestring, args_size) <- dsFExport id (mkRepReflCo export_ty) fe_nm cconv True
440 let
441 {-
442 The arguments to the external function which will
443 create a little bit of (template) code on the fly
444 for allowing the (stable pointed) Haskell closure
445 to be entered using an external calling convention
446 (stdcall, ccall).
447 -}
448 adj_args = [ mkIntLitInt dflags (ccallConvToInt cconv)
449 , Var stbl_value
450 , Lit (MachLabel fe_nm mb_sz_args IsFunction)
451 , Lit (mkMachString typestring)
452 ]
453 -- name of external entry point providing these services.
454 -- (probably in the RTS.)
455 adjustor = fsLit "createAdjustor"
456
457 -- Determine the number of bytes of arguments to the stub function,
458 -- so that we can attach the '@N' suffix to its label if it is a
459 -- stdcall on Windows.
460 mb_sz_args = case cconv of
461 StdCallConv -> Just args_size
462 _ -> Nothing
463
464 ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])
465 -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
466
467 let io_app = mkLams tvs $
468 Lam cback $
469 mkApps (Var bindIOId)
470 [ Type stable_ptr_ty
471 , Type res_ty
472 , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
473 , Lam stbl_value ccall_adj
474 ]
475
476 fed = (id `setInlineActivation` NeverActive, Cast io_app co0)
477 -- Never inline the f.e.d. function, because the litlit
478 -- might not be in scope in other modules.
479
480 return ([fed], h_code, c_code)
481
482 where
483 ty = pFst (coercionKind co0)
484 (bndrs, fn_res_ty) = tcSplitPiTys ty
485 (tvs, [arg_ty]) = partitionBinders bndrs
486 Just (io_tc, res_ty) = tcSplitIOType_maybe fn_res_ty
487 -- Must have an IO type; hence Just
488
489
490 toCName :: DynFlags -> Id -> String
491 toCName dflags i = showSDoc dflags (pprCode CStyle (ppr (idName i)))
492
493 {-
494 *
495
496 \subsection{Generating @foreign export@ stubs}
497
498 *
499
500 For each @foreign export@ function, a C stub function is generated.
501 The C stub constructs the application of the exported Haskell function
502 using the hugs/ghc rts invocation API.
503 -}
504
505 mkFExportCBits :: DynFlags
506 -> FastString
507 -> Maybe Id -- Just==static, Nothing==dynamic
508 -> [Type]
509 -> Type
510 -> Bool -- True <=> returns an IO type
511 -> CCallConv
512 -> (SDoc,
513 SDoc,
514 String, -- the argument reps
515 Int -- total size of arguments
516 )
517 mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
518 = (header_bits, c_bits, type_string,
519 sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args
520 -- NB. the calculation here isn't strictly speaking correct.
521 -- We have a primitive Haskell type (eg. Int#, Double#), and
522 -- we want to know the size, when passed on the C stack, of
523 -- the associated C type (eg. HsInt, HsDouble). We don't have
524 -- this information to hand, but we know what GHC's conventions
525 -- are for passing around the primitive Haskell types, so we
526 -- use that instead. I hope the two coincide --SDM
527 )
528 where
529 -- list the arguments to the C function
530 arg_info :: [(SDoc, -- arg name
531 SDoc, -- C type
532 Type, -- Haskell type
533 CmmType)] -- the CmmType
534 arg_info = [ let stg_type = showStgType ty in
535 (arg_cname n stg_type,
536 stg_type,
537 ty,
538 typeCmmType dflags (getPrimTyOf ty))
539 | (ty,n) <- zip arg_htys [1::Int ..] ]
540
541 arg_cname n stg_ty
542 | libffi = char '*' <> parens (stg_ty <> char '*') <>
543 text "args" <> brackets (int (n-1))
544 | otherwise = text ('a':show n)
545
546 -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled
547 libffi = cLibFFI && isNothing maybe_target
548
549 type_string
550 -- libffi needs to know the result type too:
551 | libffi = primTyDescChar dflags res_hty : arg_type_string
552 | otherwise = arg_type_string
553
554 arg_type_string = [primTyDescChar dflags ty | (_,_,ty,_) <- arg_info]
555 -- just the real args
556
557 -- add some auxiliary args; the stable ptr in the wrapper case, and
558 -- a slot for the dummy return address in the wrapper + ccall case
559 aug_arg_info
560 | isNothing maybe_target = stable_ptr_arg : insertRetAddr dflags cc arg_info
561 | otherwise = arg_info
562
563 stable_ptr_arg =
564 (text "the_stableptr", text "StgStablePtr", undefined,
565 typeCmmType dflags (mkStablePtrPrimTy alphaTy))
566
567 -- stuff to do with the return type of the C function
568 res_hty_is_unit = res_hty `eqType` unitTy -- Look through any newtypes
569
570 cResType | res_hty_is_unit = text "void"
571 | otherwise = showStgType res_hty
572
573 -- when the return type is integral and word-sized or smaller, it
574 -- must be assigned as type ffi_arg (#3516). To see what type
575 -- libffi is expecting here, take a look in its own testsuite, e.g.
576 -- libffi/testsuite/libffi.call/cls_align_ulonglong.c
577 ffi_cResType
578 | is_ffi_arg_type = text "ffi_arg"
579 | otherwise = cResType
580 where
581 res_ty_key = getUnique (getName (typeTyCon res_hty))
582 is_ffi_arg_type = res_ty_key `notElem`
583 [floatTyConKey, doubleTyConKey,
584 int64TyConKey, word64TyConKey]
585
586 -- Now we can cook up the prototype for the exported function.
587 pprCconv = ccallConvAttribute cc
588
589 header_bits = text "extern" <+> fun_proto <> semi
590
591 fun_args
592 | null aug_arg_info = text "void"
593 | otherwise = hsep $ punctuate comma
594 $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info
595
596 fun_proto
597 | libffi
598 = text "void" <+> ftext c_nm <>
599 parens (text "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr")
600 | otherwise
601 = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args
602
603 -- the target which will form the root of what we ask rts_evalIO to run
604 the_cfun
605 = case maybe_target of
606 Nothing -> text "(StgClosure*)deRefStablePtr(the_stableptr)"
607 Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"
608
609 cap = text "cap" <> comma
610
611 -- the expression we give to rts_evalIO
612 expr_to_run
613 = foldl appArg the_cfun arg_info -- NOT aug_arg_info
614 where
615 appArg acc (arg_cname, _, arg_hty, _)
616 = text "rts_apply"
617 <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname))
618
619 -- various other bits for inside the fn
620 declareResult = text "HaskellObj ret;"
621 declareCResult | res_hty_is_unit = empty
622 | otherwise = cResType <+> text "cret;"
623
624 assignCResult | res_hty_is_unit = empty
625 | otherwise =
626 text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi
627
628 -- an extern decl for the fn being called
629 extern_decl
630 = case maybe_target of
631 Nothing -> empty
632 Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi
633
634
635 -- finally, the whole darn thing
636 c_bits =
637 space $$
638 extern_decl $$
639 fun_proto $$
640 vcat
641 [ lbrace
642 , text "Capability *cap;"
643 , declareResult
644 , declareCResult
645 , text "cap = rts_lock();"
646 -- create the application + perform it.
647 , text "rts_evalIO" <> parens (
648 char '&' <> cap <>
649 text "rts_apply" <> parens (
650 cap <>
651 text "(HaskellObj)"
652 <> ptext (if is_IO_res_ty
653 then (sLit "runIO_closure")
654 else (sLit "runNonIO_closure"))
655 <> comma
656 <> expr_to_run
657 ) <+> comma
658 <> text "&ret"
659 ) <> semi
660 , text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm)
661 <> comma <> text "cap") <> semi
662 , assignCResult
663 , text "rts_unlock(cap);"
664 , ppUnless res_hty_is_unit $
665 if libffi
666 then char '*' <> parens (ffi_cResType <> char '*') <>
667 text "resp = cret;"
668 else text "return cret;"
669 , rbrace
670 ]
671
672
673 foreignExportInitialiser :: Id -> SDoc
674 foreignExportInitialiser hs_fn =
675 -- Initialise foreign exports by registering a stable pointer from an
676 -- __attribute__((constructor)) function.
677 -- The alternative is to do this from stginit functions generated in
678 -- codeGen/CodeGen.hs; however, stginit functions have a negative impact
679 -- on binary sizes and link times because the static linker will think that
680 -- all modules that are imported directly or indirectly are actually used by
681 -- the program.
682 -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)
683 vcat
684 [ text "static void stginit_export_" <> ppr hs_fn
685 <> text "() __attribute__((constructor));"
686 , text "static void stginit_export_" <> ppr hs_fn <> text "()"
687 , braces (text "foreignExportStablePtr"
688 <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure")
689 <> semi)
690 ]
691
692
693 mkHObj :: Type -> SDoc
694 mkHObj t = text "rts_mk" <> text (showFFIType t)
695
696 unpackHObj :: Type -> SDoc
697 unpackHObj t = text "rts_get" <> text (showFFIType t)
698
699 showStgType :: Type -> SDoc
700 showStgType t = text "Hs" <> text (showFFIType t)
701
702 showFFIType :: Type -> String
703 showFFIType t = getOccString (getName (typeTyCon t))
704
705 toCType :: Type -> (Maybe Header, SDoc)
706 toCType = f False
707 where f voidOK t
708 -- First, if we have (Ptr t) of (FunPtr t), then we need to
709 -- convert t to a C type and put a * after it. If we don't
710 -- know a type for t, then "void" is fine, though.
711 | Just (ptr, [t']) <- splitTyConApp_maybe t
712 , tyConName ptr `elem` [ptrTyConName, funPtrTyConName]
713 = case f True t' of
714 (mh, cType') ->
715 (mh, cType' <> char '*')
716 -- Otherwise, if we have a type constructor application, then
717 -- see if there is a C type associated with that constructor.
718 -- Note that we aren't looking through type synonyms or
719 -- anything, as it may be the synonym that is annotated.
720 | Just tycon <- tyConAppTyConPicky_maybe t
721 , Just (CType _ mHeader (_,cType)) <- tyConCType_maybe tycon
722 = (mHeader, ftext cType)
723 -- If we don't know a C type for this type, then try looking
724 -- through one layer of type synonym etc.
725 | Just t' <- coreView t
726 = f voidOK t'
727 -- Otherwise we don't know the C type. If we are allowing
728 -- void then return that; otherwise something has gone wrong.
729 | voidOK = (Nothing, text "void")
730 | otherwise
731 = pprPanic "toCType" (ppr t)
732
733 typeTyCon :: Type -> TyCon
734 typeTyCon ty
735 | UnaryRep rep_ty <- repType ty
736 , Just (tc, _) <- tcSplitTyConApp_maybe rep_ty
737 = tc
738 | otherwise
739 = pprPanic "DsForeign.typeTyCon" (ppr ty)
740
741 insertRetAddr :: DynFlags -> CCallConv
742 -> [(SDoc, SDoc, Type, CmmType)]
743 -> [(SDoc, SDoc, Type, CmmType)]
744 insertRetAddr dflags CCallConv args
745 = case platformArch platform of
746 ArchX86_64
747 | platformOS platform == OSMinGW32 ->
748 -- On other Windows x86_64 we insert the return address
749 -- after the 4th argument, because this is the point
750 -- at which we need to flush a register argument to the stack
751 -- (See rts/Adjustor.c for details).
752 let go :: Int -> [(SDoc, SDoc, Type, CmmType)]
753 -> [(SDoc, SDoc, Type, CmmType)]
754 go 4 args = ret_addr_arg dflags : args
755 go n (arg:args) = arg : go (n+1) args
756 go _ [] = []
757 in go 0 args
758 | otherwise ->
759 -- On other x86_64 platforms we insert the return address
760 -- after the 6th integer argument, because this is the point
761 -- at which we need to flush a register argument to the stack
762 -- (See rts/Adjustor.c for details).
763 let go :: Int -> [(SDoc, SDoc, Type, CmmType)]
764 -> [(SDoc, SDoc, Type, CmmType)]
765 go 6 args = ret_addr_arg dflags : args
766 go n (arg@(_,_,_,rep):args)
767 | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args
768 | otherwise = arg : go n args
769 go _ [] = []
770 in go 0 args
771 _ ->
772 ret_addr_arg dflags : args
773 where platform = targetPlatform dflags
774 insertRetAddr _ _ args = args
775
776 ret_addr_arg :: DynFlags -> (SDoc, SDoc, Type, CmmType)
777 ret_addr_arg dflags = (text "original_return_addr", text "void*", undefined,
778 typeCmmType dflags addrPrimTy)
779
780 -- This function returns the primitive type associated with the boxed
781 -- type argument to a foreign export (eg. Int ==> Int#).
782 getPrimTyOf :: Type -> UnaryType
783 getPrimTyOf ty
784 | isBoolTy rep_ty = intPrimTy
785 -- Except for Bool, the types we are interested in have a single constructor
786 -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).
787 | otherwise =
788 case splitDataProductType_maybe rep_ty of
789 Just (_, _, data_con, [prim_ty]) ->
790 ASSERT(dataConSourceArity data_con == 1)
791 ASSERT2(isUnliftedType prim_ty, ppr prim_ty)
792 prim_ty
793 _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)
794 where
795 UnaryRep rep_ty = repType ty
796
797 -- represent a primitive type as a Char, for building a string that
798 -- described the foreign function type. The types are size-dependent,
799 -- e.g. 'W' is a signed 32-bit integer.
800 primTyDescChar :: DynFlags -> Type -> Char
801 primTyDescChar dflags ty
802 | ty `eqType` unitTy = 'v'
803 | otherwise
804 = case typePrimRep (getPrimTyOf ty) of
805 IntRep -> signed_word
806 WordRep -> unsigned_word
807 Int64Rep -> 'L'
808 Word64Rep -> 'l'
809 AddrRep -> 'p'
810 FloatRep -> 'f'
811 DoubleRep -> 'd'
812 _ -> pprPanic "primTyDescChar" (ppr ty)
813 where
814 (signed_word, unsigned_word)
815 | wORD_SIZE dflags == 4 = ('W','w')
816 | wORD_SIZE dflags == 8 = ('L','l')
817 | otherwise = panic "primTyDescChar"