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