DsForeign.lhs 27.3 KB
Newer Older
sof's avatar
sof committed
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
sof's avatar
sof committed
3
4
5
% (c) The AQUA Project, Glasgow University, 1998
%

Simon Marlow's avatar
Simon Marlow committed
6
Desugaring foreign declarations (see also DsCCall).
sof's avatar
sof committed
7
8
9
10
11

\begin{code}
module DsForeign ( dsForeigns ) where

#include "HsVersions.h"
12
import TcRnMonad        -- temp
sof's avatar
sof committed
13
14
15

import CoreSyn

Simon Marlow's avatar
Simon Marlow committed
16
import DsCCall
sof's avatar
sof committed
17
18
import DsMonad

Simon Marlow's avatar
Simon Marlow committed
19
20
import HsSyn
import DataCon
21
import CoreUnfold
Simon Marlow's avatar
Simon Marlow committed
22
23
24
25
26
import Id
import Literal
import Module
import Name
import Type
27
import TyCon
Simon Marlow's avatar
Simon Marlow committed
28
29
import Coercion
import TcType
30

31
32
import CmmExpr
import CmmUtils
Simon Marlow's avatar
Simon Marlow committed
33
34
35
36
37
38
39
import HscTypes
import ForeignCall
import TysWiredIn
import TysPrim
import PrelNames
import BasicTypes
import SrcLoc
sof's avatar
sof committed
40
import Outputable
41
import FastString
42
43
import DynFlags
import Platform
44
45
import Config
import Constants
46
import OrdList
47
import Pair
Simon Marlow's avatar
Simon Marlow committed
48
import Data.Maybe
49
import Data.List
sof's avatar
sof committed
50
51
52
\end{code}

Desugaring of @foreign@ declarations is naturally split up into
53
parts, an @import@ and an @export@  part. A @foreign import@
54
55
declaration
\begin{verbatim}
sof's avatar
sof committed
56
  foreign import cc nm f :: prim_args -> IO prim_res
57
\end{verbatim}
sof's avatar
sof committed
58
is the same as
59
\begin{verbatim}
sof's avatar
sof committed
60
61
  f :: prim_args -> IO prim_res
  f a1 ... an = _ccall_ nm cc a1 ... an
62
\end{verbatim}
sof's avatar
sof committed
63
64
65
so we reuse the desugaring code in @DsCCall@ to deal with these.

\begin{code}
66
67
type Binding = (Id, CoreExpr)   -- No rec/nonrec structure;
                                -- the occurrence analyser will sort it all out
68

69
70
71
dsForeigns :: [LForeignDecl Id]
           -> DsM (ForeignStubs, OrdList Binding)
dsForeigns []
72
  = return (NoStubs, nilOL)
73
dsForeigns fos = do
74
75
    fives <- mapM do_ldecl fos
    let
76
        (hs, cs, idss, bindss) = unzip4 fives
77
78
79
        fe_ids = concat idss
        fe_init_code = map foreignExportInitialiser fe_ids
    --
80
    return (ForeignStubs
81
             (vcat hs)
82
             (vcat cs $$ vcat fe_init_code),
83
            foldr (appOL . toOL) nilOL bindss)
84
85
  where
   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
94
   do_decl (ForeignExport (L _ id) _ co (CExport (CExportStatic ext_nm cconv))) = do
      (h, c, _, _) <- dsFExport id co ext_nm cconv False
95
      return (h, c, [id], [])
sof's avatar
sof committed
96
97
\end{code}

98
99

%************************************************************************
100
%*                                                                      *
101
\subsection{Foreign import}
102
%*                                                                      *
103
104
%************************************************************************

sof's avatar
sof committed
105
106
Desugaring foreign imports is just the matter of creating a binding
that on its RHS unboxes its arguments, performs the external call
107
(using the @CCallOp@ primop), before boxing the result up and returning it.
sof's avatar
sof committed
108

109
110
However, we create a worker/wrapper pair, thus:

111
        foreign import f :: Int -> IO Int
112
==>
113
114
115
        f x = IO ( \s -> case x of { I# x# ->
                         case fw s x# of { (# s1, y# #) ->
                         (# 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
122
because it exposes the boxing to the call site.

sof's avatar
sof committed
123
\begin{code}
124
dsFImport :: Id
125
          -> Coercion
126
127
          -> ForeignImport
          -> DsM ([Binding], SDoc, SDoc)
128
129
dsFImport id co (CImport cconv safety header spec) = do
    (ids, h, c) <- dsCImport id co spec cconv safety header
130
    return (ids, h, c)
131

132
dsCImport :: Id
133
          -> Coercion
134
135
136
          -> CImportSpec
          -> CCallConv
          -> 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 (dropForAlls ty) of
142
             Just tycon
143
144
145
              | tyConUnique tycon == funPtrTyConKey ->
                 IsFunction
             _ -> 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
152
        stdcall_info = fun_type_arg_stdcall_info cconv ty
    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
158
159
dsCImport id co (CFunction target) cconv safety header
  = dsFCall id co (CCall (CCallSpec target cconv safety)) header
dsCImport id co CWrapper cconv _ _
160
  = dsFExportDynamic id co cconv
161
162
163
164
165
166

-- For stdcall labels, if the type was a FunPtr or newtype thereof,
-- then we need to calculate the size of the arguments in order to add
-- the @n suffix to the label.
fun_type_arg_stdcall_info :: CCallConv -> Type -> Maybe Int
fun_type_arg_stdcall_info StdCallConv ty
167
  | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty,
168
169
    tyConUnique tc == funPtrTyConKey
  = let
Ian Lynagh's avatar
Ian Lynagh committed
170
171
       (_tvs,sans_foralls)        = tcSplitForAllTys arg_ty
       (fe_arg_tys, _orig_res_ty) = tcSplitFunTys sans_foralls
172
    in Just $ sum (map (widthInBytes . typeWidth . typeCmmType . getPrimTyOf) fe_arg_tys)
173
174
fun_type_arg_stdcall_info _other_conv _
  = Nothing
175
176
177
178
\end{code}


%************************************************************************
179
%*                                                                      *
180
\subsection{Foreign calls}
181
%*                                                                      *
182
183
184
%************************************************************************

\begin{code}
185
186
187
dsFCall :: Id -> Coercion -> ForeignCall -> FastString
        -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
dsFCall fn_id co fcall headerFilename = do
188
    let
189
        ty                   = pFst $ coercionKind co
190
191
192
193
194
195
196
        (tvs, fun_ty)        = tcSplitForAllTys ty
        (arg_tys, io_res_ty) = tcSplitFunTys fun_ty
                -- Must use tcSplit* functions because we want to
                -- see that (IO t) in the corner

    args <- newSysLocalsDs arg_tys
    (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
204

    ccall_uniq <- newUnique
    work_uniq  <- newUnique
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242

    (fcall', cDoc) <-
              case fcall of
              CCall (CCallSpec (StaticTarget cName mPackageId) CApiConv safety) ->
               do fcall_uniq <- newUnique
                  let wrapperName = mkFastString "ghc_wrapper_" `appendFS`
                                    mkFastString (showSDoc (ppr fcall_uniq)) `appendFS`
                                    mkFastString "_" `appendFS`
                                    cName
                      fcall' = CCall (CCallSpec (StaticTarget wrapperName mPackageId) CApiConv safety)
                      c = include
                       $$ fun_proto <+> braces (cRet <> semi)
                      include
                       | nullFS headerFilename = empty
                       | otherwise = text "#include <" <> ftext headerFilename <> text ">"
                      fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes
                      cRet
                       | isVoidRes =                   cCall
                       | otherwise = text "return" <+> cCall
                      cCall = ppr cName <> parens argVals
                      raw_res_ty = case tcSplitIOType_maybe io_res_ty of
                                   Just (_ioTyCon, res_ty) -> res_ty
                                   Nothing                 -> io_res_ty
                      isVoidRes = raw_res_ty `eqType` unitTy
                      cResType | isVoidRes = text "void"
                               | otherwise = showStgType raw_res_ty
                      pprCconv = ccallConvAttribute CApiConv
                      argTypes
                       | null arg_tys = text "void"
                       | otherwise = hsep $ punctuate comma
                                         [ showStgType t <+> char 'a' <> int n
                                         | (t, n) <- zip arg_tys [1..] ]
                      argVals = hsep $ punctuate comma
                                    [ char 'a' <> int n
                                    | (_, n) <- zip arg_tys [1..] ]
                  return (fcall', c)
              _ ->
                  return (fcall, empty)
sof's avatar
sof committed
243
    let
244
245
        -- Build the worker
        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)
Ian Lynagh's avatar
Ian Lynagh committed
248
        work_id       = mkSysLocal (fsLit "$wccall") work_uniq worker_ty
249
250
251
252

        -- Build the wrapper
        work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
        wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
253
        wrap_rhs     = mkLams (tvs ++ args) wrapper_body
254
255
        wrap_rhs'    = Cast wrap_rhs co
        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
259
\end{code}

sof's avatar
sof committed
260

261
%************************************************************************
262
%*                                                                      *
263
\subsection{Primitive calls}
264
%*                                                                      *
265
266
267
268
269
270
271
272
273
274
%************************************************************************

This is for `@foreign import prim@' declarations.

Currently, at the core level we pretend that these primitive calls are
foreign calls. It may make more sense in future to have them as a distinct
kind of Id, or perhaps to bundle them with PrimOps since semantically and
for calling convention they are really prim ops.

\begin{code}
275
276
277
dsPrimCall :: Id -> Coercion -> ForeignCall
           -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
dsPrimCall fn_id co fcall = do
278
    let
279
        ty                   = pFst $ coercionKind co
280
281
282
283
284
285
286
287
288
289
290
        (tvs, fun_ty)        = tcSplitForAllTys ty
        (arg_tys, io_res_ty) = tcSplitFunTys fun_ty
                -- Must use tcSplit* functions because we want to
                -- see that (IO t) in the corner

    args <- newSysLocalsDs arg_tys

    ccall_uniq <- newUnique
    let
        call_app = mkFCall ccall_uniq fcall (map Var args) io_res_ty
        rhs      = mkLams tvs (mkLams args call_app)
291
292
        rhs'     = Cast rhs co
    return ([(fn_id, rhs')], empty, empty)
293
294
295

\end{code}

296
%************************************************************************
297
%*                                                                      *
298
\subsection{Foreign export}
299
%*                                                                      *
300
%************************************************************************
sof's avatar
sof committed
301

302
303
The function that does most of the work for `@foreign export@' declarations.
(see below for the boilerplate code a `@foreign export@' declaration expands
304
 into.)
sof's avatar
sof committed
305

306
307
308
For each `@foreign export foo@' in a module M we generate:
\begin{itemize}
\item a C function `@foo@', which calls
309
\item a Haskell stub `@M.\$ffoo@', which calls
310
311
\end{itemize}
the user-written Haskell function `@M.foo@'.
312

sof's avatar
sof committed
313
\begin{code}
314
315
dsFExport :: Id                 -- Either the exported Id,
                                -- or the foreign-export-dynamic constructor
316
317
          -> Coercion           -- Coercion between the Haskell type callable
                                -- from C, and its representation type
318
319
320
321
322
323
324
325
326
327
          -> CLabelString       -- The name to export to C land
          -> CCallConv
          -> Bool               -- True => foreign export dynamic
                                --         so invoke IO action that's hanging off
                                --         the first argument's stable pointer
          -> DsM ( SDoc         -- contents of Module_stub.h
                 , SDoc         -- contents of Module_stub.c
                 , String       -- string describing type to pass to createAdj.
                 , Int          -- size of args to stub function
                 )
328

329
dsFExport fn_id co ext_name cconv isDyn = do
330
    let
331
       ty                              = pSnd $ coercionKind co
332
333
       (_tvs,sans_foralls)             = tcSplitForAllTys ty
       (fe_arg_tys', orig_res_ty)      = tcSplitFunTys sans_foralls
334
       -- We must use tcSplits here, because we want to see
335
336
337
       -- the (IO t) in the corner of the type!
       fe_arg_tys | isDyn     = tail fe_arg_tys'
                  | otherwise = fe_arg_tys'
338

339
340
341
       -- Look at the result type of the exported function, orig_res_ty
       -- If it's IO t, return         (t, True)
       -- If it's plain t, return      (t, False)
342
343
344
345
346
       (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of
                                -- The function already returns IO t
                                Just (_ioTyCon, res_ty) -> (res_ty, True)
                                -- The function returns t
                                Nothing                 -> (orig_res_ty, False)
347

348
    dflags <- getDOpts
349
    return $
350
      mkFExportCBits dflags ext_name
351
352
                     (if isDyn then Nothing else Just fn_id)
                     fe_arg_tys res_ty is_IO_res_ty cconv
sof's avatar
sof committed
353
354
\end{code}

355
356
357
358
@foreign import "wrapper"@ (previously "foreign export dynamic") lets
you dress up Haskell IO actions of some fixed type behind an
externally callable interface (i.e., as a C function pointer). Useful
for callbacks and stuff.
sof's avatar
sof committed
359
360

\begin{verbatim}
361
362
type Fun = Bool -> Int -> IO Int
foreign import "wrapper" f :: Fun -> IO (FunPtr Fun)
sof's avatar
sof committed
363

364
365
-- Haskell-visible constructor, which is generated from the above:
-- SUP: No check for NULL from createAdjustor anymore???
sof's avatar
sof committed
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# #)))
sof's avatar
sof committed
373

374
375
376
377
378
379
foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun)

-- and the helper in C:

f_helper(StablePtr s, HsBool b, HsInt i)
{
380
381
        rts_evalIO(rts_apply(rts_apply(deRefStablePtr(s),
                                       rts_mkBool(b)), rts_mkInt(i)));
382
}
sof's avatar
sof committed
383
384
385
\end{verbatim}

\begin{code}
386
dsFExportDynamic :: Id
387
                 -> Coercion
388
389
                 -> CCallConv
                 -> DsM ([Binding], SDoc, SDoc)
390
dsFExportDynamic id co0 cconv = do
391
392
393
    fe_id <-  newSysLocalDs ty
    mod <- getModuleDs
    let
sof's avatar
sof committed
394
        -- hack: need to get at the name of the C stub we're about to generate.
395
396
397
398
399
400
401
402
403
404
        fe_nm    = mkFastString (unpackFS (zEncodeFS (moduleNameFS (moduleName mod))) ++ "_" ++ toCName fe_id)

    cback <- newSysLocalDs arg_ty
    newStablePtrId <- dsLookupGlobalId newStablePtrName
    stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName
    let
        stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]
        export_ty     = mkFunTy stable_ptr_ty arg_ty
    bindIOId <- dsLookupGlobalId bindIOName
    stbl_value <- newSysLocalDs stable_ptr_ty
405
    (h_code, c_code, typestring, args_size) <- dsFExport id (Refl export_ty) fe_nm cconv True
406
407
408
409
410
411
412
413
414
415
    let
         {-
          The arguments to the external function which will
          create a little bit of (template) code on the fly
          for allowing the (stable pointed) Haskell closure
          to be entered using an external calling convention
          (stdcall, ccall).
         -}
        adj_args      = [ mkIntLitInt (ccallConvToInt cconv)
                        , 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.)
Ian Lynagh's avatar
Ian Lynagh committed
421
        adjustor   = fsLit "createAdjustor"
422

423
424
425
426
427
428
429
430
431
432
          -- Determine the number of bytes of arguments to the stub function,
          -- so that we can attach the '@N' suffix to its label if it is a
          -- stdcall on Windows.
        mb_sz_args = case cconv of
                        StdCallConv -> Just args_size
                        _           -> Nothing

    ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])
        -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback

433
434
    let io_app = mkLams tvs                  $
                 Lam cback                   $
435
436
                 mkApps (Var bindIOId)
                        [ Type stable_ptr_ty
437
                        , Type res_ty
438
439
440
441
                        , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
                        , Lam stbl_value ccall_adj
                        ]

442
        fed = (id `setInlineActivation` NeverActive, Cast io_app co0)
443
444
445
446
               -- Never inline the f.e.d. function, because the litlit
               -- might not be in scope in other modules.

    return ([fed], h_code, c_code)
447

sof's avatar
sof committed
448
 where
449
  ty                       = pFst (coercionKind co0)
450
451
  (tvs,sans_foralls)       = tcSplitForAllTys ty
  ([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
sof's avatar
sof committed
454
455
456
457
458
459
460
461
462
463
464

toCName :: Id -> String
toCName i = showSDoc (pprCode CStyle (ppr (idName i)))
\end{code}

%*
%
\subsection{Generating @foreign export@ stubs}
%
%*

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.
sof's avatar
sof committed
468
469

\begin{code}
470
471
mkFExportCBits :: DynFlags
               -> FastString
472
473
474
475
476
477
478
479
480
481
482
               -> Maybe Id      -- Just==static, Nothing==dynamic
               -> [Type]
               -> Type
               -> Bool          -- True <=> returns an IO type
               -> CCallConv
               -> (SDoc,
                   SDoc,
                   String,      -- the argument reps
                   Int          -- total size of arguments
                  )
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
486
487
488
489
490
491
         -- NB. the calculation here isn't strictly speaking correct.
         -- We have a primitive Haskell type (eg. Int#, Double#), and
         -- we want to know the size, when passed on the C stack, of
         -- the associated C type (eg. HsInt, HsDouble).  We don't have
         -- this information to hand, but we know what GHC's conventions
         -- are for passing around the primitive Haskell types, so we
         -- use that instead.  I hope the two coincide --SDM
492
    )
sof's avatar
sof committed
493
 where
494
  -- list the arguments to the C function
495
496
497
498
  arg_info :: [(SDoc,           -- arg name
                SDoc,           -- C type
                Type,           -- Haskell type
                CmmType)]       -- the CmmType
499
500
501
  arg_info  = [ let stg_type = showStgType ty in
                (arg_cname n stg_type,
                 stg_type,
502
503
504
                 ty,
                 typeCmmType (getPrimTyOf ty))
              | (ty,n) <- zip arg_htys [1::Int ..] ]
505

506
  arg_cname n stg_ty
507
        | libffi    = char '*' <> parens (stg_ty <> char '*') <>
Ian Lynagh's avatar
Ian Lynagh committed
508
                      ptext (sLit "args") <> brackets (int (n-1))
509
510
511
512
513
514
515
516
517
518
519
520
521
        | otherwise = text ('a':show n)

  -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled
  libffi = cLibFFI && isNothing maybe_target

  type_string
      -- libffi needs to know the result type too:
      | libffi    = primTyDescChar res_hty : arg_type_string
      | otherwise = arg_type_string

  arg_type_string = [primTyDescChar ty | (_,_,ty,_) <- arg_info]
                -- just the real args

522
523
524
  -- add some auxiliary args; the stable ptr in the wrapper case, and
  -- a slot for the dummy return address in the wrapper + ccall case
  aug_arg_info
525
    | isNothing maybe_target = stable_ptr_arg : insertRetAddr dflags cc arg_info
526
527
    | otherwise              = arg_info

528
529
530
  stable_ptr_arg =
        (text "the_stableptr", text "StgStablePtr", undefined,
         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
539
540
541
542
543
544
545
546
547
548
549
550
  -- when the return type is integral and word-sized or smaller, it
  -- must be assigned as type ffi_arg (#3516).  To see what type
  -- libffi is expecting here, take a look in its own testsuite, e.g.
  -- libffi/testsuite/libffi.call/cls_align_ulonglong.c
  ffi_cResType
     | is_ffi_arg_type = text "ffi_arg"
     | otherwise       = cResType
     where
       res_ty_key = getUnique (getName (typeTyCon res_hty))
       is_ffi_arg_type = res_ty_key `notElem`
              [floatTyConKey, doubleTyConKey,
               int64TyConKey, word64TyConKey]

551
  -- Now we can cook up the prototype for the exported function.
Ian Lynagh's avatar
Ian Lynagh committed
552
  pprCconv = ccallConvAttribute cc
553

Ian Lynagh's avatar
Ian Lynagh committed
554
  header_bits = ptext (sLit "extern") <+> fun_proto <> semi
sof's avatar
sof committed
555

556
557
558
559
560
  fun_args
    | null aug_arg_info = text "void"
    | otherwise         = hsep $ punctuate comma
                               $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info

561
562
  fun_proto
    | libffi
563
      = ptext (sLit "void") <+> ftext c_nm <>
Ian Lynagh's avatar
Ian Lynagh committed
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
569
570
571

  -- the target which will form the root of what we ask rts_evalIO to run
  the_cfun
     = case maybe_target of
          Nothing    -> text "(StgClosure*)deRefStablePtr(the_stableptr)"
572
          Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"
573

574
575
  cap = text "cap" <> comma

576
577
  -- the expression we give to rts_evalIO
  expr_to_run
578
     = foldl appArg the_cfun arg_info -- NOT aug_arg_info
579
       where
580
581
          appArg acc (arg_cname, _, arg_hty, _)
             = text "rts_apply"
582
               <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname))
583
584
585

  -- various other bits for inside the fn
  declareResult = text "HaskellObj ret;"
586
587
  declareCResult | res_hty_is_unit = empty
                 | otherwise       = cResType <+> text "cret;"
588

589
  assignCResult | res_hty_is_unit = empty
590
591
                | otherwise       =
                        text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi
592
593
594
595
596

  -- an extern decl for the fn being called
  extern_decl
     = case maybe_target of
          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
Ian Lynagh's avatar
Ian Lynagh committed
607
     ,   ptext (sLit "Capability *cap;")
608
     ,   declareResult
609
     ,   declareCResult
610
     ,   text "cap = rts_lock();"
611
          -- create the application + perform it.
612
613
     ,   ptext (sLit "rts_evalIO") <> parens (
                char '&' <> cap <>
614
615
616
617
618
619
620
621
622
623
624
                ptext (sLit "rts_apply") <> parens (
                    cap <>
                    text "(HaskellObj)"
                 <> ptext (if is_IO_res_ty
                                then (sLit "runIO_closure")
                                else (sLit "runNonIO_closure"))
                 <> comma
                 <> expr_to_run
                ) <+> comma
               <> text "&ret"
             ) <> semi
Ian Lynagh's avatar
Ian Lynagh committed
625
     ,   ptext (sLit "rts_checkSchedStatus") <> parens (doubleQuotes (ftext c_nm)
626
                                                <> comma <> text "cap") <> semi
627
     ,   assignCResult
Ian Lynagh's avatar
Ian Lynagh committed
628
     ,   ptext (sLit "rts_unlock(cap);")
629
     ,   ppUnless res_hty_is_unit $
630
         if libffi
631
                  then char '*' <> parens (ffi_cResType <> char '*') <>
Ian Lynagh's avatar
Ian Lynagh committed
632
633
                       ptext (sLit "resp = cret;")
                  else ptext (sLit "return cret;")
634
     , rbrace
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
     ]


foreignExportInitialiser :: Id -> SDoc
foreignExportInitialiser hs_fn =
   -- Initialise foreign exports by registering a stable pointer from an
   -- __attribute__((constructor)) function.
   -- The alternative is to do this from stginit functions generated in
   -- codeGen/CodeGen.lhs; however, stginit functions have a negative impact
   -- on binary sizes and link times because the static linker will think that
   -- all modules that are imported directly or indirectly are actually used by
   -- the program.
   -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)
   vcat
    [ text "static void stginit_export_" <> ppr hs_fn
         <> text "() __attribute__((constructor));"
    , text "static void stginit_export_" <> ppr hs_fn <> text "()"
    , braces (text "getStablePtr"
       <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure")
       <> semi)
    ]

sof's avatar
sof committed
657

658
mkHObj :: Type -> SDoc
sof's avatar
sof committed
659
mkHObj t = text "rts_mk" <> text (showFFIType t)
sof's avatar
sof committed
660

661
unpackHObj :: Type -> SDoc
sof's avatar
sof committed
662
unpackHObj t = text "rts_get" <> text (showFFIType t)
663
664

showStgType :: Type -> SDoc
665
showStgType t = text "Hs" <> text (showFFIType t)
sof's avatar
sof committed
666

sof's avatar
sof committed
667
showFFIType :: Type -> String
668
669
670
671
672
showFFIType t = getOccString (getName (typeTyCon t))

typeTyCon :: Type -> TyCon
typeTyCon ty = case tcSplitTyConApp_maybe (repType ty) of
                 Just (tc,_) -> tc
673
                 Nothing     -> pprPanic "DsForeign.typeTyCon" (ppr ty)
674

675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
insertRetAddr :: DynFlags -> CCallConv
              -> [(SDoc, SDoc, Type, CmmType)]
              -> [(SDoc, SDoc, Type, CmmType)]
insertRetAddr dflags CCallConv args
    = case platformArch (targetPlatform dflags) of
      ArchX86_64 ->
          -- On x86_64 we insert the return address after the 6th
          -- integer argument, because this is the point at which we
          -- need to flush a register argument to the stack (See
          -- rts/Adjustor.c for details).
          let go :: Int -> [(SDoc, SDoc, Type, CmmType)]
                        -> [(SDoc, SDoc, Type, CmmType)]
              go 6 args = ret_addr_arg : args
              go n (arg@(_,_,_,rep):args)
               | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args
               | otherwise  = arg : go n     args
              go _ [] = []
          in go 0 args
      _ ->
          ret_addr_arg : args
insertRetAddr _ _ args = args
696

697
ret_addr_arg :: (SDoc, SDoc, Type, CmmType)
698
699
ret_addr_arg = (text "original_return_addr", text "void*", undefined,
                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
705
706
707
708
709
getPrimTyOf ty
  | isBoolTy rep_ty = intPrimTy
  -- Except for Bool, the types we are interested in have a single constructor
  -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).
  | otherwise =
  case splitProductType_maybe rep_ty of
710
     Just (_, _, data_con, [prim_ty]) ->
711
712
713
        ASSERT(dataConSourceArity data_con == 1)
        ASSERT2(isUnLiftedType prim_ty, ppr prim_ty)
        prim_ty
714
     _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)
715
  where
716
        rep_ty = repType ty
717
718
719
720
721
722

-- represent a primitive type as a Char, for building a string that
-- described the foreign function type.  The types are size-dependent,
-- e.g. 'W' is a signed 32-bit integer.
primTyDescChar :: Type -> Char
primTyDescChar ty
723
 | ty `eqType` unitTy = 'v'
724
725
 | otherwise
 = case typePrimRep (getPrimTyOf ty) of
726
     IntRep      -> signed_word
727
728
729
     WordRep     -> unsigned_word
     Int64Rep    -> 'L'
     Word64Rep   -> 'l'
730
     AddrRep     -> 'p'
731
732
733
734
735
736
737
738
     FloatRep    -> 'f'
     DoubleRep   -> 'd'
     _           -> pprPanic "primTyDescChar" (ppr ty)
  where
    (signed_word, unsigned_word)
       | wORD_SIZE == 4  = ('W','w')
       | wORD_SIZE == 8  = ('L','l')
       | otherwise       = panic "primTyDescChar"
739
\end{code}