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