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