DsForeign.hs 30.4 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
module DsForeign ( dsForeigns ) where
sof's avatar
sof committed
12 13

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

import CoreSyn

Simon Marlow's avatar
Simon Marlow committed
18
import DsCCall
sof's avatar
sof committed
19 20
import DsMonad

Simon Marlow's avatar
Simon Marlow committed
21 22
import HsSyn
import DataCon
23
import CoreUnfold
Simon Marlow's avatar
Simon Marlow committed
24 25 26 27 28
import Id
import Literal
import Module
import Name
import Type
29
import RepType
30
import TyCon
Simon Marlow's avatar
Simon Marlow committed
31
import Coercion
32
import TcEnv
Simon Marlow's avatar
Simon Marlow committed
33
import TcType
34

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

Simon Marlow's avatar
Simon Marlow committed
54
import Data.Maybe
55
import Data.List
sof's avatar
sof committed
56

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

72 73
type Binding = (Id, CoreExpr)   -- No rec/nonrec structure;
                                -- the occurrence analyser will sort it all out
74

75 76
dsForeigns :: [LForeignDecl Id]
           -> DsM (ForeignStubs, OrdList Binding)
77 78 79 80 81
dsForeigns fos = getHooked dsForeignsHook dsForeigns' >>= ($ fos)

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

97
   do_decl (ForeignImport { fd_name = id, fd_co = co, fd_fi = spec }) = do
98
      traceIf (text "fi start" <+> ppr id)
99 100
      let id' = unLoc id
      (bs, h, c) <- dsFImport id' co spec
101
      traceIf (text "fi end" <+> ppr id)
102
      return (h, c, [], bs)
103

104 105
   do_decl (ForeignExport { fd_name = L _ id, fd_co = co
                          , fd_fe = CExport (L _ (CExportStatic _ ext_nm cconv)) _ }) = do
106
      (h, c, _, _) <- dsFExport id co ext_nm cconv False
107
      return (h, c, [id], [])
108

Austin Seipp's avatar
Austin Seipp committed
109 110 111
{-
************************************************************************
*                                                                      *
112
\subsection{Foreign import}
Austin Seipp's avatar
Austin Seipp committed
113 114
*                                                                      *
************************************************************************
115

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

120 121
However, we create a worker/wrapper pair, thus:

122
        foreign import f :: Int -> IO Int
123
==>
124 125 126
        f x = IO ( \s -> case x of { I# x# ->
                         case fw s x# of { (# s1, y# #) ->
                         (# s1, I# y# #)}})
127

128
        fw s x# = ccall f s x#
129 130

The strictness/CPR analyser won't do this automatically because it doesn't look
131
inside returned tuples; but inlining this wrapper is a Really Good Idea
132
because it exposes the boxing to the call site.
Austin Seipp's avatar
Austin Seipp committed
133
-}
134

135
dsFImport :: Id
136
          -> Coercion
137 138
          -> ForeignImport
          -> DsM ([Binding], SDoc, SDoc)
139 140
dsFImport id co (CImport cconv safety mHeader spec _) =
    dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader
141

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

166
dsCImport id co (CFunction target) cconv@PrimCallConv safety _
167
  = dsPrimCall id co (CCall (CCallSpec target cconv safety))
168 169
dsCImport id co (CFunction target) cconv safety mHeader
  = dsFCall id co (CCall (CCallSpec target cconv safety)) mHeader
170
dsCImport id co CWrapper cconv _ _
171
  = dsFExportDynamic id co cconv
172 173 174 175

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

Austin Seipp's avatar
Austin Seipp committed
187 188 189
{-
************************************************************************
*                                                                      *
190
\subsection{Foreign calls}
Austin Seipp's avatar
Austin Seipp committed
191 192 193
*                                                                      *
************************************************************************
-}
194

195
dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header
196
        -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
197
dsFCall fn_id co fcall mDeclHeader = do
198
    let
Simon Peyton Jones's avatar
Simon Peyton Jones committed
199 200 201
        ty                   = pFst $ coercionKind co
        (tv_bndrs, rho)      = tcSplitForAllTyVarBndrs ty
        (arg_tys, io_res_ty) = tcSplitFunTys rho
202 203 204

    args <- newSysLocalsDs arg_tys
    (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args)
205

206
    let
207
        work_arg_ids  = [v | Var v <- val_args] -- All guaranteed to be vars
208

209
    (ccall_result_ty, res_wrapper) <- boxResult io_res_ty
210 211 212

    ccall_uniq <- newUnique
    work_uniq  <- newUnique
213

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

        -- Build the wrapper
        work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
        wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
273
        wrap_rhs     = mkLams (tvs ++ args) wrapper_body
274
        wrap_rhs'    = Cast wrap_rhs co
275 276
        fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineUnfoldingWithArity
                                                (length args) wrap_rhs'
277

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

Austin Seipp's avatar
Austin Seipp committed
280 281 282
{-
************************************************************************
*                                                                      *
283
\subsection{Primitive calls}
Austin Seipp's avatar
Austin Seipp committed
284 285
*                                                                      *
************************************************************************
286 287 288 289 290 291 292

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
293
-}
294

295 296 297
dsPrimCall :: Id -> Coercion -> ForeignCall
           -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
dsPrimCall fn_id co fcall = do
298
    let
299
        ty                   = pFst $ coercionKind co
Simon Peyton Jones's avatar
Simon Peyton Jones committed
300 301
        (tvs, fun_ty)        = tcSplitForAllTys ty
        (arg_tys, io_res_ty) = tcSplitFunTys fun_ty
302 303 304 305

    args <- newSysLocalsDs arg_tys

    ccall_uniq <- newUnique
Ian Lynagh's avatar
Ian Lynagh committed
306
    dflags <- getDynFlags
307
    let
Ian Lynagh's avatar
Ian Lynagh committed
308
        call_app = mkFCall dflags ccall_uniq fcall (map Var args) io_res_ty
309
        rhs      = mkLams tvs (mkLams args call_app)
310 311
        rhs'     = Cast rhs co
    return ([(fn_id, rhs')], empty, empty)
312

Austin Seipp's avatar
Austin Seipp committed
313 314 315
{-
************************************************************************
*                                                                      *
316
\subsection{Foreign export}
Austin Seipp's avatar
Austin Seipp committed
317 318
*                                                                      *
************************************************************************
sof's avatar
sof committed
319

320 321
The function that does most of the work for `@foreign export@' declarations.
(see below for the boilerplate code a `@foreign export@' declaration expands
322
 into.)
sof's avatar
sof committed
323

324 325 326
For each `@foreign export foo@' in a module M we generate:
\begin{itemize}
\item a C function `@foo@', which calls
327
\item a Haskell stub `@M.\$ffoo@', which calls
328 329
\end{itemize}
the user-written Haskell function `@M.foo@'.
Austin Seipp's avatar
Austin Seipp committed
330
-}
331

332 333
dsFExport :: Id                 -- Either the exported Id,
                                -- or the foreign-export-dynamic constructor
334 335
          -> Coercion           -- Coercion between the Haskell type callable
                                -- from C, and its representation type
336 337 338 339 340 341 342 343 344 345
          -> 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
                 )
346

347
dsFExport fn_id co ext_name cconv isDyn = do
348
    let
349 350 351
       ty                     = pSnd $ coercionKind co
       (bndrs, orig_res_ty)   = tcSplitPiTys ty
       fe_arg_tys'            = mapMaybe binderRelevantType_maybe bndrs
352
       -- We must use tcSplits here, because we want to see
353 354 355
       -- the (IO t) in the corner of the type!
       fe_arg_tys | isDyn     = tail fe_arg_tys'
                  | otherwise = fe_arg_tys'
356

357 358 359
       -- 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)
360 361 362 363 364
       (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)
365

366
    dflags <- getDynFlags
367
    return $
368
      mkFExportCBits dflags ext_name
369 370
                     (if isDyn then Nothing else Just fn_id)
                     fe_arg_tys res_ty is_IO_res_ty cconv
sof's avatar
sof committed
371

Austin Seipp's avatar
Austin Seipp committed
372
{-
373 374 375 376
@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
377 378

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

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

385
f :: Fun -> IO (FunPtr Fun)
386
f cback =
387
   bindIO (newStablePtr cback)
388
          (\StablePtr sp# -> IO (\s1# ->
389
              case _ccall_ createAdjustor cconv sp# ``f_helper'' <arg info> s1# of
390
                 (# s2#, a# #) -> (# s2#, A# a# #)))
sof's avatar
sof committed
391

392 393
foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun)

394
-- and the helper in C: (approximately; see `mkFExportCBits` below)
395 396 397

f_helper(StablePtr s, HsBool b, HsInt i)
{
398 399 400 401
        Capability *cap;
        cap = rts_lock();
        rts_evalIO(&cap,
                   rts_apply(rts_apply(deRefStablePtr(s),
402
                                       rts_mkBool(b)), rts_mkInt(i)));
403
        rts_unlock(cap);
404
}
sof's avatar
sof committed
405
\end{verbatim}
Austin Seipp's avatar
Austin Seipp committed
406
-}
sof's avatar
sof committed
407

408
dsFExportDynamic :: Id
409
                 -> Coercion
410 411
                 -> CCallConv
                 -> DsM ([Binding], SDoc, SDoc)
412
dsFExportDynamic id co0 cconv = do
413
    fe_id <-  newSysLocalDs ty
414
    mod <- getModule
Ian Lynagh's avatar
Ian Lynagh committed
415
    dflags <- getDynFlags
416
    let
sof's avatar
sof committed
417
        -- hack: need to get at the name of the C stub we're about to generate.
Ian Lynagh's avatar
Ian Lynagh committed
418 419 420 421
        -- 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)
422 423 424 425 426 427 428 429 430

    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
431
    (h_code, c_code, typestring, args_size) <- dsFExport id (mkRepReflCo export_ty) fe_nm cconv True
432 433 434 435 436 437 438 439
    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).
         -}
440
        adj_args      = [ mkIntLitInt dflags (ccallConvToInt cconv)
441
                        , Var stbl_value
442
                        , Lit (MachLabel fe_nm mb_sz_args IsFunction)
443
                        , Lit (mkMachString typestring)
444 445
                        ]
          -- name of external entry point providing these services.
446
          -- (probably in the RTS.)
Ian Lynagh's avatar
Ian Lynagh committed
447
        adjustor   = fsLit "createAdjustor"
448

449 450 451 452 453 454 455 456 457 458
          -- 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

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

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

    return ([fed], h_code, c_code)
473

sof's avatar
sof committed
474
 where
475
  ty                       = pFst (coercionKind co0)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
476 477
  (tvs,sans_foralls)       = tcSplitForAllTys ty
  ([arg_ty], fn_res_ty)    = tcSplitFunTys sans_foralls
478
  Just (io_tc, res_ty)     = tcSplitIOType_maybe fn_res_ty
479
        -- Must have an IO type; hence Just
sof's avatar
sof committed
480

481

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

Austin Seipp's avatar
Austin Seipp committed
485 486 487
{-
*

sof's avatar
sof committed
488
\subsection{Generating @foreign export@ stubs}
Austin Seipp's avatar
Austin Seipp committed
489 490

*
sof's avatar
sof committed
491

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

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

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

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

549 550 551
  -- 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
552
    | isNothing maybe_target = stable_ptr_arg : insertRetAddr dflags cc arg_info
553 554
    | otherwise              = arg_info

555 556
  stable_ptr_arg =
        (text "the_stableptr", text "StgStablePtr", undefined,
557
         typeCmmType dflags (mkStablePtrPrimTy alphaTy))
558 559

  -- stuff to do with the return type of the C function
560
  res_hty_is_unit = res_hty `eqType` unitTy     -- Look through any newtypes
561 562

  cResType | res_hty_is_unit = text "void"
563
           | otherwise       = showStgType res_hty
564

565 566 567 568 569 570 571 572 573 574 575 576 577
  -- 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]

578
  -- Now we can cook up the prototype for the exported function.
Ian Lynagh's avatar
Ian Lynagh committed
579
  pprCconv = ccallConvAttribute cc
580

581
  header_bits = text "extern" <+> fun_proto <> semi
sof's avatar
sof committed
582

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

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

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

601 602
  cap = text "cap" <> comma

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

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

616
  assignCResult | res_hty_is_unit = empty
617 618
                | otherwise       =
                        text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi
619 620 621 622 623

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

626

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


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

sof's avatar
sof committed
684

685
mkHObj :: Type -> SDoc
sof's avatar
sof committed
686
mkHObj t = text "rts_mk" <> text (showFFIType t)
sof's avatar
sof committed
687

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

691 692 693
showStgType :: Type -> SDoc
showStgType t = text "Hs" <> text (showFFIType t)

sof's avatar
sof committed
694
showFFIType :: Type -> String
695 696
showFFIType t = getOccString (getName (typeTyCon t))

697
toCType :: Type -> (Maybe Header, SDoc)
698 699
toCType = f False
    where f voidOK t
700 701 702
           -- 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.
703
           | Just (ptr, [t']) <- splitTyConApp_maybe t
704
           , tyConName ptr `elem` [ptrTyConName, funPtrTyConName]
705 706 707
              = case f True t' of
                (mh, cType') ->
                    (mh, cType' <> char '*')
708 709 710 711
           -- 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.
712
           | Just tycon <- tyConAppTyConPicky_maybe t
713
           , Just (CType _ mHeader (_,cType)) <- tyConCType_maybe tycon
714
              = (mHeader, ftext cType)
715 716 717 718 719 720
           -- 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.
721
           | voidOK = (Nothing, text "void")
722 723 724
           | otherwise
              = pprPanic "toCType" (ppr t)

725
typeTyCon :: Type -> TyCon
726 727 728 729 730 731
typeTyCon ty
  | UnaryRep rep_ty <- repType ty
  , Just (tc, _) <- tcSplitTyConApp_maybe rep_ty
  = tc
  | otherwise
  = pprPanic "DsForeign.typeTyCon" (ppr ty)
732

733 734 735 736
insertRetAddr :: DynFlags -> CCallConv
              -> [(SDoc, SDoc, Type, CmmType)]
              -> [(SDoc, SDoc, Type, CmmType)]
insertRetAddr dflags CCallConv args
737 738 739 740 741 742 743 744 745
    = 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)]
746
              go 4 args = ret_addr_arg dflags : args
747 748 749 750 751 752 753 754
              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).
755 756
          let go :: Int -> [(SDoc, SDoc, Type, CmmType)]
                        -> [(SDoc, SDoc, Type, CmmType)]
757
              go 6 args = ret_addr_arg dflags : args
758 759 760 761 762 763
              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
      _ ->
764
          ret_addr_arg dflags : args
765
    where platform = targetPlatform dflags
766
insertRetAddr _ _ args = args
767

768 769 770
ret_addr_arg :: DynFlags -> (SDoc, SDoc, Type, CmmType)
ret_addr_arg dflags = (text "original_return_addr", text "void*", undefined,
                       typeCmmType dflags addrPrimTy)
771

772
-- This function returns the primitive type associated with the boxed
773
-- type argument to a foreign export (eg. Int ==> Int#).
774
getPrimTyOf :: Type -> UnaryType
775 776 777 778 779
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 =
780
  case splitDataProductType_maybe rep_ty of
781
     Just (_, _, data_con, [prim_ty]) ->
782
        ASSERT(dataConSourceArity data_con == 1)
783
        ASSERT2(isUnliftedType prim_ty, ppr prim_ty)
784
        prim_ty
785