DsForeign.hs 30.9 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 10
{-# LANGUAGE CPP #-}

11 12 13 14 15 16 17
module DsForeign ( dsForeigns
                 , dsForeigns'
                 , dsFImport, dsCImport, dsFCall, dsPrimCall
                 , dsFExport, dsFExportDynamic, mkFExportCBits
                 , toCType
                 , foreignExportInitialiser
                 ) where
sof's avatar
sof committed
18 19

#include "HsVersions.h"
20
import TcRnMonad        -- temp
sof's avatar
sof committed
21

22 23
import TypeRep

sof's avatar
sof committed
24 25
import CoreSyn

Simon Marlow's avatar
Simon Marlow committed
26
import DsCCall
sof's avatar
sof committed
27 28
import DsMonad

Simon Marlow's avatar
Simon Marlow committed
29 30
import HsSyn
import DataCon
31
import CoreUnfold
Simon Marlow's avatar
Simon Marlow committed
32 33 34 35 36
import Id
import Literal
import Module
import Name
import Type
37
import TyCon
Simon Marlow's avatar
Simon Marlow committed
38
import Coercion
39
import TcEnv
Simon Marlow's avatar
Simon Marlow committed
40
import TcType
41

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

Simon Marlow's avatar
Simon Marlow committed
61
import Data.Maybe
62
import Data.List
sof's avatar
sof committed
63

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

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

82 83
dsForeigns :: [LForeignDecl Id]
           -> DsM (ForeignStubs, OrdList Binding)
84 85 86 87 88
dsForeigns fos = getHooked dsForeignsHook dsForeigns' >>= ($ fos)

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

104
   do_decl (ForeignImport { fd_name = id, fd_co = co, fd_fi = 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 111
   do_decl (ForeignExport { fd_name = L _ id, fd_co = co
                          , fd_fe = CExport (L _ (CExportStatic _ ext_nm cconv)) _ }) = do
112
      (h, c, _, _) <- dsFExport id co ext_nm cconv False
113
      return (h, c, [id], [])
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 _) = do
    (ids, h, c) <- dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader
147
    return (ids, h, c)
148

149
dsCImport :: Id
150
          -> Coercion
151 152 153
          -> CImportSpec
          -> CCallConv
          -> 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 162 163
              | tyConUnique tycon == funPtrTyConKey ->
                 IsFunction
             _ -> 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 176
dsCImport id co (CFunction target) cconv safety mHeader
  = dsFCall id co (CCall (CCallSpec target cconv safety)) mHeader
177
dsCImport id co CWrapper cconv _ _
178
  = dsFExportDynamic id co cconv
179 180 181 182

-- 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.
183 184
fun_type_arg_stdcall_info :: DynFlags -> CCallConv -> Type -> Maybe Int
fun_type_arg_stdcall_info dflags StdCallConv ty
185
  | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty,
186 187
    tyConUnique tc == funPtrTyConKey
  = let
Ian Lynagh's avatar
Ian Lynagh committed
188 189
       (_tvs,sans_foralls)        = tcSplitForAllTys arg_ty
       (fe_arg_tys, _orig_res_ty) = tcSplitFunTys sans_foralls
190 191
    in Just $ sum (map (widthInBytes . typeWidth . typeCmmType dflags . getPrimTyOf) fe_arg_tys)
fun_type_arg_stdcall_info _ _other_conv _
192
  = Nothing
193

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

202
dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header
203
        -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
204
dsFCall fn_id co fcall mDeclHeader = do
205
    let
206
        ty                   = pFst $ coercionKind co
207 208 209 210 211 212 213
        (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)
214

215
    let
216
        work_arg_ids  = [v | Var v <- val_args] -- All guaranteed to be vars
217

218
    (ccall_result_ty, res_wrapper) <- boxResult io_res_ty
219 220 221

    ccall_uniq <- newUnique
    work_uniq  <- newUnique
222

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

        -- Build the wrapper
        work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
        wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
281
        wrap_rhs     = mkLams (tvs ++ args) wrapper_body
282 283
        wrap_rhs'    = Cast wrap_rhs co
        fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineUnfolding (Just (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
307 308 309 310 311 312 313 314
        (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
Ian Lynagh's avatar
Ian Lynagh committed
315
    dflags <- getDynFlags
316
    let
Ian Lynagh's avatar
Ian Lynagh committed
317
        call_app = mkFCall dflags ccall_uniq fcall (map Var args) io_res_ty
318
        rhs      = mkLams tvs (mkLams args call_app)
319 320
        rhs'     = Cast rhs co
    return ([(fn_id, rhs')], empty, empty)
321

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

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

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

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

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

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

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

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

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

391 392
-- Haskell-visible constructor, which is generated from the above:
-- SUP: No check for NULL from createAdjustor anymore???
sof's avatar
sof committed
393

394
f :: Fun -> IO (FunPtr Fun)
395
f cback =
396
   bindIO (newStablePtr cback)
397
          (\StablePtr sp# -> IO (\s1# ->
398
              case _ccall_ createAdjustor cconv sp# ``f_helper'' <arg info> s1# of
399
                 (# s2#, a# #) -> (# s2#, A# a# #)))
sof's avatar
sof committed
400

401 402
foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun)

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

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

417
dsFExportDynamic :: Id
418
                 -> Coercion
419 420
                 -> CCallConv
                 -> DsM ([Binding], SDoc, SDoc)
421
dsFExportDynamic id co0 cconv = do
422
    fe_id <-  newSysLocalDs ty
423
    mod <- getModule
Ian Lynagh's avatar
Ian Lynagh committed
424
    dflags <- getDynFlags
425
    let
sof's avatar
sof committed
426
        -- hack: need to get at the name of the C stub we're about to generate.
Ian Lynagh's avatar
Ian Lynagh committed
427 428 429 430
        -- TODO: There's no real need to go via String with
        -- (mkFastString . zString). In fact, is there a reason to convert
        -- to FastString at all now, rather than sticking with FastZString?
        fe_nm    = mkFastString (zString (zEncodeFS (moduleNameFS (moduleName mod))) ++ "_" ++ toCName dflags fe_id)
431 432 433 434 435 436 437 438 439

    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
440
    (h_code, c_code, typestring, args_size) <- dsFExport id (mkReflCo Representational export_ty) fe_nm cconv True
441 442 443 444 445 446 447 448
    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).
         -}
449
        adj_args      = [ mkIntLitInt dflags (ccallConvToInt cconv)
450
                        , Var stbl_value
451
                        , Lit (MachLabel fe_nm mb_sz_args IsFunction)
452
                        , Lit (mkMachString typestring)
453 454
                        ]
          -- name of external entry point providing these services.
455
          -- (probably in the RTS.)
Ian Lynagh's avatar
Ian Lynagh committed
456
        adjustor   = fsLit "createAdjustor"
457

458 459 460 461 462 463 464 465 466 467
          -- 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

468 469
    let io_app = mkLams tvs                  $
                 Lam cback                   $
470 471
                 mkApps (Var bindIOId)
                        [ Type stable_ptr_ty
472
                        , Type res_ty
473 474 475 476
                        , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
                        , Lam stbl_value ccall_adj
                        ]

477
        fed = (id `setInlineActivation` NeverActive, Cast io_app co0)
478 479 480 481
               -- Never inline the f.e.d. function, because the litlit
               -- might not be in scope in other modules.

    return ([fed], h_code, c_code)
482

sof's avatar
sof committed
483
 where
484
  ty                       = pFst (coercionKind co0)
485 486
  (tvs,sans_foralls)       = tcSplitForAllTys ty
  ([arg_ty], fn_res_ty)    = tcSplitFunTys sans_foralls
487
  Just (io_tc, res_ty)     = tcSplitIOType_maybe fn_res_ty
488
        -- Must have an IO type; hence Just
sof's avatar
sof committed
489

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

Austin Seipp's avatar
Austin Seipp committed
493 494 495
{-
*

sof's avatar
sof committed
496
\subsection{Generating @foreign export@ stubs}
Austin Seipp's avatar
Austin Seipp committed
497 498

*
sof's avatar
sof committed
499

500
For each @foreign export@ function, a C stub function is generated.
501
The C stub constructs the application of the exported Haskell function
502
using the hugs/ghc rts invocation API.
Austin Seipp's avatar
Austin Seipp committed
503
-}
sof's avatar
sof committed
504

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

541
  arg_cname n stg_ty
542
        | libffi    = char '*' <> parens (stg_ty <> char '*') <>
Ian Lynagh's avatar
Ian Lynagh committed
543
                      ptext (sLit "args") <> brackets (int (n-1))
544 545 546 547 548 549 550
        | 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:
551
      | libffi    = primTyDescChar dflags res_hty : arg_type_string
552 553
      | otherwise = arg_type_string

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

557 558 559
  -- 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
560
    | isNothing maybe_target = stable_ptr_arg : insertRetAddr dflags cc arg_info
561 562
    | otherwise              = arg_info

563 564
  stable_ptr_arg =
        (text "the_stableptr", text "StgStablePtr", undefined,
565
         typeCmmType dflags (mkStablePtrPrimTy alphaTy))
566 567

  -- stuff to do with the return type of the C function
568
  res_hty_is_unit = res_hty `eqType` unitTy     -- Look through any newtypes
569 570

  cResType | res_hty_is_unit = text "void"
571
           | otherwise       = showStgType res_hty
572

573 574 575 576 577 578 579 580 581 582 583 584 585
  -- 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]

586
  -- Now we can cook up the prototype for the exported function.
Ian Lynagh's avatar
Ian Lynagh committed
587
  pprCconv = ccallConvAttribute cc
588

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

591 592 593 594 595
  fun_args
    | null aug_arg_info = text "void"
    | otherwise         = hsep $ punctuate comma
                               $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info

596 597
  fun_proto
    | libffi
598
      = ptext (sLit "void") <+> ftext c_nm <>
Ian Lynagh's avatar
Ian Lynagh committed
599
          parens (ptext (sLit "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr"))
600
    | otherwise
601
      = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args
602 603 604 605 606

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

609 610
  cap = text "cap" <> comma

611 612
  -- the expression we give to rts_evalIO
  expr_to_run
613
     = foldl appArg the_cfun arg_info -- NOT aug_arg_info
614
       where
615 616
          appArg acc (arg_cname, _, arg_hty, _)
             = text "rts_apply"
617
               <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname))
618 619 620

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

624
  assignCResult | res_hty_is_unit = empty
625 626
                | otherwise       =
                        text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi
627 628 629 630 631

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

634

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


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

sof's avatar
sof committed
692

693
mkHObj :: Type -> SDoc
sof's avatar
sof committed
694
mkHObj t = text "rts_mk" <> text (showFFIType t)
sof's avatar
sof committed
695

696
unpackHObj :: Type -> SDoc
sof's avatar
sof committed
697
unpackHObj t = text "rts_get" <> text (showFFIType t)
698

699 700 701
showStgType :: Type -> SDoc
showStgType t = text "Hs" <> text (showFFIType t)

sof's avatar
sof committed
702
showFFIType :: Type -> String
703 704
showFFIType t = getOccString (getName (typeTyCon t))

705
toCType :: Type -> (Maybe Header, SDoc)
706 707
toCType = f False
    where f voidOK t
708 709 710
           -- 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.
711
           | Just (ptr, [t']) <- splitTyConApp_maybe t
712
           , tyConName ptr `elem` [ptrTyConName, funPtrTyConName]
713 714 715
              = case f True t' of
                (mh, cType') ->
                    (mh, cType' <> char '*')
716 717 718 719 720
           -- 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.
           | TyConApp tycon _ <- t
721
           , Just (CType _ mHeader (_,cType)) <- tyConCType_maybe tycon
722
              = (mHeader, ftext cType)
723 724 725 726 727 728
           -- 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'
           -- Otherwise we don't know the C type. If we are allowing
           -- void then return that; otherwise something has gone wrong.
729
           | voidOK = (Nothing, ptext (sLit "void"))
730 731 732
           | otherwise
              = pprPanic "toCType" (ppr t)

733
typeTyCon :: Type -> TyCon
734 735 736 737 738 739
typeTyCon ty
  | UnaryRep rep_ty <- repType ty
  , Just (tc, _) <- tcSplitTyConApp_maybe rep_ty
  = 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 791 792
        ASSERT(dataConSourceArity data_con == 1)
        ASSERT2(isUnLiftedType prim_ty, ppr prim_ty)
        prim_ty
793
     _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)
794
  where
795
        UnaryRep rep_ty = repType 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 804
 | otherwise
 = case typePrimRep (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"