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 \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 `coreEqType` 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     = mkInlineMe (mkLams (tvs ++ args) wrapper_body)
 209
 210     return ([(work_id, work_rhs), (fn_id, wrap_rhs)], empty, empty)
 211 \end{code}
 212
 213
 214 %************************************************************************
 215 %*                                                                      *
 216 \subsection{Primitive calls}
 217 %*                                                                      *
 218 %************************************************************************
 219
 220 This is for `@foreign import prim@' declarations.
 221
 222 Currently, at the core level we pretend that these primitive calls are
 223 foreign calls. It may make more sense in future to have them as a distinct
 224 kind of Id, or perhaps to bundle them with PrimOps since semantically and
 225 for calling convention they are really prim ops.
 226
 227 \begin{code}
 228 dsPrimCall :: Id -> ForeignCall -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
 229 dsPrimCall fn_id fcall = do
 230     let
 231         ty                   = idType fn_id
 232         (tvs, fun_ty)        = tcSplitForAllTys ty
 233         (arg_tys, io_res_ty) = tcSplitFunTys fun_ty
 234                 -- Must use tcSplit* functions because we want to
 235                 -- see that (IO t) in the corner
 236
 237     args <- newSysLocalsDs arg_tys
 238
 239     ccall_uniq <- newUnique
 240     let
 241         call_app = mkFCall ccall_uniq fcall (map Var args) io_res_ty
 242         rhs      = mkLams tvs (mkLams args call_app)
 243     return ([(fn_id, rhs)], empty, empty)
 244
 245 \end{code}
 246
 247 %************************************************************************
 248 %*                                                                      *
 249 \subsection{Foreign export}
 250 %*                                                                      *
 251 %************************************************************************
 252
 253 The function that does most of the work for `@foreign export@' declarations.
 254 (see below for the boilerplate code a `@foreign export@' declaration expands
 255  into.)
 256
 257 For each `@foreign export foo@' in a module M we generate:
 258 \begin{itemize}
 259 \item a C function `@foo@', which calls
 260 \item a Haskell stub `@M.\$ffoo@', which calls
 261 \end{itemize}
 262 the user-written Haskell function `@M.foo@'.
 263
 264 \begin{code}
 265 dsFExport :: Id                 -- Either the exported Id,
 266                                 -- or the foreign-export-dynamic constructor
 267           -> Type               -- The type of the thing callable from C
 268           -> CLabelString       -- The name to export to C land
 269           -> CCallConv
 270           -> Bool               -- True => foreign export dynamic
 271                                 --         so invoke IO action that's hanging off
 272                                 --         the first argument's stable pointer
 273           -> DsM ( SDoc         -- contents of Module_stub.h
 274                  , SDoc         -- contents of Module_stub.c
 275                  , String       -- string describing type to pass to createAdj.
 276                  , Int          -- size of args to stub function
 277                  )
 278
 279 dsFExport fn_id ty ext_name cconv isDyn=  do
 280     let
 281        (_tvs,sans_foralls)             = tcSplitForAllTys ty
 282        (fe_arg_tys', orig_res_ty)      = tcSplitFunTys sans_foralls
 283        -- We must use tcSplits here, because we want to see
 284        -- the (IO t) in the corner of the type!
 285        fe_arg_tys | isDyn     = tail fe_arg_tys'
 286                   | otherwise = fe_arg_tys'
 287
 288        -- Look at the result type of the exported function, orig_res_ty
 289        -- If it's IO t, return         (t, True)
 290        -- If it's plain t, return      (t, False)
 291     (res_ty,             -- t
 292      is_IO_res_ty) <-    -- Bool
 293         case tcSplitIOType_maybe orig_res_ty of
 294            Just (_ioTyCon, res_ty, _co) -> return (res_ty, True)
 295                    -- The function already returns IO t
 296                    -- ToDo: what about the coercion?
 297            Nothing                    -> return (orig_res_ty, False)
 298                    -- The function returns t
 299
 300     return $
 301       mkFExportCBits ext_name
 302                      (if isDyn then Nothing else Just fn_id)
 303                      fe_arg_tys res_ty is_IO_res_ty cconv
 304 \end{code}
 305
 306 @foreign import "wrapper"@ (previously "foreign export dynamic") lets
 307 you dress up Haskell IO actions of some fixed type behind an
 308 externally callable interface (i.e., as a C function pointer). Useful
 309 for callbacks and stuff.
 310
 311 \begin{verbatim}
 312 type Fun = Bool -> Int -> IO Int
 313 foreign import "wrapper" f :: Fun -> IO (FunPtr Fun)
 314
 315 -- Haskell-visible constructor, which is generated from the above:
 316 -- SUP: No check for NULL from createAdjustor anymore???
 317
 318 f :: Fun -> IO (FunPtr Fun)
 319 f cback =
 320    bindIO (newStablePtr cback)
 321           (\StablePtr sp# -> IO (\s1# ->
 322               case _ccall_ createAdjustor cconv sp# ``f_helper'' <arg info> s1# of
 323                  (# s2#, a# #) -> (# s2#, A# a# #)))
 324
 325 foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun)
 326
 327 -- and the helper in C:
 328
 329 f_helper(StablePtr s, HsBool b, HsInt i)
 330 {
 331         rts_evalIO(rts_apply(rts_apply(deRefStablePtr(s),
 332                                        rts_mkBool(b)), rts_mkInt(i)));
 333 }
 334 \end{verbatim}
 335
 336 \begin{code}
 337 dsFExportDynamic :: Id
 338                  -> CCallConv
 339                  -> DsM ([Binding], SDoc, SDoc)
 340 dsFExportDynamic id cconv = do
 341     fe_id <-  newSysLocalDs ty
 342     mod <- getModuleDs
 343     let
 344         -- hack: need to get at the name of the C stub we're about to generate.
 345         fe_nm    = mkFastString (unpackFS (zEncodeFS (moduleNameFS (moduleName mod))) ++ "_" ++ toCName fe_id)
 346
 347     cback <- newSysLocalDs arg_ty
 348     newStablePtrId <- dsLookupGlobalId newStablePtrName
 349     stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName
 350     let
 351         stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]
 352         export_ty     = mkFunTy stable_ptr_ty arg_ty
 353     bindIOId <- dsLookupGlobalId bindIOName
 354     stbl_value <- newSysLocalDs stable_ptr_ty
 355     (h_code, c_code, typestring, args_size) <- dsFExport id export_ty fe_nm cconv True
 356     let
 357          {-
 358           The arguments to the external function which will
 359           create a little bit of (template) code on the fly
 360           for allowing the (stable pointed) Haskell closure
 361           to be entered using an external calling convention
 362           (stdcall, ccall).
 363          -}
 364         adj_args      = [ mkIntLitInt (ccallConvToInt cconv)
 365                         , Var stbl_value
 366                         , Lit (MachLabel fe_nm mb_sz_args IsFunction)
 367                         , Lit (mkMachString typestring)
 368                         ]
 369           -- name of external entry point providing these services.
 370           -- (probably in the RTS.)
 371         adjustor   = fsLit "createAdjustor"
 372
 373           -- Determine the number of bytes of arguments to the stub function,
 374           -- so that we can attach the '@N' suffix to its label if it is a
 375           -- stdcall on Windows.
 376         mb_sz_args = case cconv of
 377                         StdCallConv -> Just args_size
 378                         _           -> Nothing
 379
 380     ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])
 381         -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
 382
 383     let io_app = mkLams tvs                $
 384                  Lam cback                 $
 385                  mkCoerceI (mkSymCoI co)   $
 386                  mkApps (Var bindIOId)
 387                         [ Type stable_ptr_ty
 388                         , Type res_ty
 389                         , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
 390                         , Lam stbl_value ccall_adj
 391                         ]
 392
 393         fed = (id `setInlineActivation` NeverActive, io_app)
 394                -- Never inline the f.e.d. function, because the litlit
 395                -- might not be in scope in other modules.
 396
 397     return ([fed], h_code, c_code)
 398
 399  where
 400   ty                       = idType id
 401   (tvs,sans_foralls)       = tcSplitForAllTys ty
 402   ([arg_ty], fn_res_ty)    = tcSplitFunTys sans_foralls
 403   Just (io_tc, res_ty, co) = tcSplitIOType_maybe fn_res_ty
 404         -- Must have an IO type; hence Just
 405         -- co : fn_res_ty ~ IO res_ty
 406
 407 toCName :: Id -> String
 408 toCName i = showSDoc (pprCode CStyle (ppr (idName i)))
 409 \end{code}
 410
 411 %*
 412 %
 413 \subsection{Generating @foreign export@ stubs}
 414 %
 415 %*
 416
 417 For each @foreign export@ function, a C stub function is generated.
 418 The C stub constructs the application of the exported Haskell function
 419 using the hugs/ghc rts invocation API.
 420
 421 \begin{code}
 422 mkFExportCBits :: FastString
 423                -> Maybe Id      -- Just==static, Nothing==dynamic
 424                -> [Type]
 425                -> Type
 426                -> Bool          -- True <=> returns an IO type
 427                -> CCallConv
 428                -> (SDoc,
 429                    SDoc,
 430                    String,      -- the argument reps
 431                    Int          -- total size of arguments
 432                   )
 433 mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
 434  = (header_bits, c_bits, type_string,
 435     sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args
 436          -- NB. the calculation here isn't strictly speaking correct.
 437          -- We have a primitive Haskell type (eg. Int#, Double#), and
 438          -- we want to know the size, when passed on the C stack, of
 439          -- the associated C type (eg. HsInt, HsDouble).  We don't have
 440          -- this information to hand, but we know what GHC's conventions
 441          -- are for passing around the primitive Haskell types, so we
 442          -- use that instead.  I hope the two coincide --SDM
 443     )
 444  where
 445   -- list the arguments to the C function
 446   arg_info :: [(SDoc,           -- arg name
 447                 SDoc,           -- C type
 448                 Type,           -- Haskell type
 449                 CmmType)]       -- the CmmType
 450   arg_info  = [ let stg_type = showStgType ty in
 451                 (arg_cname n stg_type,
 452                  stg_type,
 453                  ty,
 454                  typeCmmType (getPrimTyOf ty))
 455               | (ty,n) <- zip arg_htys [1::Int ..] ]
 456
 457   arg_cname n stg_ty
 458         | libffi    = char '*' <> parens (stg_ty <> char '*') <>
 459                       ptext (sLit "args") <> brackets (int (n-1))
 460         | otherwise = text ('a':show n)
 461
 462   -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled
 463   libffi = cLibFFI && isNothing maybe_target
 464
 465   type_string
 466       -- libffi needs to know the result type too:
 467       | libffi    = primTyDescChar res_hty : arg_type_string
 468       | otherwise = arg_type_string
 469
 470   arg_type_string = [primTyDescChar ty | (_,_,ty,_) <- arg_info]
 471                 -- just the real args
 472
 473   -- add some auxiliary args; the stable ptr in the wrapper case, and
 474   -- a slot for the dummy return address in the wrapper + ccall case
 475   aug_arg_info
 476     | isNothing maybe_target = stable_ptr_arg : insertRetAddr cc arg_info
 477     | otherwise              = arg_info
 478
 479   stable_ptr_arg =
 480         (text "the_stableptr", text "StgStablePtr", undefined,
 481          typeCmmType (mkStablePtrPrimTy alphaTy))
 482
 483   -- stuff to do with the return type of the C function
 484   res_hty_is_unit = res_hty `coreEqType` unitTy -- Look through any newtypes
 485
 486   cResType | res_hty_is_unit = text "void"
 487            | otherwise       = showStgType res_hty
 488
 489   -- Now we can cook up the prototype for the exported function.
 490   pprCconv = case cc of
 491                 CCallConv   -> empty
 492                 StdCallConv -> text (ccallConvAttribute cc)
 493                 _           -> panic ("mkFExportCBits/pprCconv " ++ showPpr cc)
 494
 495   header_bits = ptext (sLit "extern") <+> fun_proto <> semi
 496
 497   fun_args
 498     | null aug_arg_info = text "void"
 499     | otherwise         = hsep $ punctuate comma
 500                                $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info
 501
 502   fun_proto
 503     | libffi
 504       = ptext (sLit "void") <+> ftext c_nm <>
 505           parens (ptext (sLit "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr"))
 506     | otherwise
 507       = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args
 508
 509   -- the target which will form the root of what we ask rts_evalIO to run
 510   the_cfun
 511      = case maybe_target of
 512           Nothing    -> text "(StgClosure*)deRefStablePtr(the_stableptr)"
 513           Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"
 514
 515   cap = text "cap" <> comma
 516
 517   -- the expression we give to rts_evalIO
 518   expr_to_run
 519      = foldl appArg the_cfun arg_info -- NOT aug_arg_info
 520        where
 521           appArg acc (arg_cname, _, arg_hty, _)
 522              = text "rts_apply"
 523                <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname))
 524
 525   -- various other bits for inside the fn
 526   declareResult = text "HaskellObj ret;"
 527   declareCResult | res_hty_is_unit = empty
 528                  | otherwise       = cResType <+> text "cret;"
 529
 530   assignCResult | res_hty_is_unit = empty
 531                 | otherwise       =
 532                         text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi
 533
 534   -- an extern decl for the fn being called
 535   extern_decl
 536      = case maybe_target of
 537           Nothing -> empty
 538           Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi
 539
 540
 541   -- finally, the whole darn thing
 542   c_bits =
 543     space $$
 544     extern_decl $$
 545     fun_proto  $$
 546     vcat
 547      [ lbrace
 548      ,   ptext (sLit "Capability *cap;")
 549      ,   declareResult
 550      ,   declareCResult
 551      ,   text "cap = rts_lock();"
 552           -- create the application + perform it.
 553      ,   ptext (sLit "cap=rts_evalIO") <> parens (
 554                 cap <>
 555                 ptext (sLit "rts_apply") <> parens (
 556                     cap <>
 557                     text "(HaskellObj)"
 558                  <> ptext (if is_IO_res_ty
 559                                 then (sLit "runIO_closure")
 560                                 else (sLit "runNonIO_closure"))
 561                  <> comma
 562                  <> expr_to_run
 563                 ) <+> comma
 564                <> text "&ret"
 565              ) <> semi
 566      ,   ptext (sLit "rts_checkSchedStatus") <> parens (doubleQuotes (ftext c_nm)
 567                                                 <> comma <> text "cap") <> semi
 568      ,   assignCResult
 569      ,   ptext (sLit "rts_unlock(cap);")
 570      ,   if res_hty_is_unit then empty
 571             else if libffi
 572                   then char '*' <> parens (cResType <> char '*') <>
 573                        ptext (sLit "resp = cret;")
 574                   else ptext (sLit "return cret;")
 575      , rbrace
 576      ]
 577
 578
 579 foreignExportInitialiser :: Id -> SDoc
 580 foreignExportInitialiser hs_fn =
 581    -- Initialise foreign exports by registering a stable pointer from an
 582    -- __attribute__((constructor)) function.
 583    -- The alternative is to do this from stginit functions generated in
 584    -- codeGen/CodeGen.lhs; however, stginit functions have a negative impact
 585    -- on binary sizes and link times because the static linker will think that
 586    -- all modules that are imported directly or indirectly are actually used by
 587    -- the program.
 588    -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)
 589    vcat
 590     [ text "static void stginit_export_" <> ppr hs_fn
 591          <> text "() __attribute__((constructor));"
 592     , text "static void stginit_export_" <> ppr hs_fn <> text "()"
 593     , braces (text "getStablePtr"
 594        <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure")
 595        <> semi)
 596     ]
 597
 598
 599 mkHObj :: Type -> SDoc
 600 mkHObj t = text "rts_mk" <> text (showFFIType t)
 601
 602 unpackHObj :: Type -> SDoc
 603 unpackHObj t = text "rts_get" <> text (showFFIType t)
 604
 605 showStgType :: Type -> SDoc
 606 showStgType t = text "Hs" <> text (showFFIType t)
 607
 608 showFFIType :: Type -> String
 609 showFFIType t = getOccString (getName tc)
 610  where
 611   tc = case tcSplitTyConApp_maybe (repType t) of
 612             Just (tc,_) -> tc
 613             Nothing     -> pprPanic "showFFIType" (ppr t)
 614
 615 insertRetAddr :: CCallConv -> [(SDoc, SDoc, Type, CmmType)]
 616                            -> [(SDoc, SDoc, Type, CmmType)]
 617 #if !defined(x86_64_TARGET_ARCH)
 618 insertRetAddr CCallConv args = ret_addr_arg : args
 619 insertRetAddr _ args = args
 620 #else
 621 -- On x86_64 we insert the return address after the 6th
 622 -- integer argument, because this is the point at which we
 623 -- need to flush a register argument to the stack (See rts/Adjustor.c for
 624 -- details).
 625 insertRetAddr CCallConv args = go 0 args
 626   where  go :: Int -> [(SDoc, SDoc, Type, CmmType)]
 627                    -> [(SDoc, SDoc, Type, CmmType)]
 628          go 6 args = ret_addr_arg : args
 629          go n (arg@(_,_,_,rep):args)
 630           | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args
 631           | otherwise  = arg : go n     args
 632          go _ [] = []
 633 insertRetAddr _ args = args
 634 #endif
 635
 636 ret_addr_arg :: (SDoc, SDoc, Type, CmmType)
 637 ret_addr_arg = (text "original_return_addr", text "void*", undefined,
 638                 typeCmmType addrPrimTy)
 639
 640 -- This function returns the primitive type associated with the boxed
 641 -- type argument to a foreign export (eg. Int ==> Int#).
 642 getPrimTyOf :: Type -> Type
 643 getPrimTyOf ty
 644   | isBoolTy rep_ty = intPrimTy
 645   -- Except for Bool, the types we are interested in have a single constructor
 646   -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).
 647   | otherwise =
 648   case splitProductType_maybe rep_ty of
 649      Just (_, _, data_con, [prim_ty]) ->
 650         ASSERT(dataConSourceArity data_con == 1)
 651         ASSERT2(isUnLiftedType prim_ty, ppr prim_ty)
 652         prim_ty
 653      _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)
 654   where
 655         rep_ty = repType ty
 656
 657 -- represent a primitive type as a Char, for building a string that
 658 -- described the foreign function type.  The types are size-dependent,
 659 -- e.g. 'W' is a signed 32-bit integer.
 660 primTyDescChar :: Type -> Char
 661 primTyDescChar ty
 662  | ty `coreEqType` unitTy = 'v'
 663  | otherwise
 664  = case typePrimRep (getPrimTyOf ty) of
 665      IntRep      -> signed_word
 666      WordRep     -> unsigned_word
 667      Int64Rep    -> 'L'
 668      Word64Rep   -> 'l'
 669      AddrRep     -> 'p'
 670      FloatRep    -> 'f'
 671      DoubleRep   -> 'd'
 672      _           -> pprPanic "primTyDescChar" (ppr ty)
 673   where
 674     (signed_word, unsigned_word)
 675        | wORD_SIZE == 4  = ('W','w')
 676        | wORD_SIZE == 8  = ('L','l')
 677        | otherwise       = panic "primTyDescChar"
 678 \end{code}