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