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 MachOp
  22 import SMRep
  23 import CoreUtils
  24 import Id
  25 import Literal
  26 import Module
  27 import Name
  28 import Type
  29 import Coercion
  30 import TcType
  31
  32 import HscTypes
  33 import ForeignCall
  34 import TysWiredIn
  35 import TysPrim
  36 import PrelNames
  37 import BasicTypes
  38 import SrcLoc
  39 import Outputable
  40 import FastString
  41
  42 import Data.Maybe
  43 \end{code}
  44
  45 Desugaring of @foreign@ declarations is naturally split up into
  46 parts, an @import@ and an @export@  part. A @foreign import@
  47 declaration
  48 \begin{verbatim}
  49   foreign import cc nm f :: prim_args -> IO prim_res
  50 \end{verbatim}
  51 is the same as
  52 \begin{verbatim}
  53   f :: prim_args -> IO prim_res
  54   f a1 ... an = _ccall_ nm cc a1 ... an
  55 \end{verbatim}
  56 so we reuse the desugaring code in @DsCCall@ to deal with these.
  57
  58 \begin{code}
  59 type Binding = (Id, CoreExpr)   -- No rec/nonrec structure;
  60                                 -- the occurrence analyser will sort it all out
  61
  62 dsForeigns :: [LForeignDecl Id]
  63            -> DsM (ForeignStubs, [Binding])
  64 dsForeigns []
  65   = returnDs (NoStubs, [])
  66 dsForeigns fos
  67   = foldlDs combine (ForeignStubs empty empty [] [], []) fos
  68  where
  69   combine stubs (L loc decl) = putSrcSpanDs loc (combine1 stubs decl)
  70
  71   combine1 (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f)
  72            (ForeignImport id _ spec)
  73     = traceIf (text "fi start" <+> ppr id)      `thenDs` \ _ ->
  74       dsFImport (unLoc id) spec                 `thenDs` \ (bs, h, c, mbhd) ->
  75       traceIf (text "fi end" <+> ppr id)        `thenDs` \ _ ->
  76       returnDs (ForeignStubs (h $$ acc_h)
  77                              (c $$ acc_c)
  78                              (addH mbhd acc_hdrs)
  79                              acc_feb,
  80                 bs ++ acc_f)
  81
  82   combine1 (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f)
  83            (ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv)))
  84     = dsFExport id (idType id)
  85                 ext_nm cconv False                 `thenDs` \(h, c, _, _) ->
  86       returnDs (ForeignStubs (h $$ acc_h) (c $$ acc_c) acc_hdrs (id:acc_feb),
  87                 acc_f)
  88
  89   addH Nothing  ls = ls
  90   addH (Just e) ls
  91    | e `elem` ls = ls
  92    | otherwise   = e:ls
  93 \end{code}
  94
  95
  96 %************************************************************************
  97 %*                                                                      *
  98 \subsection{Foreign import}
  99 %*                                                                      *
 100 %************************************************************************
 101
 102 Desugaring foreign imports is just the matter of creating a binding
 103 that on its RHS unboxes its arguments, performs the external call
 104 (using the @CCallOp@ primop), before boxing the result up and returning it.
 105
 106 However, we create a worker/wrapper pair, thus:
 107
 108         foreign import f :: Int -> IO Int
 109 ==>
 110         f x = IO ( \s -> case x of { I# x# ->
 111                          case fw s x# of { (# s1, y# #) ->
 112                          (# s1, I# y# #)}})
 113
 114         fw s x# = ccall f s x#
 115
 116 The strictness/CPR analyser won't do this automatically because it doesn't look
 117 inside returned tuples; but inlining this wrapper is a Really Good Idea
 118 because it exposes the boxing to the call site.
 119
 120 \begin{code}
 121 dsFImport :: Id
 122           -> ForeignImport
 123           -> DsM ([Binding], SDoc, SDoc, Maybe FastString)
 124 dsFImport id (CImport cconv safety header lib spec)
 125   = dsCImport id spec cconv safety no_hdrs        `thenDs` \(ids, h, c) ->
 126     returnDs (ids, h, c, if no_hdrs then Nothing else Just header)
 127   where
 128     no_hdrs = nullFS header
 129
 130   -- FIXME: the `lib' field is needed for .NET ILX generation when invoking
 131   --        routines that are external to the .NET runtime, but GHC doesn't
 132   --        support such calls yet; if `nullFastString lib', the value was not given
 133 dsFImport id (DNImport spec)
 134   = dsFCall id (DNCall spec) True {- No headers -} `thenDs` \(ids, h, c) ->
 135     returnDs (ids, h, c, Nothing)
 136
 137 dsCImport :: Id
 138           -> CImportSpec
 139           -> CCallConv
 140           -> Safety
 141           -> Bool       -- True <=> no headers in the f.i decl
 142           -> DsM ([Binding], SDoc, SDoc)
 143 dsCImport id (CLabel cid) _ _ no_hdrs
 144  = resultWrapper (idType id) `thenDs` \ (resTy, foRhs) ->
 145    ASSERT(fromJust resTy `coreEqType` addrPrimTy)    -- typechecker ensures this
 146     let rhs = foRhs (mkLit (MachLabel cid Nothing)) in
 147     returnDs ([(setImpInline no_hdrs id, rhs)], empty, empty)
 148 dsCImport id (CFunction target) cconv safety no_hdrs
 149   = dsFCall id (CCall (CCallSpec target cconv safety)) no_hdrs
 150 dsCImport id CWrapper cconv _ _
 151   = dsFExportDynamic id cconv
 152
 153 setImpInline :: Bool    -- True <=> No #include headers
 154                         -- in the foreign import declaration
 155              -> Id -> Id
 156 -- If there is a #include header in the foreign import
 157 -- we make the worker non-inlinable, because we currently
 158 -- don't keep the #include stuff in the CCallId, and hence
 159 -- it won't be visible in the importing module, which can be
 160 -- fatal.
 161 -- (The #include stuff is just collected from the foreign import
 162 --  decls in a module.)
 163 -- If you want to do cross-module inlining of the c-calls themselves,
 164 -- put the #include stuff in the package spec, not the foreign
 165 -- import decl.
 166 setImpInline True  id = id
 167 setImpInline False id = id `setInlinePragma` NeverActive
 168 \end{code}
 169
 170
 171 %************************************************************************
 172 %*                                                                      *
 173 \subsection{Foreign calls}
 174 %*                                                                      *
 175 %************************************************************************
 176
 177 \begin{code}
 178 dsFCall fn_id fcall no_hdrs
 179   = let
 180         ty                   = idType fn_id
 181         (tvs, fun_ty)        = tcSplitForAllTys ty
 182         (arg_tys, io_res_ty) = tcSplitFunTys fun_ty
 183                 -- Must use tcSplit* functions because we want to
 184                 -- see that (IO t) in the corner
 185     in
 186     newSysLocalsDs arg_tys                      `thenDs` \ args ->
 187     mapAndUnzipDs unboxArg (map Var args)       `thenDs` \ (val_args, arg_wrappers) ->
 188
 189     let
 190         work_arg_ids  = [v | Var v <- val_args] -- All guaranteed to be vars
 191
 192         forDotnet =
 193          case fcall of
 194            DNCall{} -> True
 195            _        -> False
 196
 197         topConDs
 198           | forDotnet =
 199              dsLookupGlobalId checkDotnetResName `thenDs` \ check_id ->
 200              return (Just check_id)
 201           | otherwise = return Nothing
 202
 203         augmentResultDs
 204           | forDotnet =
 205                 newSysLocalDs addrPrimTy `thenDs` \ err_res ->
 206                 returnDs (\ (mb_res_ty, resWrap) ->
 207                               case mb_res_ty of
 208                                 Nothing -> (Just (mkTyConApp (tupleTyCon Unboxed 1)
 209                                                              [ addrPrimTy ]),
 210                                                  resWrap)
 211                                 Just x  -> (Just (mkTyConApp (tupleTyCon Unboxed 2)
 212                                                              [ x, addrPrimTy ]),
 213                                                  resWrap))
 214           | otherwise = returnDs id
 215     in
 216     augmentResultDs                                  `thenDs` \ augment ->
 217     topConDs                                         `thenDs` \ topCon ->
 218     boxResult augment topCon io_res_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
 219
 220     newUnique                                   `thenDs` \ ccall_uniq ->
 221     newUnique                                   `thenDs` \ work_uniq ->
 222     let
 223         -- Build the worker
 224         worker_ty     = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
 225         the_ccall_app = mkFCall ccall_uniq fcall val_args ccall_result_ty
 226         work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)
 227         work_id       = setImpInline no_hdrs $  -- See comments with setImpInline
 228                         mkSysLocal FSLIT("$wccall") work_uniq worker_ty
 229
 230         -- Build the wrapper
 231         work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
 232         wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
 233         wrap_rhs     = mkInlineMe (mkLams (tvs ++ args) wrapper_body)
 234     in
 235     returnDs ([(work_id, work_rhs), (fn_id, wrap_rhs)], empty, empty)
 236 \end{code}
 237
 238
 239 %************************************************************************
 240 %*                                                                      *
 241 \subsection{Foreign export}
 242 %*                                                                      *
 243 %************************************************************************
 244
 245 The function that does most of the work for `@foreign export@' declarations.
 246 (see below for the boilerplate code a `@foreign export@' declaration expands
 247  into.)
 248
 249 For each `@foreign export foo@' in a module M we generate:
 250 \begin{itemize}
 251 \item a C function `@foo@', which calls
 252 \item a Haskell stub `@M.$ffoo@', which calls
 253 \end{itemize}
 254 the user-written Haskell function `@M.foo@'.
 255
 256 \begin{code}
 257 dsFExport :: Id                 -- Either the exported Id,
 258                                 -- or the foreign-export-dynamic constructor
 259           -> Type               -- The type of the thing callable from C
 260           -> CLabelString       -- The name to export to C land
 261           -> CCallConv
 262           -> Bool               -- True => foreign export dynamic
 263                                 --         so invoke IO action that's hanging off
 264                                 --         the first argument's stable pointer
 265           -> DsM ( SDoc         -- contents of Module_stub.h
 266                  , SDoc         -- contents of Module_stub.c
 267                  , [MachRep]    -- primitive arguments expected by stub function
 268                  , Int          -- size of args to stub function
 269                  )
 270
 271 dsFExport fn_id ty ext_name cconv isDyn
 272    =
 273      let
 274         (_tvs,sans_foralls)             = tcSplitForAllTys ty
 275         (fe_arg_tys', orig_res_ty)      = tcSplitFunTys sans_foralls
 276         -- We must use tcSplits here, because we want to see
 277         -- the (IO t) in the corner of the type!
 278         fe_arg_tys | isDyn     = tail fe_arg_tys'
 279                    | otherwise = fe_arg_tys'
 280      in
 281         -- Look at the result type of the exported function, orig_res_ty
 282         -- If it's IO t, return         (t, True)
 283         -- If it's plain t, return      (t, False)
 284      (case tcSplitIOType_maybe orig_res_ty of
 285         Just (ioTyCon, res_ty) -> returnDs (res_ty, True)
 286                 -- The function already returns IO t
 287         Nothing                -> returnDs (orig_res_ty, False)
 288                 -- The function returns t
 289      )                                  `thenDs` \ (res_ty,             -- t
 290                                                     is_IO_res_ty) ->    -- Bool
 291      returnDs $
 292        mkFExportCBits ext_name
 293                       (if isDyn then Nothing else Just fn_id)
 294                       fe_arg_tys res_ty is_IO_res_ty cconv
 295 \end{code}
 296
 297 @foreign import "wrapper"@ (previously "foreign export dynamic") lets
 298 you dress up Haskell IO actions of some fixed type behind an
 299 externally callable interface (i.e., as a C function pointer). Useful
 300 for callbacks and stuff.
 301
 302 \begin{verbatim}
 303 type Fun = Bool -> Int -> IO Int
 304 foreign import "wrapper" f :: Fun -> IO (FunPtr Fun)
 305
 306 -- Haskell-visible constructor, which is generated from the above:
 307 -- SUP: No check for NULL from createAdjustor anymore???
 308
 309 f :: Fun -> IO (FunPtr Fun)
 310 f cback =
 311    bindIO (newStablePtr cback)
 312           (\StablePtr sp# -> IO (\s1# ->
 313               case _ccall_ createAdjustor cconv sp# ``f_helper'' <arg info> s1# of
 314                  (# s2#, a# #) -> (# s2#, A# a# #)))
 315
 316 foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun)
 317
 318 -- and the helper in C:
 319
 320 f_helper(StablePtr s, HsBool b, HsInt i)
 321 {
 322         rts_evalIO(rts_apply(rts_apply(deRefStablePtr(s),
 323                                        rts_mkBool(b)), rts_mkInt(i)));
 324 }
 325 \end{verbatim}
 326
 327 \begin{code}
 328 dsFExportDynamic :: Id
 329                  -> CCallConv
 330                  -> DsM ([Binding], SDoc, SDoc)
 331 dsFExportDynamic id cconv
 332   =  newSysLocalDs ty                            `thenDs` \ fe_id ->
 333      getModuleDs                                `thenDs` \ mod ->
 334      let
 335         -- hack: need to get at the name of the C stub we're about to generate.
 336        fe_nm       = mkFastString (unpackFS (zEncodeFS (moduleNameFS (moduleName mod))) ++ "_" ++ toCName fe_id)
 337      in
 338      newSysLocalDs arg_ty                       `thenDs` \ cback ->
 339      dsLookupGlobalId newStablePtrName          `thenDs` \ newStablePtrId ->
 340      dsLookupTyCon stablePtrTyConName           `thenDs` \ stable_ptr_tycon ->
 341      let
 342         mk_stbl_ptr_app = mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
 343         stable_ptr_ty   = mkTyConApp stable_ptr_tycon [arg_ty]
 344         export_ty       = mkFunTy stable_ptr_ty arg_ty
 345      in
 346      dsLookupGlobalId bindIOName                `thenDs` \ bindIOId ->
 347      newSysLocalDs stable_ptr_ty                `thenDs` \ stbl_value ->
 348      dsFExport id export_ty fe_nm cconv True
 349                 `thenDs` \ (h_code, c_code, arg_reps, args_size) ->
 350      let
 351       stbl_app cont ret_ty = mkApps (Var bindIOId)
 352                                     [ Type stable_ptr_ty
 353                                     , Type ret_ty
 354                                     , mk_stbl_ptr_app
 355                                     , cont
 356                                     ]
 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                       , mkLit (MachLabel fe_nm mb_sz_args)
 367                       , mkLit (mkStringLit arg_type_info)
 368                       ]
 369         -- name of external entry point providing these services.
 370         -- (probably in the RTS.)
 371       adjustor   = FSLIT("createAdjustor")
 372
 373       arg_type_info = map repCharCode arg_reps
 374       repCharCode F32 = 'f'
 375       repCharCode F64 = 'd'
 376       repCharCode I64 = 'l'
 377       repCharCode _   = 'i'
 378
 379         -- Determine the number of bytes of arguments to the stub function,
 380         -- so that we can attach the '@N' suffix to its label if it is a
 381         -- stdcall on Windows.
 382       mb_sz_args = case cconv of
 383                       StdCallConv -> Just args_size
 384                       _           -> Nothing
 385
 386      in
 387      dsCCall adjustor adj_args PlayRisky io_res_ty      `thenDs` \ ccall_adj ->
 388         -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
 389      let ccall_adj_ty = exprType ccall_adj
 390          ccall_io_adj = mkLams [stbl_value]                  $
 391                         (pprTrace "DsForeign: why is there an unsafeCoerce here?" (text "") $
 392                         (Cast ccall_adj (mkUnsafeCoercion ccall_adj_ty io_res_ty )))
 393
 394          io_app = mkLams tvs     $
 395                   mkLams [cback] $
 396                   stbl_app ccall_io_adj res_ty
 397          fed = (id `setInlinePragma` NeverActive, io_app)
 398                 -- Never inline the f.e.d. function, because the litlit
 399                 -- might not be in scope in other modules.
 400      in
 401      returnDs ([fed], h_code, c_code)
 402
 403  where
 404   ty                    = idType id
 405   (tvs,sans_foralls)    = tcSplitForAllTys ty
 406   ([arg_ty], io_res_ty) = tcSplitFunTys sans_foralls
 407   [res_ty]              = tcTyConAppArgs io_res_ty
 408         -- Must use tcSplit* to see the (IO t), which is a newtype
 409
 410 toCName :: Id -> String
 411 toCName i = showSDoc (pprCode CStyle (ppr (idName i)))
 412 \end{code}
 413
 414 %*
 415 %
 416 \subsection{Generating @foreign export@ stubs}
 417 %
 418 %*
 419
 420 For each @foreign export@ function, a C stub function is generated.
 421 The C stub constructs the application of the exported Haskell function
 422 using the hugs/ghc rts invocation API.
 423
 424 \begin{code}
 425 mkFExportCBits :: FastString
 426                -> Maybe Id      -- Just==static, Nothing==dynamic
 427                -> [Type]
 428                -> Type
 429                -> Bool          -- True <=> returns an IO type
 430                -> CCallConv
 431                -> (SDoc,
 432                    SDoc,
 433                    [MachRep],   -- the argument reps
 434                    Int          -- total size of arguments
 435                   )
 436 mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
 437  = (header_bits, c_bits,
 438     [rep | (_,_,_,rep) <- arg_info],  -- just the real args
 439     sum [ machRepByteWidth rep | (_,_,_,rep) <- aug_arg_info] -- all the args
 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                 MachRep)]       -- the MachRep
 447   arg_info  = [ (text ('a':show n), showStgType ty, ty,
 448                  typeMachRep (getPrimTyOf ty))
 449               | (ty,n) <- zip arg_htys [1..] ]
 450
 451   -- add some auxiliary args; the stable ptr in the wrapper case, and
 452   -- a slot for the dummy return address in the wrapper + ccall case
 453   aug_arg_info
 454     | isNothing maybe_target = stable_ptr_arg : insertRetAddr cc arg_info
 455     | otherwise              = arg_info
 456
 457   stable_ptr_arg =
 458         (text "the_stableptr", text "StgStablePtr", undefined,
 459          typeMachRep (mkStablePtrPrimTy alphaTy))
 460
 461   -- stuff to do with the return type of the C function
 462   res_hty_is_unit = res_hty `coreEqType` unitTy -- Look through any newtypes
 463
 464   cResType | res_hty_is_unit = text "void"
 465            | otherwise       = showStgType res_hty
 466
 467   -- Now we can cook up the prototype for the exported function.
 468   pprCconv = case cc of
 469                 CCallConv   -> empty
 470                 StdCallConv -> text (ccallConvAttribute cc)
 471
 472   header_bits = ptext SLIT("extern") <+> fun_proto <> semi
 473
 474   fun_proto = cResType <+> pprCconv <+> ftext c_nm <>
 475               parens (hsep (punctuate comma (map (\(nm,ty,_,_) -> ty <+> nm)
 476                                                  aug_arg_info)))
 477
 478   -- the target which will form the root of what we ask rts_evalIO to run
 479   the_cfun
 480      = case maybe_target of
 481           Nothing    -> text "(StgClosure*)deRefStablePtr(the_stableptr)"
 482           Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"
 483
 484   cap = text "cap" <> comma
 485
 486   -- the expression we give to rts_evalIO
 487   expr_to_run
 488      = foldl appArg the_cfun arg_info -- NOT aug_arg_info
 489        where
 490           appArg acc (arg_cname, _, arg_hty, _)
 491              = text "rts_apply"
 492                <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname))
 493
 494   -- various other bits for inside the fn
 495   declareResult = text "HaskellObj ret;"
 496   declareCResult | res_hty_is_unit = empty
 497                  | otherwise       = cResType <+> text "cret;"
 498
 499   assignCResult | res_hty_is_unit = empty
 500                 | otherwise       =
 501                         text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi
 502
 503   -- an extern decl for the fn being called
 504   extern_decl
 505      = case maybe_target of
 506           Nothing -> empty
 507           Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi
 508
 509
 510    -- Initialise foreign exports by registering a stable pointer from an
 511    -- __attribute__((constructor)) function.
 512    -- The alternative is to do this from stginit functions generated in
 513    -- codeGen/CodeGen.lhs; however, stginit functions have a negative impact
 514    -- on binary sizes and link times because the static linker will think that
 515    -- all modules that are imported directly or indirectly are actually used by
 516    -- the program.
 517    -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)
 518
 519   initialiser
 520      = case maybe_target of
 521           Nothing -> empty
 522           Just hs_fn ->
 523             vcat
 524              [ text "static void stginit_export_" <> ppr hs_fn
 525                   <> text "() __attribute__((constructor));"
 526              , text "static void stginit_export_" <> ppr hs_fn <> text "()"
 527              , braces (text "getStablePtr"
 528                 <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure")
 529                 <> semi)
 530              ]
 531
 532   -- finally, the whole darn thing
 533   c_bits =
 534     space $$
 535     extern_decl $$
 536     fun_proto  $$
 537     vcat
 538      [ lbrace
 539      ,   text "Capability *cap;"
 540      ,   declareResult
 541      ,   declareCResult
 542      ,   text "cap = rts_lock();"
 543           -- create the application + perform it.
 544      ,   text "cap=rts_evalIO" <> parens (
 545                 cap <>
 546                 text "rts_apply" <> parens (
 547                     cap <>
 548                     text "(HaskellObj)"
 549                  <> text (if is_IO_res_ty
 550                                 then "runIO_closure"
 551                                 else "runNonIO_closure")
 552                  <> comma
 553                  <> expr_to_run
 554                 ) <+> comma
 555                <> text "&ret"
 556              ) <> semi
 557      ,   text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm)
 558                                                 <> comma <> text "cap") <> semi
 559      ,   assignCResult
 560      ,   text "rts_unlock(cap);"
 561      ,   if res_hty_is_unit then empty
 562             else text "return cret;"
 563      , rbrace
 564      ] $$
 565     initialiser
 566
 567 -- NB. the calculation here isn't strictly speaking correct.
 568 -- We have a primitive Haskell type (eg. Int#, Double#), and
 569 -- we want to know the size, when passed on the C stack, of
 570 -- the associated C type (eg. HsInt, HsDouble).  We don't have
 571 -- this information to hand, but we know what GHC's conventions
 572 -- are for passing around the primitive Haskell types, so we
 573 -- use that instead.  I hope the two coincide --SDM
 574 typeMachRep ty = argMachRep (typeCgRep ty)
 575
 576 mkHObj :: Type -> SDoc
 577 mkHObj t = text "rts_mk" <> text (showFFIType t)
 578
 579 unpackHObj :: Type -> SDoc
 580 unpackHObj t = text "rts_get" <> text (showFFIType t)
 581
 582 showStgType :: Type -> SDoc
 583 showStgType t = text "Hs" <> text (showFFIType t)
 584
 585 showFFIType :: Type -> String
 586 showFFIType t = getOccString (getName tc)
 587  where
 588   tc = case tcSplitTyConApp_maybe (repType t) of
 589             Just (tc,_) -> tc
 590             Nothing     -> pprPanic "showFFIType" (ppr t)
 591
 592 #if !defined(x86_64_TARGET_ARCH)
 593 insertRetAddr CCallConv args = ret_addr_arg : args
 594 insertRetAddr _ args = args
 595 #else
 596 -- On x86_64 we insert the return address after the 6th
 597 -- integer argument, because this is the point at which we
 598 -- need to flush a register argument to the stack (See rts/Adjustor.c for
 599 -- details).
 600 insertRetAddr CCallConv args = go 0 args
 601   where  go 6 args = ret_addr_arg : args
 602          go n (arg@(_,_,_,rep):args)
 603           | I64 <- rep = arg : go (n+1) args
 604           | otherwise  = arg : go n     args
 605          go n [] = []
 606 insertRetAddr _ args = args
 607 #endif
 608
 609 ret_addr_arg = (text "original_return_addr", text "void*", undefined,
 610                 typeMachRep addrPrimTy)
 611
 612 -- This function returns the primitive type associated with the boxed
 613 -- type argument to a foreign export (eg. Int ==> Int#).
 614 getPrimTyOf :: Type -> Type
 615 getPrimTyOf ty
 616   | isBoolTy rep_ty = intPrimTy
 617   -- Except for Bool, the types we are interested in have a single constructor
 618   -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).
 619   | otherwise =
 620   case splitProductType_maybe rep_ty of
 621      Just (_, _, data_con, [prim_ty]) ->
 622         ASSERT(dataConSourceArity data_con == 1)
 623         ASSERT2(isUnLiftedType prim_ty, ppr prim_ty)
 624         prim_ty
 625      _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)
 626   where
 627         rep_ty = repType ty
 628 \end{code}