Re-add FunTy (big patch)
[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 (tv_bndrs, rho) = tcSplitForAllTyVarBndrs ty
200 (arg_tys, io_res_ty) = tcSplitFunTys rho
201
202 args <- newSysLocalsDs arg_tys
203 (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args)
204
205 let
206 work_arg_ids = [v | Var v <- val_args] -- All guaranteed to be vars
207
208 (ccall_result_ty, res_wrapper) <- boxResult io_res_ty
209
210 ccall_uniq <- newUnique
211 work_uniq <- newUnique
212
213 dflags <- getDynFlags
214 (fcall', cDoc) <-
215 case fcall of
216 CCall (CCallSpec (StaticTarget _ cName mUnitId isFun)
217 CApiConv safety) ->
218 do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName)
219 let fcall' = CCall (CCallSpec
220 (StaticTarget (unpackFS wrapperName)
221 wrapperName mUnitId
222 True)
223 CApiConv safety)
224 c = includes
225 $$ fun_proto <+> braces (cRet <> semi)
226 includes = vcat [ text "#include <" <> ftext h <> text ">"
227 | Header _ h <- nub headers ]
228 fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes
229 cRet
230 | isVoidRes = cCall
231 | otherwise = text "return" <+> cCall
232 cCall = if isFun
233 then ppr cName <> parens argVals
234 else if null arg_tys
235 then ppr cName
236 else panic "dsFCall: Unexpected arguments to FFI value import"
237 raw_res_ty = case tcSplitIOType_maybe io_res_ty of
238 Just (_ioTyCon, res_ty) -> res_ty
239 Nothing -> io_res_ty
240 isVoidRes = raw_res_ty `eqType` unitTy
241 (mHeader, cResType)
242 | isVoidRes = (Nothing, text "void")
243 | otherwise = toCType raw_res_ty
244 pprCconv = ccallConvAttribute CApiConv
245 mHeadersArgTypeList
246 = [ (header, cType <+> char 'a' <> int n)
247 | (t, n) <- zip arg_tys [1..]
248 , let (header, cType) = toCType t ]
249 (mHeaders, argTypeList) = unzip mHeadersArgTypeList
250 argTypes = if null argTypeList
251 then text "void"
252 else hsep $ punctuate comma argTypeList
253 mHeaders' = mDeclHeader : mHeader : mHeaders
254 headers = catMaybes mHeaders'
255 argVals = hsep $ punctuate comma
256 [ char 'a' <> int n
257 | (_, n) <- zip arg_tys [1..] ]
258 return (fcall', c)
259 _ ->
260 return (fcall, empty)
261 let
262 -- Build the worker
263 worker_ty = mkForAllTys tv_bndrs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
264 tvs = map binderVar tv_bndrs
265 the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty
266 work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app)
267 work_id = mkSysLocal (fsLit "$wccall") work_uniq worker_ty
268
269 -- Build the wrapper
270 work_app = mkApps (mkVarApps (Var work_id) tvs) val_args
271 wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
272 wrap_rhs = mkLams (tvs ++ args) wrapper_body
273 wrap_rhs' = Cast wrap_rhs co
274 fn_id_w_inl = fn_id `setIdUnfolding` mkInlineUnfolding (Just (length args)) wrap_rhs'
275
276 return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, cDoc)
277
278 {-
279 ************************************************************************
280 * *
281 \subsection{Primitive calls}
282 * *
283 ************************************************************************
284
285 This is for `@foreign import prim@' declarations.
286
287 Currently, at the core level we pretend that these primitive calls are
288 foreign calls. It may make more sense in future to have them as a distinct
289 kind of Id, or perhaps to bundle them with PrimOps since semantically and
290 for calling convention they are really prim ops.
291 -}
292
293 dsPrimCall :: Id -> Coercion -> ForeignCall
294 -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
295 dsPrimCall fn_id co fcall = do
296 let
297 ty = pFst $ coercionKind co
298 (tvs, fun_ty) = tcSplitForAllTys ty
299 (arg_tys, io_res_ty) = tcSplitFunTys fun_ty
300
301 args <- newSysLocalsDs arg_tys
302
303 ccall_uniq <- newUnique
304 dflags <- getDynFlags
305 let
306 call_app = mkFCall dflags ccall_uniq fcall (map Var args) io_res_ty
307 rhs = mkLams tvs (mkLams args call_app)
308 rhs' = Cast rhs co
309 return ([(fn_id, rhs')], empty, empty)
310
311 {-
312 ************************************************************************
313 * *
314 \subsection{Foreign export}
315 * *
316 ************************************************************************
317
318 The function that does most of the work for `@foreign export@' declarations.
319 (see below for the boilerplate code a `@foreign export@' declaration expands
320 into.)
321
322 For each `@foreign export foo@' in a module M we generate:
323 \begin{itemize}
324 \item a C function `@foo@', which calls
325 \item a Haskell stub `@M.\$ffoo@', which calls
326 \end{itemize}
327 the user-written Haskell function `@M.foo@'.
328 -}
329
330 dsFExport :: Id -- Either the exported Id,
331 -- or the foreign-export-dynamic constructor
332 -> Coercion -- Coercion between the Haskell type callable
333 -- from C, and its representation type
334 -> CLabelString -- The name to export to C land
335 -> CCallConv
336 -> Bool -- True => foreign export dynamic
337 -- so invoke IO action that's hanging off
338 -- the first argument's stable pointer
339 -> DsM ( SDoc -- contents of Module_stub.h
340 , SDoc -- contents of Module_stub.c
341 , String -- string describing type to pass to createAdj.
342 , Int -- size of args to stub function
343 )
344
345 dsFExport fn_id co ext_name cconv isDyn = do
346 let
347 ty = pSnd $ coercionKind co
348 (bndrs, orig_res_ty) = tcSplitPiTys ty
349 fe_arg_tys' = mapMaybe binderRelevantType_maybe bndrs
350 -- We must use tcSplits here, because we want to see
351 -- the (IO t) in the corner of the type!
352 fe_arg_tys | isDyn = tail fe_arg_tys'
353 | otherwise = fe_arg_tys'
354
355 -- Look at the result type of the exported function, orig_res_ty
356 -- If it's IO t, return (t, True)
357 -- If it's plain t, return (t, False)
358 (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of
359 -- The function already returns IO t
360 Just (_ioTyCon, res_ty) -> (res_ty, True)
361 -- The function returns t
362 Nothing -> (orig_res_ty, False)
363
364 dflags <- getDynFlags
365 return $
366 mkFExportCBits dflags ext_name
367 (if isDyn then Nothing else Just fn_id)
368 fe_arg_tys res_ty is_IO_res_ty cconv
369
370 {-
371 @foreign import "wrapper"@ (previously "foreign export dynamic") lets
372 you dress up Haskell IO actions of some fixed type behind an
373 externally callable interface (i.e., as a C function pointer). Useful
374 for callbacks and stuff.
375
376 \begin{verbatim}
377 type Fun = Bool -> Int -> IO Int
378 foreign import "wrapper" f :: Fun -> IO (FunPtr Fun)
379
380 -- Haskell-visible constructor, which is generated from the above:
381 -- SUP: No check for NULL from createAdjustor anymore???
382
383 f :: Fun -> IO (FunPtr Fun)
384 f cback =
385 bindIO (newStablePtr cback)
386 (\StablePtr sp# -> IO (\s1# ->
387 case _ccall_ createAdjustor cconv sp# ``f_helper'' <arg info> s1# of
388 (# s2#, a# #) -> (# s2#, A# a# #)))
389
390 foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun)
391
392 -- and the helper in C: (approximately; see `mkFExportCBits` below)
393
394 f_helper(StablePtr s, HsBool b, HsInt i)
395 {
396 Capability *cap;
397 cap = rts_lock();
398 rts_evalIO(&cap,
399 rts_apply(rts_apply(deRefStablePtr(s),
400 rts_mkBool(b)), rts_mkInt(i)));
401 rts_unlock(cap);
402 }
403 \end{verbatim}
404 -}
405
406 dsFExportDynamic :: Id
407 -> Coercion
408 -> CCallConv
409 -> DsM ([Binding], SDoc, SDoc)
410 dsFExportDynamic id co0 cconv = do
411 fe_id <- newSysLocalDs ty
412 mod <- getModule
413 dflags <- getDynFlags
414 let
415 -- hack: need to get at the name of the C stub we're about to generate.
416 -- TODO: There's no real need to go via String with
417 -- (mkFastString . zString). In fact, is there a reason to convert
418 -- to FastString at all now, rather than sticking with FastZString?
419 fe_nm = mkFastString (zString (zEncodeFS (moduleNameFS (moduleName mod))) ++ "_" ++ toCName dflags fe_id)
420
421 cback <- newSysLocalDs arg_ty
422 newStablePtrId <- dsLookupGlobalId newStablePtrName
423 stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName
424 let
425 stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]
426 export_ty = mkFunTy stable_ptr_ty arg_ty
427 bindIOId <- dsLookupGlobalId bindIOName
428 stbl_value <- newSysLocalDs stable_ptr_ty
429 (h_code, c_code, typestring, args_size) <- dsFExport id (mkRepReflCo export_ty) fe_nm cconv True
430 let
431 {-
432 The arguments to the external function which will
433 create a little bit of (template) code on the fly
434 for allowing the (stable pointed) Haskell closure
435 to be entered using an external calling convention
436 (stdcall, ccall).
437 -}
438 adj_args = [ mkIntLitInt dflags (ccallConvToInt cconv)
439 , Var stbl_value
440 , Lit (MachLabel fe_nm mb_sz_args IsFunction)
441 , Lit (mkMachString typestring)
442 ]
443 -- name of external entry point providing these services.
444 -- (probably in the RTS.)
445 adjustor = fsLit "createAdjustor"
446
447 -- Determine the number of bytes of arguments to the stub function,
448 -- so that we can attach the '@N' suffix to its label if it is a
449 -- stdcall on Windows.
450 mb_sz_args = case cconv of
451 StdCallConv -> Just args_size
452 _ -> Nothing
453
454 ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])
455 -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
456
457 let io_app = mkLams tvs $
458 Lam cback $
459 mkApps (Var bindIOId)
460 [ Type stable_ptr_ty
461 , Type res_ty
462 , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
463 , Lam stbl_value ccall_adj
464 ]
465
466 fed = (id `setInlineActivation` NeverActive, Cast io_app co0)
467 -- Never inline the f.e.d. function, because the litlit
468 -- might not be in scope in other modules.
469
470 return ([fed], h_code, c_code)
471
472 where
473 ty = pFst (coercionKind co0)
474 (tvs,sans_foralls) = tcSplitForAllTys ty
475 ([arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls
476 Just (io_tc, res_ty) = tcSplitIOType_maybe fn_res_ty
477 -- Must have an IO type; hence Just
478
479
480 toCName :: DynFlags -> Id -> String
481 toCName dflags i = showSDoc dflags (pprCode CStyle (ppr (idName i)))
482
483 {-
484 *
485
486 \subsection{Generating @foreign export@ stubs}
487
488 *
489
490 For each @foreign export@ function, a C stub function is generated.
491 The C stub constructs the application of the exported Haskell function
492 using the hugs/ghc rts invocation API.
493 -}
494
495 mkFExportCBits :: DynFlags
496 -> FastString
497 -> Maybe Id -- Just==static, Nothing==dynamic
498 -> [Type]
499 -> Type
500 -> Bool -- True <=> returns an IO type
501 -> CCallConv
502 -> (SDoc,
503 SDoc,
504 String, -- the argument reps
505 Int -- total size of arguments
506 )
507 mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
508 = (header_bits, c_bits, type_string,
509 sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args
510 -- NB. the calculation here isn't strictly speaking correct.
511 -- We have a primitive Haskell type (eg. Int#, Double#), and
512 -- we want to know the size, when passed on the C stack, of
513 -- the associated C type (eg. HsInt, HsDouble). We don't have
514 -- this information to hand, but we know what GHC's conventions
515 -- are for passing around the primitive Haskell types, so we
516 -- use that instead. I hope the two coincide --SDM
517 )
518 where
519 -- list the arguments to the C function
520 arg_info :: [(SDoc, -- arg name
521 SDoc, -- C type
522 Type, -- Haskell type
523 CmmType)] -- the CmmType
524 arg_info = [ let stg_type = showStgType ty in
525 (arg_cname n stg_type,
526 stg_type,
527 ty,
528 typeCmmType dflags (getPrimTyOf ty))
529 | (ty,n) <- zip arg_htys [1::Int ..] ]
530
531 arg_cname n stg_ty
532 | libffi = char '*' <> parens (stg_ty <> char '*') <>
533 text "args" <> brackets (int (n-1))
534 | otherwise = text ('a':show n)
535
536 -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled
537 libffi = cLibFFI && isNothing maybe_target
538
539 type_string
540 -- libffi needs to know the result type too:
541 | libffi = primTyDescChar dflags res_hty : arg_type_string
542 | otherwise = arg_type_string
543
544 arg_type_string = [primTyDescChar dflags ty | (_,_,ty,_) <- arg_info]
545 -- just the real args
546
547 -- add some auxiliary args; the stable ptr in the wrapper case, and
548 -- a slot for the dummy return address in the wrapper + ccall case
549 aug_arg_info
550 | isNothing maybe_target = stable_ptr_arg : insertRetAddr dflags cc arg_info
551 | otherwise = arg_info
552
553 stable_ptr_arg =
554 (text "the_stableptr", text "StgStablePtr", undefined,
555 typeCmmType dflags (mkStablePtrPrimTy alphaTy))
556
557 -- stuff to do with the return type of the C function
558 res_hty_is_unit = res_hty `eqType` unitTy -- Look through any newtypes
559
560 cResType | res_hty_is_unit = text "void"
561 | otherwise = showStgType res_hty
562
563 -- when the return type is integral and word-sized or smaller, it
564 -- must be assigned as type ffi_arg (#3516). To see what type
565 -- libffi is expecting here, take a look in its own testsuite, e.g.
566 -- libffi/testsuite/libffi.call/cls_align_ulonglong.c
567 ffi_cResType
568 | is_ffi_arg_type = text "ffi_arg"
569 | otherwise = cResType
570 where
571 res_ty_key = getUnique (getName (typeTyCon res_hty))
572 is_ffi_arg_type = res_ty_key `notElem`
573 [floatTyConKey, doubleTyConKey,
574 int64TyConKey, word64TyConKey]
575
576 -- Now we can cook up the prototype for the exported function.
577 pprCconv = ccallConvAttribute cc
578
579 header_bits = text "extern" <+> fun_proto <> semi
580
581 fun_args
582 | null aug_arg_info = text "void"
583 | otherwise = hsep $ punctuate comma
584 $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info
585
586 fun_proto
587 | libffi
588 = text "void" <+> ftext c_nm <>
589 parens (text "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr")
590 | otherwise
591 = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args
592
593 -- the target which will form the root of what we ask rts_evalIO to run
594 the_cfun
595 = case maybe_target of
596 Nothing -> text "(StgClosure*)deRefStablePtr(the_stableptr)"
597 Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"
598
599 cap = text "cap" <> comma
600
601 -- the expression we give to rts_evalIO
602 expr_to_run
603 = foldl appArg the_cfun arg_info -- NOT aug_arg_info
604 where
605 appArg acc (arg_cname, _, arg_hty, _)
606 = text "rts_apply"
607 <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname))
608
609 -- various other bits for inside the fn
610 declareResult = text "HaskellObj ret;"
611 declareCResult | res_hty_is_unit = empty
612 | otherwise = cResType <+> text "cret;"
613
614 assignCResult | res_hty_is_unit = empty
615 | otherwise =
616 text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi
617
618 -- an extern decl for the fn being called
619 extern_decl
620 = case maybe_target of
621 Nothing -> empty
622 Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi
623
624
625 -- finally, the whole darn thing
626 c_bits =
627 space $$
628 extern_decl $$
629 fun_proto $$
630 vcat
631 [ lbrace
632 , text "Capability *cap;"
633 , declareResult
634 , declareCResult
635 , text "cap = rts_lock();"
636 -- create the application + perform it.
637 , text "rts_evalIO" <> parens (
638 char '&' <> cap <>
639 text "rts_apply" <> parens (
640 cap <>
641 text "(HaskellObj)"
642 <> ptext (if is_IO_res_ty
643 then (sLit "runIO_closure")
644 else (sLit "runNonIO_closure"))
645 <> comma
646 <> expr_to_run
647 ) <+> comma
648 <> text "&ret"
649 ) <> semi
650 , text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm)
651 <> comma <> text "cap") <> semi
652 , assignCResult
653 , text "rts_unlock(cap);"
654 , ppUnless res_hty_is_unit $
655 if libffi
656 then char '*' <> parens (ffi_cResType <> char '*') <>
657 text "resp = cret;"
658 else text "return cret;"
659 , rbrace
660 ]
661
662
663 foreignExportInitialiser :: Id -> SDoc
664 foreignExportInitialiser hs_fn =
665 -- Initialise foreign exports by registering a stable pointer from an
666 -- __attribute__((constructor)) function.
667 -- The alternative is to do this from stginit functions generated in
668 -- codeGen/CodeGen.hs; however, stginit functions have a negative impact
669 -- on binary sizes and link times because the static linker will think that
670 -- all modules that are imported directly or indirectly are actually used by
671 -- the program.
672 -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)
673 vcat
674 [ text "static void stginit_export_" <> ppr hs_fn
675 <> text "() __attribute__((constructor));"
676 , text "static void stginit_export_" <> ppr hs_fn <> text "()"
677 , braces (text "foreignExportStablePtr"
678 <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure")
679 <> semi)
680 ]
681
682
683 mkHObj :: Type -> SDoc
684 mkHObj t = text "rts_mk" <> text (showFFIType t)
685
686 unpackHObj :: Type -> SDoc
687 unpackHObj t = text "rts_get" <> text (showFFIType t)
688
689 showStgType :: Type -> SDoc
690 showStgType t = text "Hs" <> text (showFFIType t)
691
692 showFFIType :: Type -> String
693 showFFIType t = getOccString (getName (typeTyCon t))
694
695 toCType :: Type -> (Maybe Header, SDoc)
696 toCType = f False
697 where f voidOK t
698 -- First, if we have (Ptr t) of (FunPtr t), then we need to
699 -- convert t to a C type and put a * after it. If we don't
700 -- know a type for t, then "void" is fine, though.
701 | Just (ptr, [t']) <- splitTyConApp_maybe t
702 , tyConName ptr `elem` [ptrTyConName, funPtrTyConName]
703 = case f True t' of
704 (mh, cType') ->
705 (mh, cType' <> char '*')
706 -- Otherwise, if we have a type constructor application, then
707 -- see if there is a C type associated with that constructor.
708 -- Note that we aren't looking through type synonyms or
709 -- anything, as it may be the synonym that is annotated.
710 | Just tycon <- tyConAppTyConPicky_maybe t
711 , Just (CType _ mHeader (_,cType)) <- tyConCType_maybe tycon
712 = (mHeader, ftext cType)
713 -- If we don't know a C type for this type, then try looking
714 -- through one layer of type synonym etc.
715 | Just t' <- coreView t
716 = f voidOK t'
717 -- Otherwise we don't know the C type. If we are allowing
718 -- void then return that; otherwise something has gone wrong.
719 | voidOK = (Nothing, text "void")
720 | otherwise
721 = pprPanic "toCType" (ppr t)
722
723 typeTyCon :: Type -> TyCon
724 typeTyCon ty
725 | UnaryRep rep_ty <- repType ty
726 , Just (tc, _) <- tcSplitTyConApp_maybe rep_ty
727 = tc
728 | otherwise
729 = pprPanic "DsForeign.typeTyCon" (ppr ty)
730
731 insertRetAddr :: DynFlags -> CCallConv
732 -> [(SDoc, SDoc, Type, CmmType)]
733 -> [(SDoc, SDoc, Type, CmmType)]
734 insertRetAddr dflags CCallConv args
735 = case platformArch platform of
736 ArchX86_64
737 | platformOS platform == OSMinGW32 ->
738 -- On other Windows x86_64 we insert the return address
739 -- after the 4th argument, because this is the point
740 -- at which we need to flush a register argument to the stack
741 -- (See rts/Adjustor.c for details).
742 let go :: Int -> [(SDoc, SDoc, Type, CmmType)]
743 -> [(SDoc, SDoc, Type, CmmType)]
744 go 4 args = ret_addr_arg dflags : args
745 go n (arg:args) = arg : go (n+1) args
746 go _ [] = []
747 in go 0 args
748 | otherwise ->
749 -- On other x86_64 platforms we insert the return address
750 -- after the 6th integer argument, because this is the point
751 -- at which we need to flush a register argument to the stack
752 -- (See rts/Adjustor.c for details).
753 let go :: Int -> [(SDoc, SDoc, Type, CmmType)]
754 -> [(SDoc, SDoc, Type, CmmType)]
755 go 6 args = ret_addr_arg dflags : args
756 go n (arg@(_,_,_,rep):args)
757 | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args
758 | otherwise = arg : go n args
759 go _ [] = []
760 in go 0 args
761 _ ->
762 ret_addr_arg dflags : args
763 where platform = targetPlatform dflags
764 insertRetAddr _ _ args = args
765
766 ret_addr_arg :: DynFlags -> (SDoc, SDoc, Type, CmmType)
767 ret_addr_arg dflags = (text "original_return_addr", text "void*", undefined,
768 typeCmmType dflags addrPrimTy)
769
770 -- This function returns the primitive type associated with the boxed
771 -- type argument to a foreign export (eg. Int ==> Int#).
772 getPrimTyOf :: Type -> UnaryType
773 getPrimTyOf ty
774 | isBoolTy rep_ty = intPrimTy
775 -- Except for Bool, the types we are interested in have a single constructor
776 -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).
777 | otherwise =
778 case splitDataProductType_maybe rep_ty of
779 Just (_, _, data_con, [prim_ty]) ->
780 ASSERT(dataConSourceArity data_con == 1)
781 ASSERT2(isUnliftedType prim_ty, ppr prim_ty)
782 prim_ty
783 _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)
784 where
785 UnaryRep rep_ty = repType ty
786
787 -- represent a primitive type as a Char, for building a string that
788 -- described the foreign function type. The types are size-dependent,
789 -- e.g. 'W' is a signed 32-bit integer.
790 primTyDescChar :: DynFlags -> Type -> Char
791 primTyDescChar dflags ty
792 | ty `eqType` unitTy = 'v'
793 | otherwise
794 = case typePrimRep (getPrimTyOf ty) of
795 IntRep -> signed_word
796 WordRep -> unsigned_word
797 Int64Rep -> 'L'
798 Word64Rep -> 'l'
799 AddrRep -> 'p'
800 FloatRep -> 'f'
801 DoubleRep -> 'd'
802 _ -> pprPanic "primTyDescChar" (ppr ty)
803 where
804 (signed_word, unsigned_word)
805 | wORD_SIZE dflags == 4 = ('W','w')
806 | wORD_SIZE dflags == 8 = ('L','l')
807 | otherwise = panic "primTyDescChar"