Introduce new file format for the package database binary cache
[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 {-# LANGUAGE CPP #-}
10
11 module DsForeign ( dsForeigns
12                  , dsForeigns'
13                  , dsFImport, dsCImport, dsFCall, dsPrimCall
14                  , dsFExport, dsFExportDynamic, mkFExportCBits
15                  , toCType
16                  , foreignExportInitialiser
17                  ) where
18
19 #include "HsVersions.h"
20 import TcRnMonad        -- temp
21
22 import TypeRep
23
24 import CoreSyn
25
26 import DsCCall
27 import DsMonad
28
29 import HsSyn
30 import DataCon
31 import CoreUnfold
32 import Id
33 import Literal
34 import Module
35 import Name
36 import Type
37 import TyCon
38 import Coercion
39 import TcEnv
40 import TcType
41
42 import CmmExpr
43 import CmmUtils
44 import HscTypes
45 import ForeignCall
46 import TysWiredIn
47 import TysPrim
48 import PrelNames
49 import BasicTypes
50 import SrcLoc
51 import Outputable
52 import FastString
53 import DynFlags
54 import Platform
55 import Config
56 import OrdList
57 import Pair
58 import Util
59 import Hooks
60
61 import Data.Maybe
62 import Data.List
63 \end{code}
64
65 Desugaring of @foreign@ declarations is naturally split up into
66 parts, an @import@ and an @export@  part. A @foreign import@
67 declaration
68 \begin{verbatim}
69   foreign import cc nm f :: prim_args -> IO prim_res
70 \end{verbatim}
71 is the same as
72 \begin{verbatim}
73   f :: prim_args -> IO prim_res
74   f a1 ... an = _ccall_ nm cc a1 ... an
75 \end{verbatim}
76 so we reuse the desugaring code in @DsCCall@ to deal with these.
77
78 \begin{code}
79 type Binding = (Id, CoreExpr)   -- No rec/nonrec structure;
80                                 -- the occurrence analyser will sort it all out
81
82 dsForeigns :: [LForeignDecl Id]
83            -> DsM (ForeignStubs, OrdList Binding)
84 dsForeigns fos = getHooked dsForeignsHook dsForeigns' >>= ($ fos)
85
86 dsForeigns' :: [LForeignDecl Id]
87             -> DsM (ForeignStubs, OrdList Binding)
88 dsForeigns' []
89   = return (NoStubs, nilOL)
90 dsForeigns' fos = do
91     fives <- mapM do_ldecl fos
92     let
93         (hs, cs, idss, bindss) = unzip4 fives
94         fe_ids = concat idss
95         fe_init_code = map foreignExportInitialiser fe_ids
96     --
97     return (ForeignStubs
98              (vcat hs)
99              (vcat cs $$ vcat fe_init_code),
100             foldr (appOL . toOL) nilOL bindss)
101   where
102    do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl)
103
104    do_decl (ForeignImport id _ co spec) = do
105       traceIf (text "fi start" <+> ppr id)
106       (bs, h, c) <- dsFImport (unLoc id) co spec
107       traceIf (text "fi end" <+> ppr id)
108       return (h, c, [], bs)
109
110    do_decl (ForeignExport (L _ id) _ co (CExport (CExportStatic ext_nm cconv))) = do
111       (h, c, _, _) <- dsFExport id co ext_nm cconv False
112       return (h, c, [id], [])
113 \end{code}
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 \begin{code}
141 dsFImport :: Id
142           -> Coercion
143           -> ForeignImport
144           -> DsM ([Binding], SDoc, SDoc)
145 dsFImport id co (CImport cconv safety mHeader spec) = do
146     (ids, h, c) <- dsCImport id co spec cconv safety mHeader
147     return (ids, h, c)
148
149 dsCImport :: Id
150           -> Coercion
151           -> CImportSpec
152           -> CCallConv
153           -> Safety
154           -> Maybe Header
155           -> DsM ([Binding], SDoc, SDoc)
156 dsCImport id co (CLabel cid) cconv _ _ = do
157    dflags <- getDynFlags
158    let ty = pFst $ coercionKind co
159        fod = case tyConAppTyCon_maybe (dropForAlls ty) of
160              Just tycon
161               | tyConUnique tycon == funPtrTyConKey ->
162                  IsFunction
163              _ -> IsData
164    (resTy, foRhs) <- resultWrapper ty
165    ASSERT(fromJust resTy `eqType` addrPrimTy)    -- typechecker ensures this
166     let
167         rhs = foRhs (Lit (MachLabel cid stdcall_info fod))
168         rhs' = Cast rhs co
169         stdcall_info = fun_type_arg_stdcall_info dflags cconv ty
170     in
171     return ([(id, rhs')], empty, empty)
172
173 dsCImport id co (CFunction target) cconv@PrimCallConv safety _
174   = dsPrimCall id co (CCall (CCallSpec target cconv safety))
175 dsCImport id co (CFunction target) cconv safety mHeader
176   = dsFCall id co (CCall (CCallSpec target cconv safety)) mHeader
177 dsCImport id co CWrapper cconv _ _
178   = dsFExportDynamic id co cconv
179
180 -- For stdcall labels, if the type was a FunPtr or newtype thereof,
181 -- then we need to calculate the size of the arguments in order to add
182 -- the @n suffix to the label.
183 fun_type_arg_stdcall_info :: DynFlags -> CCallConv -> Type -> Maybe Int
184 fun_type_arg_stdcall_info dflags StdCallConv ty
185   | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty,
186     tyConUnique tc == funPtrTyConKey
187   = let
188        (_tvs,sans_foralls)        = tcSplitForAllTys arg_ty
189        (fe_arg_tys, _orig_res_ty) = tcSplitFunTys sans_foralls
190     in Just $ sum (map (widthInBytes . typeWidth . typeCmmType dflags . getPrimTyOf) fe_arg_tys)
191 fun_type_arg_stdcall_info _ _other_conv _
192   = Nothing
193 \end{code}
194
195
196 %************************************************************************
197 %*                                                                      *
198 \subsection{Foreign calls}
199 %*                                                                      *
200 %************************************************************************
201
202 \begin{code}
203 dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header
204         -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
205 dsFCall fn_id co fcall mDeclHeader = do
206     let
207         ty                   = pFst $ coercionKind co
208         (tvs, fun_ty)        = tcSplitForAllTys ty
209         (arg_tys, io_res_ty) = tcSplitFunTys fun_ty
210                 -- Must use tcSplit* functions because we want to
211                 -- see that (IO t) in the corner
212
213     args <- newSysLocalsDs arg_tys
214     (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args)
215
216     let
217         work_arg_ids  = [v | Var v <- val_args] -- All guaranteed to be vars
218
219     (ccall_result_ty, res_wrapper) <- boxResult io_res_ty
220
221     ccall_uniq <- newUnique
222     work_uniq  <- newUnique
223
224     dflags <- getDynFlags
225     (fcall', cDoc) <-
226               case fcall of
227               CCall (CCallSpec (StaticTarget cName mPackageKey isFun) CApiConv safety) ->
228                do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName)
229                   let fcall' = CCall (CCallSpec (StaticTarget wrapperName mPackageKey True) CApiConv safety)
230                       c = includes
231                        $$ fun_proto <+> braces (cRet <> semi)
232                       includes = vcat [ text "#include <" <> ftext h <> text ">"
233                                       | Header h <- nub headers ]
234                       fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes
235                       cRet
236                        | isVoidRes =                   cCall
237                        | otherwise = text "return" <+> cCall
238                       cCall = if isFun
239                               then ppr cName <> parens argVals
240                               else if null arg_tys
241                                     then ppr cName
242                                     else panic "dsFCall: Unexpected arguments to FFI value import"
243                       raw_res_ty = case tcSplitIOType_maybe io_res_ty of
244                                    Just (_ioTyCon, res_ty) -> res_ty
245                                    Nothing                 -> io_res_ty
246                       isVoidRes = raw_res_ty `eqType` unitTy
247                       (mHeader, cResType)
248                        | isVoidRes = (Nothing, text "void")
249                        | otherwise = toCType raw_res_ty
250                       pprCconv = ccallConvAttribute CApiConv
251                       mHeadersArgTypeList
252                           = [ (header, cType <+> char 'a' <> int n)
253                             | (t, n) <- zip arg_tys [1..]
254                             , let (header, cType) = toCType t ]
255                       (mHeaders, argTypeList) = unzip mHeadersArgTypeList
256                       argTypes = if null argTypeList
257                                  then text "void"
258                                  else hsep $ punctuate comma argTypeList
259                       mHeaders' = mDeclHeader : mHeader : mHeaders
260                       headers = catMaybes mHeaders'
261                       argVals = hsep $ punctuate comma
262                                     [ char 'a' <> int n
263                                     | (_, n) <- zip arg_tys [1..] ]
264                   return (fcall', c)
265               _ ->
266                   return (fcall, empty)
267     let
268         -- Build the worker
269         worker_ty     = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
270         the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty
271         work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)
272         work_id       = mkSysLocal (fsLit "$wccall") work_uniq worker_ty
273
274         -- Build the wrapper
275         work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
276         wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
277         wrap_rhs     = mkLams (tvs ++ args) wrapper_body
278         wrap_rhs'    = Cast wrap_rhs co
279         fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineUnfolding (Just (length args)) wrap_rhs'
280
281     return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, cDoc)
282 \end{code}
283
284
285 %************************************************************************
286 %*                                                                      *
287 \subsection{Primitive calls}
288 %*                                                                      *
289 %************************************************************************
290
291 This is for `@foreign import prim@' declarations.
292
293 Currently, at the core level we pretend that these primitive calls are
294 foreign calls. It may make more sense in future to have them as a distinct
295 kind of Id, or perhaps to bundle them with PrimOps since semantically and
296 for calling convention they are really prim ops.
297
298 \begin{code}
299 dsPrimCall :: Id -> Coercion -> ForeignCall
300            -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
301 dsPrimCall fn_id co fcall = do
302     let
303         ty                   = pFst $ coercionKind co
304         (tvs, fun_ty)        = tcSplitForAllTys ty
305         (arg_tys, io_res_ty) = tcSplitFunTys fun_ty
306                 -- Must use tcSplit* functions because we want to
307                 -- see that (IO t) in the corner
308
309     args <- newSysLocalsDs arg_tys
310
311     ccall_uniq <- newUnique
312     dflags <- getDynFlags
313     let
314         call_app = mkFCall dflags ccall_uniq fcall (map Var args) io_res_ty
315         rhs      = mkLams tvs (mkLams args call_app)
316         rhs'     = Cast rhs co
317     return ([(fn_id, rhs')], empty, empty)
318
319 \end{code}
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 \begin{code}
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        (_tvs,sans_foralls)             = tcSplitForAllTys ty
358        (fe_arg_tys', orig_res_ty)      = tcSplitFunTys sans_foralls
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 \end{code}
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:
402
403 f_helper(StablePtr s, HsBool b, HsInt i)
404 {
405         rts_evalIO(rts_apply(rts_apply(deRefStablePtr(s),
406                                        rts_mkBool(b)), rts_mkInt(i)));
407 }
408 \end{verbatim}
409
410 \begin{code}
411 dsFExportDynamic :: Id
412                  -> Coercion
413                  -> CCallConv
414                  -> DsM ([Binding], SDoc, SDoc)
415 dsFExportDynamic id co0 cconv = do
416     fe_id <-  newSysLocalDs ty
417     mod <- getModule
418     dflags <- getDynFlags
419     let
420         -- hack: need to get at the name of the C stub we're about to generate.
421         -- TODO: There's no real need to go via String with
422         -- (mkFastString . zString). In fact, is there a reason to convert
423         -- to FastString at all now, rather than sticking with FastZString?
424         fe_nm    = mkFastString (zString (zEncodeFS (moduleNameFS (moduleName mod))) ++ "_" ++ toCName dflags fe_id)
425
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 (mkReflCo Representational 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 toCName :: DynFlags -> Id -> String
485 toCName dflags i = showSDoc dflags (pprCode CStyle (ppr (idName i)))
486 \end{code}
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 \begin{code}
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                       ptext (sLit "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 = ptext (sLit "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       = ptext (sLit "void") <+> ftext c_nm <>
593           parens (ptext (sLit "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      ,   ptext (sLit "Capability *cap;")
637      ,   declareResult
638      ,   declareCResult
639      ,   text "cap = rts_lock();"
640           -- create the application + perform it.
641      ,   ptext (sLit "rts_evalIO") <> parens (
642                 char '&' <> cap <>
643                 ptext (sLit "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      ,   ptext (sLit "rts_checkSchedStatus") <> parens (doubleQuotes (ftext c_nm)
655                                                 <> comma <> text "cap") <> semi
656      ,   assignCResult
657      ,   ptext (sLit "rts_unlock(cap);")
658      ,   ppUnless res_hty_is_unit $
659          if libffi
660                   then char '*' <> parens (ffi_cResType <> char '*') <>
661                        ptext (sLit "resp = cret;")
662                   else ptext (sLit "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.lhs; 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            | TyConApp tycon _ <- 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, ptext (sLit "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"
812 \end{code}