DsForeign.hs 30.8 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1
2
3
4
{-
(c) The University of Glasgow 2006
(c) The AQUA Project, Glasgow University, 1998

sof's avatar
sof committed
5

Simon Marlow's avatar
Simon Marlow committed
6
Desugaring foreign declarations (see also DsCCall).
Austin Seipp's avatar
Austin Seipp committed
7
-}
sof's avatar
sof committed
8

9
{-# LANGUAGE CPP #-}
10
11
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
12

13
module DsForeign ( dsForeigns ) where
sof's avatar
sof committed
14
15

#include "HsVersions.h"
16
17
import GhcPrelude

18
import TcRnMonad        -- temp
sof's avatar
sof committed
19
20
21

import CoreSyn

Simon Marlow's avatar
Simon Marlow committed
22
import DsCCall
sof's avatar
sof committed
23
24
import DsMonad

Simon Marlow's avatar
Simon Marlow committed
25
26
import HsSyn
import DataCon
27
import CoreUnfold
Simon Marlow's avatar
Simon Marlow committed
28
29
30
31
32
import Id
import Literal
import Module
import Name
import Type
33
import RepType
34
import TyCon
Simon Marlow's avatar
Simon Marlow committed
35
import Coercion
36
import TcEnv
Simon Marlow's avatar
Simon Marlow committed
37
import TcType
38

39
40
import CmmExpr
import CmmUtils
Simon Marlow's avatar
Simon Marlow committed
41
42
43
44
45
46
47
import HscTypes
import ForeignCall
import TysWiredIn
import TysPrim
import PrelNames
import BasicTypes
import SrcLoc
sof's avatar
sof committed
48
import Outputable
49
import FastString
50
51
import DynFlags
import Platform
52
import Config
53
import OrdList
54
import Pair
55
import Util
56
import Hooks
57
import Encoding
58

Simon Marlow's avatar
Simon Marlow committed
59
import Data.Maybe
60
import Data.List
sof's avatar
sof committed
61

Austin Seipp's avatar
Austin Seipp committed
62
{-
sof's avatar
sof committed
63
Desugaring of @foreign@ declarations is naturally split up into
64
parts, an @import@ and an @export@  part. A @foreign import@
65
66
declaration
\begin{verbatim}
sof's avatar
sof committed
67
  foreign import cc nm f :: prim_args -> IO prim_res
68
\end{verbatim}
sof's avatar
sof committed
69
is the same as
70
\begin{verbatim}
sof's avatar
sof committed
71
72
  f :: prim_args -> IO prim_res
  f a1 ... an = _ccall_ nm cc a1 ... an
73
\end{verbatim}
sof's avatar
sof committed
74
so we reuse the desugaring code in @DsCCall@ to deal with these.
Austin Seipp's avatar
Austin Seipp committed
75
-}
sof's avatar
sof committed
76

77
78
type Binding = (Id, CoreExpr) -- No rec/nonrec structure;
                              -- the occurrence analyser will sort it all out
79

80
dsForeigns :: [LForeignDecl GhcTc]
81
           -> DsM (ForeignStubs, OrdList Binding)
82
83
dsForeigns fos = getHooked dsForeignsHook dsForeigns' >>= ($ fos)

84
dsForeigns' :: [LForeignDecl GhcTc]
85
86
            -> DsM (ForeignStubs, OrdList Binding)
dsForeigns' []
87
  = return (NoStubs, nilOL)
88
dsForeigns' fos = do
89
90
    fives <- mapM do_ldecl fos
    let
91
        (hs, cs, idss, bindss) = unzip4 fives
92
93
94
        fe_ids = concat idss
        fe_init_code = map foreignExportInitialiser fe_ids
    --
95
    return (ForeignStubs
96
             (vcat hs)
97
             (vcat cs $$ vcat fe_init_code),
98
            foldr (appOL . toOL) nilOL bindss)
99
100
  where
   do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl)
101

102
   do_decl (ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec }) = do
103
      traceIf (text "fi start" <+> ppr id)
104
105
      let id' = unLoc id
      (bs, h, c) <- dsFImport id' co spec
106
      traceIf (text "fi end" <+> ppr id)
107
      return (h, c, [], bs)
108

109
   do_decl (ForeignExport { fd_name = L _ id, fd_e_ext = co
110
                          , fd_fe = CExport (L _ (CExportStatic _ ext_nm cconv)) _ }) = do
111
      (h, c, _, _) <- dsFExport id co ext_nm cconv False
112
      return (h, c, [id], [])
113
   do_decl (XForeignDecl _) = panic "dsForeigns'"
114

Austin Seipp's avatar
Austin Seipp committed
115
116
117
{-
************************************************************************
*                                                                      *
118
\subsection{Foreign import}
Austin Seipp's avatar
Austin Seipp committed
119
120
*                                                                      *
************************************************************************
121

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

126
127
However, we create a worker/wrapper pair, thus:

128
        foreign import f :: Int -> IO Int
129
==>
130
131
132
        f x = IO ( \s -> case x of { I# x# ->
                         case fw s x# of { (# s1, y# #) ->
                         (# 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.
Austin Seipp's avatar
Austin Seipp committed
139
-}
140

141
dsFImport :: Id
142
          -> Coercion
143
144
          -> ForeignImport
          -> DsM ([Binding], SDoc, SDoc)
145
146
dsFImport id co (CImport cconv safety mHeader spec _) =
    dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader
147

148
dsCImport :: Id
149
          -> Coercion
150
151
152
          -> CImportSpec
          -> CCallConv
          -> Safety
153
          -> Maybe Header
154
          -> DsM ([Binding], SDoc, SDoc)
155
dsCImport id co (CLabel cid) cconv _ _ = do
156
   dflags <- getDynFlags
157
   let ty  = pFst $ coercionKind co
158
       fod = case tyConAppTyCon_maybe (dropForAlls ty) of
159
             Just tycon
160
161
162
              | tyConUnique tycon == funPtrTyConKey ->
                 IsFunction
             _ -> IsData
163
   (resTy, foRhs) <- resultWrapper ty
164
   ASSERT(fromJust resTy `eqType` addrPrimTy)    -- typechecker ensures this
165
    let
Sylvain Henry's avatar
Sylvain Henry committed
166
        rhs = foRhs (Lit (LitLabel cid stdcall_info fod))
167
        rhs' = Cast rhs co
168
        stdcall_info = fun_type_arg_stdcall_info dflags cconv ty
169
    in
170
    return ([(id, rhs')], empty, empty)
171

172
dsCImport id co (CFunction target) cconv@PrimCallConv safety _
173
  = dsPrimCall id co (CCall (CCallSpec target cconv safety))
174
175
dsCImport id co (CFunction target) cconv safety mHeader
  = dsFCall id co (CCall (CCallSpec target cconv safety)) mHeader
176
dsCImport id co CWrapper cconv _ _
177
  = dsFExportDynamic id co cconv
178
179
180
181

-- 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.
182
183
fun_type_arg_stdcall_info :: DynFlags -> CCallConv -> Type -> Maybe Int
fun_type_arg_stdcall_info dflags StdCallConv ty
184
  | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty,
185
186
    tyConUnique tc == funPtrTyConKey
  = let
187
188
       (bndrs, _) = tcSplitPiTys arg_ty
       fe_arg_tys = mapMaybe binderRelevantType_maybe bndrs
189
190
    in Just $ sum (map (widthInBytes . typeWidth . typeCmmType dflags . getPrimTyOf) fe_arg_tys)
fun_type_arg_stdcall_info _ _other_conv _
191
  = Nothing
192

Austin Seipp's avatar
Austin Seipp committed
193
194
195
{-
************************************************************************
*                                                                      *
196
\subsection{Foreign calls}
Austin Seipp's avatar
Austin Seipp committed
197
198
199
*                                                                      *
************************************************************************
-}
200

201
dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header
202
        -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
203
dsFCall fn_id co fcall mDeclHeader = do
204
    let
Simon Peyton Jones's avatar
Simon Peyton Jones committed
205
        ty                   = pFst $ coercionKind co
Ningning Xie's avatar
Ningning Xie committed
206
        (tv_bndrs, rho)      = tcSplitForAllVarBndrs ty
Simon Peyton Jones's avatar
Simon Peyton Jones committed
207
        (arg_tys, io_res_ty) = tcSplitFunTys rho
208

Richard Eisenberg's avatar
Richard Eisenberg committed
209
    args <- newSysLocalsDs arg_tys  -- no FFI levity-polymorphism
210
    (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args)
211

212
    let
213
        work_arg_ids  = [v | Var v <- val_args] -- All guaranteed to be vars
214

215
    (ccall_result_ty, res_wrapper) <- boxResult io_res_ty
216
217
218

    ccall_uniq <- newUnique
    work_uniq  <- newUnique
219

Ian Lynagh's avatar
Ian Lynagh committed
220
    dflags <- getDynFlags
221
222
    (fcall', cDoc) <-
              case fcall of
223
              CCall (CCallSpec (StaticTarget _ cName mUnitId isFun)
224
                               CApiConv safety) ->
225
               do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName)
226
                  let fcall' = CCall (CCallSpec
Alan Zimmerman's avatar
Alan Zimmerman committed
227
                                      (StaticTarget NoSourceText
228
                                                    wrapperName mUnitId
229
230
                                                    True)
                                      CApiConv safety)
231
                      c = includes
232
                       $$ fun_proto <+> braces (cRet <> semi)
233
234
                      includes = vcat [ text "#include \"" <> ftext h
                                        <> text "\""
235
                                      | Header _ h <- nub headers ]
236
237
238
239
                      fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes
                      cRet
                       | isVoidRes =                   cCall
                       | otherwise = text "return" <+> cCall
240
241
242
243
244
                      cCall = if isFun
                              then ppr cName <> parens argVals
                              else if null arg_tys
                                    then ppr cName
                                    else panic "dsFCall: Unexpected arguments to FFI value import"
245
246
247
248
                      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
249
250
251
                      (mHeader, cResType)
                       | isVoidRes = (Nothing, text "void")
                       | otherwise = toCType raw_res_ty
252
                      pprCconv = ccallConvAttribute CApiConv
253
254
255
256
257
258
259
260
                      mHeadersArgTypeList
                          = [ (header, cType <+> char 'a' <> int n)
                            | (t, n) <- zip arg_tys [1..]
                            , let (header, cType) = toCType t ]
                      (mHeaders, argTypeList) = unzip mHeadersArgTypeList
                      argTypes = if null argTypeList
                                 then text "void"
                                 else hsep $ punctuate comma argTypeList
261
262
                      mHeaders' = mDeclHeader : mHeader : mHeaders
                      headers = catMaybes mHeaders'
263
264
265
266
267
268
                      argVals = hsep $ punctuate comma
                                    [ char 'a' <> int n
                                    | (_, n) <- zip arg_tys [1..] ]
                  return (fcall', c)
              _ ->
                  return (fcall, empty)
sof's avatar
sof committed
269
    let
270
        -- Build the worker
Simon Peyton Jones's avatar
Simon Peyton Jones committed
271
272
        worker_ty     = mkForAllTys tv_bndrs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
        tvs           = map binderVar tv_bndrs
Ian Lynagh's avatar
Ian Lynagh committed
273
        the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty
274
        work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)
Ian Lynagh's avatar
Ian Lynagh committed
275
        work_id       = mkSysLocal (fsLit "$wccall") work_uniq worker_ty
276
277
278
279

        -- Build the wrapper
        work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
        wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
280
        wrap_rhs     = mkLams (tvs ++ args) wrapper_body
281
        wrap_rhs'    = Cast wrap_rhs co
282
283
        fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineUnfoldingWithArity
                                                (length args) wrap_rhs'
284

285
    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, cDoc)
sof's avatar
sof committed
286

Austin Seipp's avatar
Austin Seipp committed
287
288
289
{-
************************************************************************
*                                                                      *
290
\subsection{Primitive calls}
Austin Seipp's avatar
Austin Seipp committed
291
292
*                                                                      *
************************************************************************
293
294
295
296
297
298
299

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.
Austin Seipp's avatar
Austin Seipp committed
300
-}
301

302
303
304
dsPrimCall :: Id -> Coercion -> ForeignCall
           -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
dsPrimCall fn_id co fcall = do
305
    let
306
        ty                   = pFst $ coercionKind co
Simon Peyton Jones's avatar
Simon Peyton Jones committed
307
308
        (tvs, fun_ty)        = tcSplitForAllTys ty
        (arg_tys, io_res_ty) = tcSplitFunTys fun_ty
309

Richard Eisenberg's avatar
Richard Eisenberg committed
310
    args <- newSysLocalsDs arg_tys  -- no FFI levity-polymorphism
311
312

    ccall_uniq <- newUnique
Ian Lynagh's avatar
Ian Lynagh committed
313
    dflags <- getDynFlags
314
    let
Ian Lynagh's avatar
Ian Lynagh committed
315
        call_app = mkFCall dflags ccall_uniq fcall (map Var args) io_res_ty
316
        rhs      = mkLams tvs (mkLams args call_app)
317
318
        rhs'     = Cast rhs co
    return ([(fn_id, rhs')], empty, empty)
319

Austin Seipp's avatar
Austin Seipp committed
320
321
322
{-
************************************************************************
*                                                                      *
323
\subsection{Foreign export}
Austin Seipp's avatar
Austin Seipp committed
324
325
*                                                                      *
************************************************************************
sof's avatar
sof committed
326

327
328
The function that does most of the work for `@foreign export@' declarations.
(see below for the boilerplate code a `@foreign export@' declaration expands
329
 into.)
sof's avatar
sof committed
330

331
332
333
For each `@foreign export foo@' in a module M we generate:
\begin{itemize}
\item a C function `@foo@', which calls
334
\item a Haskell stub `@M.\$ffoo@', which calls
335
336
\end{itemize}
the user-written Haskell function `@M.foo@'.
Austin Seipp's avatar
Austin Seipp committed
337
-}
338

339
340
dsFExport :: Id                 -- Either the exported Id,
                                -- or the foreign-export-dynamic constructor
341
342
          -> Coercion           -- Coercion between the Haskell type callable
                                -- from C, and its representation type
343
344
345
346
347
348
349
350
351
352
          -> 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
                 )
353

354
dsFExport fn_id co ext_name cconv isDyn = do
355
    let
356
357
358
       ty                     = pSnd $ coercionKind co
       (bndrs, orig_res_ty)   = tcSplitPiTys ty
       fe_arg_tys'            = mapMaybe binderRelevantType_maybe bndrs
359
       -- We must use tcSplits here, because we want to see
360
361
362
       -- the (IO t) in the corner of the type!
       fe_arg_tys | isDyn     = tail fe_arg_tys'
                  | otherwise = fe_arg_tys'
363

364
365
366
       -- 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)
367
368
369
370
371
       (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)
372

373
    dflags <- getDynFlags
374
    return $
375
      mkFExportCBits dflags ext_name
376
377
                     (if isDyn then Nothing else Just fn_id)
                     fe_arg_tys res_ty is_IO_res_ty cconv
sof's avatar
sof committed
378

Austin Seipp's avatar
Austin Seipp committed
379
{-
380
381
382
383
@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
384
385

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

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

399
400
foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun)

401
-- and the helper in C: (approximately; see `mkFExportCBits` below)
402
403
404

f_helper(StablePtr s, HsBool b, HsInt i)
{
405
406
407
408
        Capability *cap;
        cap = rts_lock();
        rts_evalIO(&cap,
                   rts_apply(rts_apply(deRefStablePtr(s),
409
                                       rts_mkBool(b)), rts_mkInt(i)));
410
        rts_unlock(cap);
411
}
sof's avatar
sof committed
412
\end{verbatim}
Austin Seipp's avatar
Austin Seipp committed
413
-}
sof's avatar
sof committed
414

415
dsFExportDynamic :: Id
416
                 -> Coercion
417
418
                 -> CCallConv
                 -> DsM ([Binding], SDoc, SDoc)
419
dsFExportDynamic id co0 cconv = do
420
    mod <- getModule
Ian Lynagh's avatar
Ian Lynagh committed
421
    dflags <- getDynFlags
422
423
424
425
    let fe_nm = mkFastString $ zEncodeString
            (moduleStableString mod ++ "$" ++ toCName dflags id)
        -- Construct the label based on the passed id, don't use names
        -- depending on Unique. See #13807 and Note [Unique Determinism].
426
427
428
429
430
431
432
433
    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
434
    (h_code, c_code, typestring, args_size) <- dsFExport id (mkRepReflCo export_ty) fe_nm cconv True
435
436
437
438
439
440
441
442
    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).
         -}
443
        adj_args      = [ mkIntLitInt dflags (ccallConvToInt cconv)
444
                        , Var stbl_value
Sylvain Henry's avatar
Sylvain Henry committed
445
446
                        , Lit (LitLabel fe_nm mb_sz_args IsFunction)
                        , Lit (mkLitString typestring)
447
448
                        ]
          -- name of external entry point providing these services.
449
          -- (probably in the RTS.)
Ian Lynagh's avatar
Ian Lynagh committed
450
        adjustor   = fsLit "createAdjustor"
451

452
453
454
455
456
457
458
459
460
461
          -- 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

462
463
    let io_app = mkLams tvs                  $
                 Lam cback                   $
464
465
                 mkApps (Var bindIOId)
                        [ Type stable_ptr_ty
466
                        , Type res_ty
467
468
469
470
                        , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
                        , Lam stbl_value ccall_adj
                        ]

471
        fed = (id `setInlineActivation` NeverActive, Cast io_app co0)
472
473
474
475
               -- Never inline the f.e.d. function, because the litlit
               -- might not be in scope in other modules.

    return ([fed], h_code, c_code)
476

sof's avatar
sof committed
477
 where
478
  ty                       = pFst (coercionKind co0)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
479
480
  (tvs,sans_foralls)       = tcSplitForAllTys ty
  ([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
sof's avatar
sof committed
483

484

Ian Lynagh's avatar
Ian Lynagh committed
485
486
toCName :: DynFlags -> Id -> String
toCName dflags i = showSDoc dflags (pprCode CStyle (ppr (idName i)))
sof's avatar
sof committed
487

Austin Seipp's avatar
Austin Seipp committed
488
489
490
{-
*

sof's avatar
sof committed
491
\subsection{Generating @foreign export@ stubs}
Austin Seipp's avatar
Austin Seipp committed
492
493

*
sof's avatar
sof committed
494

495
For each @foreign export@ function, a C stub function is generated.
496
The C stub constructs the application of the exported Haskell function
497
using the hugs/ghc rts invocation API.
Austin Seipp's avatar
Austin Seipp committed
498
-}
sof's avatar
sof committed
499

500
501
mkFExportCBits :: DynFlags
               -> FastString
502
503
504
505
506
507
508
509
510
511
512
               -> 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
513
 = (header_bits, c_bits, type_string,
514
    sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args
515
516
517
518
519
520
521
         -- 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
522
    )
sof's avatar
sof committed
523
 where
524
  -- list the arguments to the C function
525
526
527
528
  arg_info :: [(SDoc,           -- arg name
                SDoc,           -- C type
                Type,           -- Haskell type
                CmmType)]       -- the CmmType
529
  arg_info  = [ let stg_type = showStgType ty in
530
531
                (arg_cname n stg_type,
                 stg_type,
532
                 ty,
533
                 typeCmmType dflags (getPrimTyOf ty))
534
              | (ty,n) <- zip arg_htys [1::Int ..] ]
535

536
  arg_cname n stg_ty
537
        | libffi    = char '*' <> parens (stg_ty <> char '*') <>
538
                      text "args" <> brackets (int (n-1))
539
540
541
542
543
544
545
        | 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:
546
      | libffi    = primTyDescChar dflags res_hty : arg_type_string
547
548
      | otherwise = arg_type_string

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

552
553
554
  -- 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
555
    | isNothing maybe_target = stable_ptr_arg : insertRetAddr dflags cc arg_info
556
557
    | otherwise              = arg_info

558
559
  stable_ptr_arg =
        (text "the_stableptr", text "StgStablePtr", undefined,
560
         typeCmmType dflags (mkStablePtrPrimTy alphaTy))
561
562

  -- stuff to do with the return type of the C function
563
  res_hty_is_unit = res_hty `eqType` unitTy     -- Look through any newtypes
564
565

  cResType | res_hty_is_unit = text "void"
566
           | otherwise       = showStgType res_hty
567

568
569
570
571
572
573
574
575
576
577
578
579
580
  -- 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]

581
  -- Now we can cook up the prototype for the exported function.
Ian Lynagh's avatar
Ian Lynagh committed
582
  pprCconv = ccallConvAttribute cc
583

584
  header_bits = text "extern" <+> fun_proto <> semi
sof's avatar
sof committed
585

586
587
588
589
590
  fun_args
    | null aug_arg_info = text "void"
    | otherwise         = hsep $ punctuate comma
                               $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info

591
592
  fun_proto
    | libffi
593
594
      = text "void" <+> ftext c_nm <>
          parens (text "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr")
595
    | otherwise
596
      = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args
597
598
599
600
601

  -- 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)"
602
          Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"
603

604
605
  cap = text "cap" <> comma

606
607
  -- the expression we give to rts_evalIO
  expr_to_run
608
     = foldl' appArg the_cfun arg_info -- NOT aug_arg_info
609
       where
610
611
          appArg acc (arg_cname, _, arg_hty, _)
             = text "rts_apply"
612
               <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname))
613
614
615

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

619
  assignCResult | res_hty_is_unit = empty
620
621
                | otherwise       =
                        text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi
622
623
624
625
626

  -- an extern decl for the fn being called
  extern_decl
     = case maybe_target of
          Nothing -> empty
627
          Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi
628

629

630
  -- finally, the whole darn thing
631
  c_bits =
632
    space $$
633
    extern_decl $$
634
    fun_proto  $$
635
    vcat
636
     [ lbrace
637
     ,   text "Capability *cap;"
638
     ,   declareResult
639
     ,   declareCResult
640
     ,   text "cap = rts_lock();"
641
          -- create the application + perform it.
642
     ,   text "rts_evalIO" <> parens (
643
                char '&' <> cap <>
644
                text "rts_apply" <> parens (
645
646
647
648
649
650
651
652
653
654
                    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
655
     ,   text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm)
656
                                                <> comma <> text "cap") <> semi
657
     ,   assignCResult
658
     ,   text "rts_unlock(cap);"
659
     ,   ppUnless res_hty_is_unit $
660
         if libffi
661
                  then char '*' <> parens (ffi_cResType <> char '*') <>
662
663
                       text "resp = cret;"
                  else text "return cret;"
664
     , rbrace
665
666
667
668
669
670
671
672
     ]


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
673
   -- codeGen/CodeGen.hs; however, stginit functions have a negative impact
674
675
676
677
678
679
680
681
   -- 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 "()"
682
    , braces (text "foreignExportStablePtr"
683
       <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure")
684
685
686
       <> semi)
    ]

sof's avatar
sof committed
687

688
mkHObj :: Type -> SDoc
sof's avatar
sof committed
689
mkHObj t = text "rts_mk" <> text (showFFIType t)
sof's avatar
sof committed
690

691
unpackHObj :: Type -> SDoc
sof's avatar
sof committed
692
unpackHObj t = text "rts_get" <> text (showFFIType t)
693

694
695
696
showStgType :: Type -> SDoc
showStgType t = text "Hs" <> text (showFFIType t)

sof's avatar
sof committed
697
showFFIType :: Type -> String
698
699
showFFIType t = getOccString (getName (typeTyCon t))

700
toCType :: Type -> (Maybe Header, SDoc)
701
702
toCType = f False
    where f voidOK t
703
704
705
           -- First, if we have (Ptr t) of (FunPtr t), then we need to
           -- convert t to a C type and put a * after it. If we don't
           -- know a type for t, then "void" is fine, though.
706
           | Just (ptr, [t']) <- splitTyConApp_maybe t
707
           , tyConName ptr `elem` [ptrTyConName, funPtrTyConName]
708
709
710
              = case f True t' of
                (mh, cType') ->
                    (mh, cType' <> char '*')
711
712
713
714
           -- Otherwise, if we have a type constructor application, then
           -- see if there is a C type associated with that constructor.
           -- Note that we aren't looking through type synonyms or
           -- anything, as it may be the synonym that is annotated.
715
           | Just tycon <- tyConAppTyConPicky_maybe t
716
           , Just (CType _ mHeader (_,cType)) <- tyConCType_maybe tycon
717
              = (mHeader, ftext cType)
718
719
720
721
           -- If we don't know a C type for this type, then try looking
           -- through one layer of type synonym etc.
           | Just t' <- coreView t
              = f voidOK t'
722
723
724
725
726
727
           -- This may be an 'UnliftedFFITypes'-style ByteArray# argument
           -- (which is marshalled like a Ptr)
           | Just byteArrayPrimTyCon        == tyConAppTyConPicky_maybe t
              = (Nothing, text "const void*")
           | Just mutableByteArrayPrimTyCon == tyConAppTyConPicky_maybe t
              = (Nothing, text "void*")
728
729
           -- Otherwise we don't know the C type. If we are allowing
           -- void then return that; otherwise something has gone wrong.
730
           | voidOK = (Nothing, text "void")
731
732
733
           | otherwise
              = pprPanic "toCType" (ppr t)

734
typeTyCon :: Type -> TyCon
735
typeTyCon ty
Richard Eisenberg's avatar
Richard Eisenberg committed
736
  | Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty)
737
738
739
  = tc
  | otherwise
  = pprPanic "DsForeign.typeTyCon" (ppr ty)
740

741
742
743
744
insertRetAddr :: DynFlags -> CCallConv
              -> [(SDoc, SDoc, Type, CmmType)]
              -> [(SDoc, SDoc, Type, CmmType)]
insertRetAddr dflags CCallConv args
745
746
747
748
749
750
751
752
753
    = case platformArch platform of
      ArchX86_64
       | platformOS platform == OSMinGW32 ->
          -- On other Windows x86_64 we insert the return address
          -- after the 4th 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)]
754
              go 4 args = ret_addr_arg dflags : args
755
756
757
758
759
760
761
762
              go n (arg:args) = arg : go (n+1) args
              go _ [] = []
          in go 0 args
       | otherwise ->
          -- On other x86_64 platforms 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).
763
764
          let go :: Int -> [(SDoc, SDoc, Type, CmmType)]
                        -> [(SDoc, SDoc, Type, CmmType)]
765
              go 6 args = ret_addr_arg dflags : args
766
767
768
769
770
771
              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
      _ ->
772
          ret_addr_arg dflags : args
773
    where platform = targetPlatform dflags
774
insertRetAddr _ _ args = args
775

776
777
778
ret_addr_arg :: DynFlags -> (SDoc, SDoc, Type, CmmType)
ret_addr_arg dflags = (text "original_return_addr", text "void*", undefined,
                       typeCmmType dflags addrPrimTy)
779

780
-- This function returns the primitive type associated with the boxed
781
-- type argument to a foreign export (eg. Int ==> Int#).
782
getPrimTyOf :: Type -> UnaryType
783
784
785
786
787
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 =
788
  case splitDataProductType_maybe rep_ty of
789
     Just (_, _, data_con, [prim_ty]) ->
790
        ASSERT(dataConSourceArity data_con == 1)
791
        ASSERT2(isUnliftedType prim_ty, ppr prim_ty)
792
        prim_ty
793
     _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)
794
  where
Richard Eisenberg's avatar
Richard Eisenberg committed
795
        rep_ty = unwrapType ty
796
797
798
799

-- 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.
800
801
primTyDescChar :: DynFlags -> Type -> Char
primTyDescChar dflags ty
802
 | ty `eqType` unitTy = 'v'
803
 | otherwise
Richard Eisenberg's avatar
Richard Eisenberg committed
804
 = case typePrimRep1 (getPrimTyOf ty) of
805
     IntRep      -> signed_word
806
807
808
     WordRep     -> unsigned_word
     Int64Rep    -> 'L'
     Word64Rep   -> 'l'
809
     AddrRep     -> 'p'
810
811
812
813
814
     FloatRep    -> 'f'
     DoubleRep   -> 'd'
     _           -> pprPanic "primTyDescChar" (ppr ty)
  where
    (signed_word, unsigned_word)
815
816
817
       | wORD_SIZE dflags == 4  = ('W','w')
       | wORD_SIZE dflags == 8  = ('L','l')
       | otherwise              = panic "primTyDescChar"