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