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