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