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