compiler/deSugar/DsForeign.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The AQUA Project, Glasgow University, 1998
   4 %
   5
   6 Desugaring foreign declarations (see also DsCCall).
   7
   8 \begin{code}
   9 module DsForeign ( dsForeigns ) where
  10
  11 #include "HsVersions.h"
  12 import TcRnMonad        -- temp
  13
  14 import CoreSyn
  15
  16 import DsCCall
  17 import DsMonad
  18
  19 import HsSyn
  20 import DataCon
  21 import CoreUtils
  22 import CoreUnfold
  23 import Id
  24 import Literal
  25 import Module
  26 import Name
  27 import Type
  28 import TyCon
  29 import Coercion
  30 import TcType
  31
  32 import CmmExpr
  33 import CmmUtils
  34 import HscTypes
  35 import ForeignCall
  36 import TysWiredIn
  37 import TysPrim
  38 import PrelNames
  39 import BasicTypes
  40 import SrcLoc
  41 import Outputable
  42 import FastString
  43 import Config
  44 import Constants
  45 import OrdList
  46 import Data.Maybe
  47 import Data.List
  48 \end{code}
  49
  50 Desugaring of @foreign@ declarations is naturally split up into
  51 parts, an @import@ and an @export@  part. A @foreign import@
  52 declaration
  53 \begin{verbatim}
  54   foreign import cc nm f :: prim_args -> IO prim_res
  55 \end{verbatim}
  56 is the same as
  57 \begin{verbatim}
  58   f :: prim_args -> IO prim_res
  59   f a1 ... an = _ccall_ nm cc a1 ... an
  60 \end{verbatim}
  61 so we reuse the desugaring code in @DsCCall@ to deal with these.
  62
  63 \begin{code}
  64 type Binding = (Id, CoreExpr)   -- No rec/nonrec structure;
  65                                 -- the occurrence analyser will sort it all out
  66
  67 dsForeigns :: [LForeignDecl Id]
  68            -> DsM (ForeignStubs, OrdList Binding)
  69 dsForeigns []
  70   = return (NoStubs, nilOL)
  71 dsForeigns fos = do
  72     fives <- mapM do_ldecl fos
  73     let
  74         (hs, cs, idss, bindss) = unzip4 fives
  75         fe_ids = concat idss
  76         fe_init_code = map foreignExportInitialiser fe_ids
  77     --
  78     return (ForeignStubs
  79              (vcat hs)
  80              (vcat cs $$ vcat fe_init_code),
  81             foldr (appOL . toOL) nilOL bindss)
  82   where
  83    do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl)
  84
  85    do_decl (ForeignImport id _ spec) = do
  86       traceIf (text "fi start" <+> ppr id)
  87       (bs, h, c) <- dsFImport (unLoc id) spec
  88       traceIf (text "fi end" <+> ppr id)
  89       return (h, c, [], bs)
  90
  91    do_decl (ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv))) = do
  92       (h, c, _, _) <- dsFExport id (idType id) ext_nm cconv False
  93       return (h, c, [id], [])
  94 \end{code}
  95
  96
  97 %************************************************************************
  98 %*                                                                      *
  99 \subsection{Foreign import}
 100 %*                                                                      *
 101 %************************************************************************
 102
 103 Desugaring foreign imports is just the matter of creating a binding
 104 that on its RHS unboxes its arguments, performs the external call
 105 (using the @CCallOp@ primop), before boxing the result up and returning it.
 106
 107 However, we create a worker/wrapper pair, thus:
 108
 109         foreign import f :: Int -> IO Int
 110 ==>
 111         f x = IO ( \s -> case x of { I# x# ->
 112                          case fw s x# of { (# s1, y# #) ->
 113                          (# s1, I# y# #)}})
 114
 115         fw s x# = ccall f s x#
 116
 117 The strictness/CPR analyser won't do this automatically because it doesn't look
 118 inside returned tuples; but inlining this wrapper is a Really Good Idea
 119 because it exposes the boxing to the call site.
 120
 121 \begin{code}
 122 dsFImport :: Id
 123           -> ForeignImport
 124           -> DsM ([Binding], SDoc, SDoc)
 125 dsFImport id (CImport cconv safety _ spec) = do
 126     (ids, h, c) <- dsCImport id spec cconv safety
 127     return (ids, h, c)
 128
 129 dsCImport :: Id
 130           -> CImportSpec
 131           -> CCallConv
 132           -> Safety
 133           -> DsM ([Binding], SDoc, SDoc)
 134 dsCImport id (CLabel cid) cconv _ = do
 135    let ty = idType id
 136        fod = case splitTyConApp_maybe (repType ty) of
 137              Just (tycon, _)
 138               | tyConUnique tycon == funPtrTyConKey ->
 139                  IsFunction
 140              _ -> IsData
 141    (resTy, foRhs) <- resultWrapper ty
 142    ASSERT(fromJust resTy `eqType` addrPrimTy)    -- typechecker ensures this
 143     let
 144         rhs = foRhs (Lit (MachLabel cid stdcall_info fod))
 145         stdcall_info = fun_type_arg_stdcall_info cconv ty
 146     in
 147     return ([(id, rhs)], empty, empty)
 148
 149 dsCImport id (CFunction target) cconv@PrimCallConv safety
 150   = dsPrimCall id (CCall (CCallSpec target cconv safety))
 151 dsCImport id (CFunction target) cconv safety
 152   = dsFCall id (CCall (CCallSpec target cconv safety))
 153 dsCImport id CWrapper cconv _
 154   = dsFExportDynamic id cconv
 155
 156 -- For stdcall labels, if the type was a FunPtr or newtype thereof,
 157 -- then we need to calculate the size of the arguments in order to add
 158 -- the @n suffix to the label.
 159 fun_type_arg_stdcall_info :: CCallConv -> Type -> Maybe Int
 160 fun_type_arg_stdcall_info StdCallConv ty
 161   | Just (tc,[arg_ty]) <- splitTyConApp_maybe (repType ty),
 162     tyConUnique tc == funPtrTyConKey
 163   = let
 164        (_tvs,sans_foralls)        = tcSplitForAllTys arg_ty
 165        (fe_arg_tys, _orig_res_ty) = tcSplitFunTys sans_foralls
 166     in Just $ sum (map (widthInBytes . typeWidth . typeCmmType . getPrimTyOf) fe_arg_tys)
 167 fun_type_arg_stdcall_info _other_conv _
 168   = Nothing
 169 \end{code}
 170
 171
 172 %************************************************************************
 173 %*                                                                      *
 174 \subsection{Foreign calls}
 175 %*                                                                      *
 176 %************************************************************************
 177
 178 \begin{code}
 179 dsFCall :: Id -> ForeignCall -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
 180 dsFCall fn_id fcall = do
 181     let
 182         ty                   = idType fn_id
 183         (tvs, fun_ty)        = tcSplitForAllTys ty
 184         (arg_tys, io_res_ty) = tcSplitFunTys fun_ty
 185                 -- Must use tcSplit* functions because we want to
 186                 -- see that (IO t) in the corner
 187
 188     args <- newSysLocalsDs arg_tys
 189     (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args)
 190
 191     let
 192         work_arg_ids  = [v | Var v <- val_args] -- All guaranteed to be vars
 193
 194     (ccall_result_ty, res_wrapper) <- boxResult io_res_ty
 195
 196     ccall_uniq <- newUnique
 197     work_uniq  <- newUnique
 198     let
 199         -- Build the worker
 200         worker_ty     = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
 201         the_ccall_app = mkFCall ccall_uniq fcall val_args ccall_result_ty
 202         work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)
 203         work_id       = mkSysLocal (fsLit "$wccall") work_uniq worker_ty
 204
 205         -- Build the wrapper
 206         work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
 207         wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
 208         wrap_rhs     = mkLams (tvs ++ args) wrapper_body
 209         fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineUnfolding (Just (length args)) wrap_rhs
 210
 211     return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs)], empty, empty)
 212 \end{code}
 213
 214
 215 %************************************************************************
 216 %*                                                                      *
 217 \subsection{Primitive calls}
 218 %*                                                                      *
 219 %************************************************************************
 220
 221 This is for `@foreign import prim@' declarations.
 222
 223 Currently, at the core level we pretend that these primitive calls are
 224 foreign calls. It may make more sense in future to have them as a distinct
 225 kind of Id, or perhaps to bundle them with PrimOps since semantically and
 226 for calling convention they are really prim ops.
 227
 228 \begin{code}
 229 dsPrimCall :: Id -> ForeignCall -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
 230 dsPrimCall fn_id fcall = do
 231     let
 232         ty                   = idType fn_id
 233         (tvs, fun_ty)        = tcSplitForAllTys ty
 234         (arg_tys, io_res_ty) = tcSplitFunTys fun_ty
 235                 -- Must use tcSplit* functions because we want to
 236                 -- see that (IO t) in the corner
 237
 238     args <- newSysLocalsDs arg_tys
 239
 240     ccall_uniq <- newUnique
 241     let
 242         call_app = mkFCall ccall_uniq fcall (map Var args) io_res_ty
 243         rhs      = mkLams tvs (mkLams args call_app)
 244     return ([(fn_id, rhs)], empty, empty)
 245
 246 \end{code}
 247
 248 %************************************************************************
 249 %*                                                                      *
 250 \subsection{Foreign export}
 251 %*                                                                      *
 252 %************************************************************************
 253
 254 The function that does most of the work for `@foreign export@' declarations.
 255 (see below for the boilerplate code a `@foreign export@' declaration expands
 256  into.)
 257
 258 For each `@foreign export foo@' in a module M we generate:
 259 \begin{itemize}
 260 \item a C function `@foo@', which calls
 261 \item a Haskell stub `@M.\$ffoo@', which calls
 262 \end{itemize}
 263 the user-written Haskell function `@M.foo@'.
 264
 265 \begin{code}
 266 dsFExport :: Id                 -- Either the exported Id,
 267                                 -- or the foreign-export-dynamic constructor
 268           -> Type               -- The type of the thing callable from C
 269           -> CLabelString       -- The name to export to C land
 270           -> CCallConv
 271           -> Bool               -- True => foreign export dynamic
 272                                 --         so invoke IO action that's hanging off
 273                                 --         the first argument's stable pointer
 274           -> DsM ( SDoc         -- contents of Module_stub.h
 275                  , SDoc         -- contents of Module_stub.c
 276                  , String       -- string describing type to pass to createAdj.
 277                  , Int          -- size of args to stub function
 278                  )
 279
 280 dsFExport fn_id ty ext_name cconv isDyn=  do
 281     let
 282        (_tvs,sans_foralls)             = tcSplitForAllTys ty
 283        (fe_arg_tys', orig_res_ty)      = tcSplitFunTys sans_foralls
 284        -- We must use tcSplits here, because we want to see
 285        -- the (IO t) in the corner of the type!
 286        fe_arg_tys | isDyn     = tail fe_arg_tys'
 287                   | otherwise = fe_arg_tys'
 288
 289        -- Look at the result type of the exported function, orig_res_ty
 290        -- If it's IO t, return         (t, True)
 291        -- If it's plain t, return      (t, False)
 292     (res_ty,             -- t
 293      is_IO_res_ty) <-    -- Bool
 294         case tcSplitIOType_maybe orig_res_ty of
 295            Just (_ioTyCon, res_ty, _co) -> return (res_ty, True)
 296                    -- The function already returns IO t
 297                    -- ToDo: what about the coercion?
 298            Nothing                    -> return (orig_res_ty, False)
 299                    -- The function returns t
 300
 301     return $
 302       mkFExportCBits ext_name
 303                      (if isDyn then Nothing else Just fn_id)
 304                      fe_arg_tys res_ty is_IO_res_ty cconv
 305 \end{code}
 306
 307 @foreign import "wrapper"@ (previously "foreign export dynamic") lets
 308 you dress up Haskell IO actions of some fixed type behind an
 309 externally callable interface (i.e., as a C function pointer). Useful
 310 for callbacks and stuff.
 311
 312 \begin{verbatim}
 313 type Fun = Bool -> Int -> IO Int
 314 foreign import "wrapper" f :: Fun -> IO (FunPtr Fun)
 315
 316 -- Haskell-visible constructor, which is generated from the above:
 317 -- SUP: No check for NULL from createAdjustor anymore???
 318
 319 f :: Fun -> IO (FunPtr Fun)
 320 f cback =
 321    bindIO (newStablePtr cback)
 322           (\StablePtr sp# -> IO (\s1# ->
 323               case _ccall_ createAdjustor cconv sp# ``f_helper'' <arg info> s1# of
 324                  (# s2#, a# #) -> (# s2#, A# a# #)))
 325
 326 foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun)
 327
 328 -- and the helper in C:
 329
 330 f_helper(StablePtr s, HsBool b, HsInt i)
 331 {
 332         rts_evalIO(rts_apply(rts_apply(deRefStablePtr(s),
 333                                        rts_mkBool(b)), rts_mkInt(i)));
 334 }
 335 \end{verbatim}
 336
 337 \begin{code}
 338 dsFExportDynamic :: Id
 339                  -> CCallConv
 340                  -> DsM ([Binding], SDoc, SDoc)
 341 dsFExportDynamic id cconv = do
 342     fe_id <-  newSysLocalDs ty
 343     mod <- getModuleDs
 344     let
 345         -- hack: need to get at the name of the C stub we're about to generate.
 346         fe_nm    = mkFastString (unpackFS (zEncodeFS (moduleNameFS (moduleName mod))) ++ "_" ++ toCName fe_id)
 347
 348     cback <- newSysLocalDs arg_ty
 349     newStablePtrId <- dsLookupGlobalId newStablePtrName
 350     stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName
 351     let
 352         stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]
 353         export_ty     = mkFunTy stable_ptr_ty arg_ty
 354     bindIOId <- dsLookupGlobalId bindIOName
 355     stbl_value <- newSysLocalDs stable_ptr_ty
 356     (h_code, c_code, typestring, args_size) <- dsFExport id export_ty fe_nm cconv True
 357     let
 358          {-
 359           The arguments to the external function which will
 360           create a little bit of (template) code on the fly
 361           for allowing the (stable pointed) Haskell closure
 362           to be entered using an external calling convention
 363           (stdcall, ccall).
 364          -}
 365         adj_args      = [ mkIntLitInt (ccallConvToInt cconv)
 366                         , Var stbl_value
 367                         , Lit (MachLabel fe_nm mb_sz_args IsFunction)
 368                         , Lit (mkMachString typestring)
 369                         ]
 370           -- name of external entry point providing these services.
 371           -- (probably in the RTS.)
 372         adjustor   = fsLit "createAdjustor"
 373
 374           -- Determine the number of bytes of arguments to the stub function,
 375           -- so that we can attach the '@N' suffix to its label if it is a
 376           -- stdcall on Windows.
 377         mb_sz_args = case cconv of
 378                         StdCallConv -> Just args_size
 379                         _           -> Nothing
 380
 381     ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])
 382         -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
 383
 384     let io_app = mkLams tvs                  $
 385                  Lam cback                   $
 386                  mkCoerce (mkSymCo co) $
 387                  mkApps (Var bindIOId)
 388                         [ Type stable_ptr_ty
 389                         , Type res_ty
 390                         , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
 391                         , Lam stbl_value ccall_adj
 392                         ]
 393
 394         fed = (id `setInlineActivation` NeverActive, io_app)
 395                -- Never inline the f.e.d. function, because the litlit
 396                -- might not be in scope in other modules.
 397
 398     return ([fed], h_code, c_code)
 399
 400  where
 401   ty                       = idType id
 402   (tvs,sans_foralls)       = tcSplitForAllTys ty
 403   ([arg_ty], fn_res_ty)    = tcSplitFunTys sans_foralls
 404   Just (io_tc, res_ty, co) = tcSplitIOType_maybe fn_res_ty
 405         -- Must have an IO type; hence Just
 406         -- co : fn_res_ty ~ IO res_ty
 407
 408 toCName :: Id -> String
 409 toCName i = showSDoc (pprCode CStyle (ppr (idName i)))
 410 \end{code}
 411
 412 %*
 413 %
 414 \subsection{Generating @foreign export@ stubs}
 415 %
 416 %*
 417
 418 For each @foreign export@ function, a C stub function is generated.
 419 The C stub constructs the application of the exported Haskell function
 420 using the hugs/ghc rts invocation API.
 421
 422 \begin{code}
 423 mkFExportCBits :: FastString
 424                -> Maybe Id      -- Just==static, Nothing==dynamic
 425                -> [Type]
 426                -> Type
 427                -> Bool          -- True <=> returns an IO type
 428                -> CCallConv
 429                -> (SDoc,
 430                    SDoc,
 431                    String,      -- the argument reps
 432                    Int          -- total size of arguments
 433                   )
 434 mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
 435  = (header_bits, c_bits, type_string,
 436     sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args
 437          -- NB. the calculation here isn't strictly speaking correct.
 438          -- We have a primitive Haskell type (eg. Int#, Double#), and
 439          -- we want to know the size, when passed on the C stack, of
 440          -- the associated C type (eg. HsInt, HsDouble).  We don't have
 441          -- this information to hand, but we know what GHC's conventions
 442          -- are for passing around the primitive Haskell types, so we
 443          -- use that instead.  I hope the two coincide --SDM
 444     )
 445  where
 446   -- list the arguments to the C function
 447   arg_info :: [(SDoc,           -- arg name
 448                 SDoc,           -- C type
 449                 Type,           -- Haskell type
 450                 CmmType)]       -- the CmmType
 451   arg_info  = [ let stg_type = showStgType ty in
 452                 (arg_cname n stg_type,
 453                  stg_type,
 454                  ty,
 455                  typeCmmType (getPrimTyOf ty))
 456               | (ty,n) <- zip arg_htys [1::Int ..] ]
 457
 458   arg_cname n stg_ty
 459         | libffi    = char '*' <> parens (stg_ty <> char '*') <>
 460                       ptext (sLit "args") <> brackets (int (n-1))
 461         | otherwise = text ('a':show n)
 462
 463   -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled
 464   libffi = cLibFFI && isNothing maybe_target
 465
 466   type_string
 467       -- libffi needs to know the result type too:
 468       | libffi    = primTyDescChar res_hty : arg_type_string
 469       | otherwise = arg_type_string
 470
 471   arg_type_string = [primTyDescChar ty | (_,_,ty,_) <- arg_info]
 472                 -- just the real args
 473
 474   -- add some auxiliary args; the stable ptr in the wrapper case, and
 475   -- a slot for the dummy return address in the wrapper + ccall case
 476   aug_arg_info
 477     | isNothing maybe_target = stable_ptr_arg : insertRetAddr cc arg_info
 478     | otherwise              = arg_info
 479
 480   stable_ptr_arg =
 481         (text "the_stableptr", text "StgStablePtr", undefined,
 482          typeCmmType (mkStablePtrPrimTy alphaTy))
 483
 484   -- stuff to do with the return type of the C function
 485   res_hty_is_unit = res_hty `eqType` unitTy     -- Look through any newtypes
 486
 487   cResType | res_hty_is_unit = text "void"
 488            | otherwise       = showStgType res_hty
 489
 490   -- when the return type is integral and word-sized or smaller, it
 491   -- must be assigned as type ffi_arg (#3516).  To see what type
 492   -- libffi is expecting here, take a look in its own testsuite, e.g.
 493   -- libffi/testsuite/libffi.call/cls_align_ulonglong.c
 494   ffi_cResType
 495      | is_ffi_arg_type = text "ffi_arg"
 496      | otherwise       = cResType
 497      where
 498        res_ty_key = getUnique (getName (typeTyCon res_hty))
 499        is_ffi_arg_type = res_ty_key `notElem`
 500               [floatTyConKey, doubleTyConKey,
 501                int64TyConKey, word64TyConKey]
 502
 503   -- Now we can cook up the prototype for the exported function.
 504   pprCconv = case cc of
 505                 CCallConv   -> empty
 506                 StdCallConv -> text (ccallConvAttribute cc)
 507                 _           -> panic ("mkFExportCBits/pprCconv " ++ showPpr cc)
 508
 509   header_bits = ptext (sLit "extern") <+> fun_proto <> semi
 510
 511   fun_args
 512     | null aug_arg_info = text "void"
 513     | otherwise         = hsep $ punctuate comma
 514                                $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info
 515
 516   fun_proto
 517     | libffi
 518       = ptext (sLit "void") <+> ftext c_nm <>
 519           parens (ptext (sLit "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr"))
 520     | otherwise
 521       = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args
 522
 523   -- the target which will form the root of what we ask rts_evalIO to run
 524   the_cfun
 525      = case maybe_target of
 526           Nothing    -> text "(StgClosure*)deRefStablePtr(the_stableptr)"
 527           Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"
 528
 529   cap = text "cap" <> comma
 530
 531   -- the expression we give to rts_evalIO
 532   expr_to_run
 533      = foldl appArg the_cfun arg_info -- NOT aug_arg_info
 534        where
 535           appArg acc (arg_cname, _, arg_hty, _)
 536              = text "rts_apply"
 537                <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname))
 538
 539   -- various other bits for inside the fn
 540   declareResult = text "HaskellObj ret;"
 541   declareCResult | res_hty_is_unit = empty
 542                  | otherwise       = cResType <+> text "cret;"
 543
 544   assignCResult | res_hty_is_unit = empty
 545                 | otherwise       =
 546                         text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi
 547
 548   -- an extern decl for the fn being called
 549   extern_decl
 550      = case maybe_target of
 551           Nothing -> empty
 552           Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi
 553
 554
 555   -- finally, the whole darn thing
 556   c_bits =
 557     space $$
 558     extern_decl $$
 559     fun_proto  $$
 560     vcat
 561      [ lbrace
 562      ,   ptext (sLit "Capability *cap;")
 563      ,   declareResult
 564      ,   declareCResult
 565      ,   text "cap = rts_lock();"
 566           -- create the application + perform it.
 567      ,   ptext (sLit "cap=rts_evalIO") <> parens (
 568                 cap <>
 569                 ptext (sLit "rts_apply") <> parens (
 570                     cap <>
 571                     text "(HaskellObj)"
 572                  <> ptext (if is_IO_res_ty
 573                                 then (sLit "runIO_closure")
 574                                 else (sLit "runNonIO_closure"))
 575                  <> comma
 576                  <> expr_to_run
 577                 ) <+> comma
 578                <> text "&ret"
 579              ) <> semi
 580      ,   ptext (sLit "rts_checkSchedStatus") <> parens (doubleQuotes (ftext c_nm)
 581                                                 <> comma <> text "cap") <> semi
 582      ,   assignCResult
 583      ,   ptext (sLit "rts_unlock(cap);")
 584      ,   ppUnless res_hty_is_unit $
 585          if libffi
 586                   then char '*' <> parens (ffi_cResType <> char '*') <>
 587                        ptext (sLit "resp = cret;")
 588                   else ptext (sLit "return cret;")
 589      , rbrace
 590      ]
 591
 592
 593 foreignExportInitialiser :: Id -> SDoc
 594 foreignExportInitialiser hs_fn =
 595    -- Initialise foreign exports by registering a stable pointer from an
 596    -- __attribute__((constructor)) function.
 597    -- The alternative is to do this from stginit functions generated in
 598    -- codeGen/CodeGen.lhs; however, stginit functions have a negative impact
 599    -- on binary sizes and link times because the static linker will think that
 600    -- all modules that are imported directly or indirectly are actually used by
 601    -- the program.
 602    -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)
 603    vcat
 604     [ text "static void stginit_export_" <> ppr hs_fn
 605          <> text "() __attribute__((constructor));"
 606     , text "static void stginit_export_" <> ppr hs_fn <> text "()"
 607     , braces (text "getStablePtr"
 608        <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure")
 609        <> semi)
 610     ]
 611
 612
 613 mkHObj :: Type -> SDoc
 614 mkHObj t = text "rts_mk" <> text (showFFIType t)
 615
 616 unpackHObj :: Type -> SDoc
 617 unpackHObj t = text "rts_get" <> text (showFFIType t)
 618
 619 showStgType :: Type -> SDoc
 620 showStgType t = text "Hs" <> text (showFFIType t)
 621
 622 showFFIType :: Type -> String
 623 showFFIType t = getOccString (getName (typeTyCon t))
 624
 625 typeTyCon :: Type -> TyCon
 626 typeTyCon ty = case tcSplitTyConApp_maybe (repType ty) of
 627                  Just (tc,_) -> tc
 628                  Nothing     -> pprPanic "DsForeign.typeTyCon" (ppr ty)
 629
 630 insertRetAddr :: CCallConv -> [(SDoc, SDoc, Type, CmmType)]
 631                            -> [(SDoc, SDoc, Type, CmmType)]
 632 #if !defined(x86_64_TARGET_ARCH)
 633 insertRetAddr CCallConv args = ret_addr_arg : args
 634 insertRetAddr _ args = args
 635 #else
 636 -- On x86_64 we insert the return address after the 6th
 637 -- integer argument, because this is the point at which we
 638 -- need to flush a register argument to the stack (See rts/Adjustor.c for
 639 -- details).
 640 insertRetAddr CCallConv args = go 0 args
 641   where  go :: Int -> [(SDoc, SDoc, Type, CmmType)]
 642                    -> [(SDoc, SDoc, Type, CmmType)]
 643          go 6 args = ret_addr_arg : args
 644          go n (arg@(_,_,_,rep):args)
 645           | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args
 646           | otherwise  = arg : go n     args
 647          go _ [] = []
 648 insertRetAddr _ args = args
 649 #endif
 650
 651 ret_addr_arg :: (SDoc, SDoc, Type, CmmType)
 652 ret_addr_arg = (text "original_return_addr", text "void*", undefined,
 653                 typeCmmType addrPrimTy)
 654
 655 -- This function returns the primitive type associated with the boxed
 656 -- type argument to a foreign export (eg. Int ==> Int#).
 657 getPrimTyOf :: Type -> Type
 658 getPrimTyOf ty
 659   | isBoolTy rep_ty = intPrimTy
 660   -- Except for Bool, the types we are interested in have a single constructor
 661   -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).
 662   | otherwise =
 663   case splitProductType_maybe rep_ty of
 664      Just (_, _, data_con, [prim_ty]) ->
 665         ASSERT(dataConSourceArity data_con == 1)
 666         ASSERT2(isUnLiftedType prim_ty, ppr prim_ty)
 667         prim_ty
 668      _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)
 669   where
 670         rep_ty = repType ty
 671
 672 -- represent a primitive type as a Char, for building a string that
 673 -- described the foreign function type.  The types are size-dependent,
 674 -- e.g. 'W' is a signed 32-bit integer.
 675 primTyDescChar :: Type -> Char
 676 primTyDescChar ty
 677  | ty `eqType` unitTy = 'v'
 678  | otherwise
 679  = case typePrimRep (getPrimTyOf ty) of
 680      IntRep      -> signed_word
 681      WordRep     -> unsigned_word
 682      Int64Rep    -> 'L'
 683      Word64Rep   -> 'l'
 684      AddrRep     -> 'p'
 685      FloatRep    -> 'f'
 686      DoubleRep   -> 'd'
 687      _           -> pprPanic "primTyDescChar" (ppr ty)
 688   where
 689     (signed_word, unsigned_word)
 690        | wORD_SIZE == 4  = ('W','w')
 691        | wORD_SIZE == 8  = ('L','l')
 692        | otherwise       = panic "primTyDescChar"
 693 \end{code}