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 Id
  23 import Literal
  24 import Module
  25 import Name
  26 import Type
  27 import TyCon
  28 import Coercion
  29 import TcType
  30 import Var
  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
  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, [Binding])
  69 dsForeigns []
  70   = return (NoStubs, [])
  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            (concat 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
  95    do_decl d = pprPanic "dsForeigns/do_decl" (ppr d)
  96 \end{code}
  97
  98
  99 %************************************************************************
 100 %*                                                                      *
 101 \subsection{Foreign import}
 102 %*                                                                      *
 103 %************************************************************************
 104
 105 Desugaring foreign imports is just the matter of creating a binding
 106 that on its RHS unboxes its arguments, performs the external call
 107 (using the @CCallOp@ primop), before boxing the result up and returning it.
 108
 109 However, we create a worker/wrapper pair, thus:
 110
 111         foreign import f :: Int -> IO Int
 112 ==>
 113         f x = IO ( \s -> case x of { I# x# ->
 114                          case fw s x# of { (# s1, y# #) ->
 115                          (# s1, I# y# #)}})
 116
 117         fw s x# = ccall f s x#
 118
 119 The strictness/CPR analyser won't do this automatically because it doesn't look
 120 inside returned tuples; but inlining this wrapper is a Really Good Idea
 121 because it exposes the boxing to the call site.
 122
 123 \begin{code}
 124 dsFImport :: Id
 125           -> ForeignImport
 126           -> DsM ([Binding], SDoc, SDoc)
 127 dsFImport id (CImport cconv safety _ spec) = do
 128     (ids, h, c) <- dsCImport id spec cconv safety
 129     return (ids, h, c)
 130
 131 dsCImport :: Id
 132           -> CImportSpec
 133           -> CCallConv
 134           -> Safety
 135           -> DsM ([Binding], SDoc, SDoc)
 136 dsCImport id (CLabel cid) cconv _ = do
 137    let ty = idType id
 138        fod = case splitTyConApp_maybe (repType ty) of
 139              Just (tycon, _)
 140               | tyConUnique tycon == funPtrTyConKey ->
 141                  IsFunction
 142              _ -> IsData
 143    (resTy, foRhs) <- resultWrapper ty
 144    ASSERT(fromJust resTy `coreEqType` addrPrimTy)    -- typechecker ensures this
 145     let
 146         rhs = foRhs (Lit (MachLabel cid stdcall_info fod))
 147         stdcall_info = fun_type_arg_stdcall_info cconv ty
 148     in
 149     return ([(id, rhs)], empty, empty)
 150
 151 dsCImport id (CFunction target) cconv@PrimCallConv safety
 152   = dsPrimCall id (CCall (CCallSpec target cconv safety))
 153 dsCImport id (CFunction target) cconv safety
 154   = dsFCall id (CCall (CCallSpec target cconv safety))
 155 dsCImport id CWrapper cconv _
 156   = dsFExportDynamic id cconv
 157
 158 -- For stdcall labels, if the type was a FunPtr or newtype thereof,
 159 -- then we need to calculate the size of the arguments in order to add
 160 -- the @n suffix to the label.
 161 fun_type_arg_stdcall_info :: CCallConv -> Type -> Maybe Int
 162 fun_type_arg_stdcall_info StdCallConv ty
 163   | Just (tc,[arg_ty]) <- splitTyConApp_maybe (repType ty),
 164     tyConUnique tc == funPtrTyConKey
 165   = let
 166        (_tvs,sans_foralls)        = tcSplitForAllTys arg_ty
 167        (fe_arg_tys, _orig_res_ty) = tcSplitFunTys sans_foralls
 168     in Just $ sum (map (widthInBytes . typeWidth . typeCmmType . getPrimTyOf) fe_arg_tys)
 169 fun_type_arg_stdcall_info _other_conv _
 170   = Nothing
 171 \end{code}
 172
 173
 174 %************************************************************************
 175 %*                                                                      *
 176 \subsection{Foreign calls}
 177 %*                                                                      *
 178 %************************************************************************
 179
 180 \begin{code}
 181 dsFCall :: Id -> ForeignCall -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
 182 dsFCall fn_id fcall = do
 183     let
 184         ty                   = idType fn_id
 185         (tvs, fun_ty)        = tcSplitForAllTys ty
 186         (arg_tys, io_res_ty) = tcSplitFunTys fun_ty
 187                 -- Must use tcSplit* functions because we want to
 188                 -- see that (IO t) in the corner
 189
 190     args <- newSysLocalsDs arg_tys
 191     (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args)
 192
 193     let
 194         work_arg_ids  = [v | Var v <- val_args] -- All guaranteed to be vars
 195
 196     (ccall_result_ty, res_wrapper) <- boxResult io_res_ty
 197
 198     ccall_uniq <- newUnique
 199     work_uniq  <- newUnique
 200     let
 201         -- Build the worker
 202         worker_ty     = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
 203         the_ccall_app = mkFCall ccall_uniq fcall val_args ccall_result_ty
 204         work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)
 205         work_id       = mkSysLocal (fsLit "$wccall") work_uniq worker_ty
 206
 207         -- Build the wrapper
 208         work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
 209         wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
 210         wrap_rhs     = mkInlineMe (mkLams (tvs ++ args) wrapper_body)
 211
 212     return ([(work_id, work_rhs), (fn_id, 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   -- Now we can cook up the prototype for the exported function.
 492   pprCconv = case cc of
 493                 CCallConv   -> empty
 494                 StdCallConv -> text (ccallConvAttribute cc)
 495                 _           -> panic ("mkFExportCBits/pprCconv " ++ showPpr cc)
 496
 497   header_bits = ptext (sLit "extern") <+> fun_proto <> semi
 498
 499   fun_args
 500     | null aug_arg_info = text "void"
 501     | otherwise         = hsep $ punctuate comma
 502                                $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info
 503
 504   fun_proto
 505     | libffi
 506       = ptext (sLit "void") <+> ftext c_nm <>
 507           parens (ptext (sLit "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr"))
 508     | otherwise
 509       = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args
 510
 511   -- the target which will form the root of what we ask rts_evalIO to run
 512   the_cfun
 513      = case maybe_target of
 514           Nothing    -> text "(StgClosure*)deRefStablePtr(the_stableptr)"
 515           Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"
 516
 517   cap = text "cap" <> comma
 518
 519   -- the expression we give to rts_evalIO
 520   expr_to_run
 521      = foldl appArg the_cfun arg_info -- NOT aug_arg_info
 522        where
 523           appArg acc (arg_cname, _, arg_hty, _)
 524              = text "rts_apply"
 525                <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname))
 526
 527   -- various other bits for inside the fn
 528   declareResult = text "HaskellObj ret;"
 529   declareCResult | res_hty_is_unit = empty
 530                  | otherwise       = cResType <+> text "cret;"
 531
 532   assignCResult | res_hty_is_unit = empty
 533                 | otherwise       =
 534                         text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi
 535
 536   -- an extern decl for the fn being called
 537   extern_decl
 538      = case maybe_target of
 539           Nothing -> empty
 540           Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi
 541
 542
 543   -- finally, the whole darn thing
 544   c_bits =
 545     space $$
 546     extern_decl $$
 547     fun_proto  $$
 548     vcat
 549      [ lbrace
 550      ,   ptext (sLit "Capability *cap;")
 551      ,   declareResult
 552      ,   declareCResult
 553      ,   text "cap = rts_lock();"
 554           -- create the application + perform it.
 555      ,   ptext (sLit "cap=rts_evalIO") <> parens (
 556                 cap <>
 557                 ptext (sLit "rts_apply") <> parens (
 558                     cap <>
 559                     text "(HaskellObj)"
 560                  <> ptext (if is_IO_res_ty
 561                                 then (sLit "runIO_closure")
 562                                 else (sLit "runNonIO_closure"))
 563                  <> comma
 564                  <> expr_to_run
 565                 ) <+> comma
 566                <> text "&ret"
 567              ) <> semi
 568      ,   ptext (sLit "rts_checkSchedStatus") <> parens (doubleQuotes (ftext c_nm)
 569                                                 <> comma <> text "cap") <> semi
 570      ,   assignCResult
 571      ,   ptext (sLit "rts_unlock(cap);")
 572      ,   if res_hty_is_unit then empty
 573             else if libffi
 574                   then char '*' <> parens (cResType <> char '*') <>
 575                        ptext (sLit "resp = cret;")
 576                   else ptext (sLit "return cret;")
 577      , rbrace
 578      ]
 579
 580
 581 foreignExportInitialiser :: Id -> SDoc
 582 foreignExportInitialiser hs_fn =
 583    -- Initialise foreign exports by registering a stable pointer from an
 584    -- __attribute__((constructor)) function.
 585    -- The alternative is to do this from stginit functions generated in
 586    -- codeGen/CodeGen.lhs; however, stginit functions have a negative impact
 587    -- on binary sizes and link times because the static linker will think that
 588    -- all modules that are imported directly or indirectly are actually used by
 589    -- the program.
 590    -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)
 591    vcat
 592     [ text "static void stginit_export_" <> ppr hs_fn
 593          <> text "() __attribute__((constructor));"
 594     , text "static void stginit_export_" <> ppr hs_fn <> text "()"
 595     , braces (text "getStablePtr"
 596        <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure")
 597        <> semi)
 598     ]
 599
 600
 601 mkHObj :: Type -> SDoc
 602 mkHObj t = text "rts_mk" <> text (showFFIType t)
 603
 604 unpackHObj :: Type -> SDoc
 605 unpackHObj t = text "rts_get" <> text (showFFIType t)
 606
 607 showStgType :: Type -> SDoc
 608 showStgType t = text "Hs" <> text (showFFIType t)
 609
 610 showFFIType :: Type -> String
 611 showFFIType t = getOccString (getName tc)
 612  where
 613   tc = case tcSplitTyConApp_maybe (repType t) of
 614             Just (tc,_) -> tc
 615             Nothing     -> pprPanic "showFFIType" (ppr t)
 616
 617 insertRetAddr :: CCallConv -> [(SDoc, SDoc, Type, CmmType)]
 618                            -> [(SDoc, SDoc, Type, CmmType)]
 619 #if !defined(x86_64_TARGET_ARCH)
 620 insertRetAddr CCallConv args = ret_addr_arg : args
 621 insertRetAddr _ args = args
 622 #else
 623 -- On x86_64 we insert the return address after the 6th
 624 -- integer argument, because this is the point at which we
 625 -- need to flush a register argument to the stack (See rts/Adjustor.c for
 626 -- details).
 627 insertRetAddr CCallConv args = go 0 args
 628   where  go :: Int -> [(SDoc, SDoc, Type, CmmType)]
 629                    -> [(SDoc, SDoc, Type, CmmType)]
 630          go 6 args = ret_addr_arg : args
 631          go n (arg@(_,_,_,rep):args)
 632           | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args
 633           | otherwise  = arg : go n     args
 634          go _ [] = []
 635 insertRetAddr _ args = args
 636 #endif
 637
 638 ret_addr_arg :: (SDoc, SDoc, Type, CmmType)
 639 ret_addr_arg = (text "original_return_addr", text "void*", undefined,
 640                 typeCmmType addrPrimTy)
 641
 642 -- This function returns the primitive type associated with the boxed
 643 -- type argument to a foreign export (eg. Int ==> Int#).
 644 getPrimTyOf :: Type -> Type
 645 getPrimTyOf ty
 646   | isBoolTy rep_ty = intPrimTy
 647   -- Except for Bool, the types we are interested in have a single constructor
 648   -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).
 649   | otherwise =
 650   case splitProductType_maybe rep_ty of
 651      Just (_, _, data_con, [prim_ty]) ->
 652         ASSERT(dataConSourceArity data_con == 1)
 653         ASSERT2(isUnLiftedType prim_ty, ppr prim_ty)
 654         prim_ty
 655      _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)
 656   where
 657         rep_ty = repType ty
 658
 659 -- represent a primitive type as a Char, for building a string that
 660 -- described the foreign function type.  The types are size-dependent,
 661 -- e.g. 'W' is a signed 32-bit integer.
 662 primTyDescChar :: Type -> Char
 663 primTyDescChar ty
 664  | ty `coreEqType` unitTy = 'v'
 665  | otherwise
 666  = case typePrimRep (getPrimTyOf ty) of
 667      IntRep      -> signed_word
 668      WordRep     -> unsigned_word
 669      Int64Rep    -> 'L'
 670      Word64Rep   -> 'l'
 671      AddrRep     -> 'p'
 672      FloatRep    -> 'f'
 673      DoubleRep   -> 'd'
 674      _           -> pprPanic "primTyDescChar" (ppr ty)
 675   where
 676     (signed_word, unsigned_word)
 677        | wORD_SIZE == 4  = ('W','w')
 678        | wORD_SIZE == 8  = ('L','l')
 679        | otherwise       = panic "primTyDescChar"
 680 \end{code}