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 import Data.List
  44 \end{code}
  45
  46 Desugaring of @foreign@ declarations is naturally split up into
  47 parts, an @import@ and an @export@  part. A @foreign import@
  48 declaration
  49 \begin{verbatim}
  50   foreign import cc nm f :: prim_args -> IO prim_res
  51 \end{verbatim}
  52 is the same as
  53 \begin{verbatim}
  54   f :: prim_args -> IO prim_res
  55   f a1 ... an = _ccall_ nm cc a1 ... an
  56 \end{verbatim}
  57 so we reuse the desugaring code in @DsCCall@ to deal with these.
  58
  59 \begin{code}
  60 type Binding = (Id, CoreExpr)   -- No rec/nonrec structure;
  61                                 -- the occurrence analyser will sort it all out
  62
  63 dsForeigns :: [LForeignDecl Id]
  64            -> DsM (ForeignStubs, [Binding])
  65 dsForeigns []
  66   = returnDs (NoStubs, [])
  67 dsForeigns fos
  68   = do
  69     fives <- mapM do_ldecl fos
  70     let
  71         (hs, cs, hdrs, idss, bindss) = unzip5 fives
  72         fe_ids = concat idss
  73         fe_init_code = map foreignExportInitialiser fe_ids
  74     --
  75     return (ForeignStubs
  76              (vcat hs)
  77              (vcat cs $$ vcat fe_init_code)
  78              (nub (concat hdrs)),
  79            (concat bindss))
  80   where
  81    do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl)
  82
  83    do_decl (ForeignImport id _ spec)
  84     = traceIf (text "fi start" <+> ppr id)      `thenDs` \ _ ->
  85       dsFImport (unLoc id) spec                 `thenDs` \ (bs, h, c, mbhd) ->
  86       traceIf (text "fi end" <+> ppr id)        `thenDs` \ _ ->
  87       returnDs (h, c, maybeToList mbhd, [], bs)
  88
  89    do_decl (ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv)))
  90     = dsFExport id (idType id)
  91                 ext_nm cconv False                 `thenDs` \(h, c, _, _) ->
  92       returnDs (h, c, [], [id], [])
  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, co) -> returnDs (res_ty, True)
 286                 -- The function already returns IO t
 287                 -- ToDo: what about the coercion?
 288         Nothing                -> returnDs (orig_res_ty, False)
 289                 -- The function returns t
 290      )                                  `thenDs` \ (res_ty,             -- t
 291                                                     is_IO_res_ty) ->    -- Bool
 292      returnDs $
 293        mkFExportCBits ext_name
 294                       (if isDyn then Nothing else Just fn_id)
 295                       fe_arg_tys res_ty is_IO_res_ty cconv
 296 \end{code}
 297
 298 @foreign import "wrapper"@ (previously "foreign export dynamic") lets
 299 you dress up Haskell IO actions of some fixed type behind an
 300 externally callable interface (i.e., as a C function pointer). Useful
 301 for callbacks and stuff.
 302
 303 \begin{verbatim}
 304 type Fun = Bool -> Int -> IO Int
 305 foreign import "wrapper" f :: Fun -> IO (FunPtr Fun)
 306
 307 -- Haskell-visible constructor, which is generated from the above:
 308 -- SUP: No check for NULL from createAdjustor anymore???
 309
 310 f :: Fun -> IO (FunPtr Fun)
 311 f cback =
 312    bindIO (newStablePtr cback)
 313           (\StablePtr sp# -> IO (\s1# ->
 314               case _ccall_ createAdjustor cconv sp# ``f_helper'' <arg info> s1# of
 315                  (# s2#, a# #) -> (# s2#, A# a# #)))
 316
 317 foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun)
 318
 319 -- and the helper in C:
 320
 321 f_helper(StablePtr s, HsBool b, HsInt i)
 322 {
 323         rts_evalIO(rts_apply(rts_apply(deRefStablePtr(s),
 324                                        rts_mkBool(b)), rts_mkInt(i)));
 325 }
 326 \end{verbatim}
 327
 328 \begin{code}
 329 dsFExportDynamic :: Id
 330                  -> CCallConv
 331                  -> DsM ([Binding], SDoc, SDoc)
 332 dsFExportDynamic id cconv
 333   =  newSysLocalDs ty                            `thenDs` \ fe_id ->
 334      getModuleDs                                `thenDs` \ mod ->
 335      let
 336         -- hack: need to get at the name of the C stub we're about to generate.
 337        fe_nm       = mkFastString (unpackFS (zEncodeFS (moduleNameFS (moduleName mod))) ++ "_" ++ toCName fe_id)
 338      in
 339      newSysLocalDs arg_ty                       `thenDs` \ cback ->
 340      dsLookupGlobalId newStablePtrName          `thenDs` \ newStablePtrId ->
 341      dsLookupTyCon stablePtrTyConName           `thenDs` \ stable_ptr_tycon ->
 342      let
 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        {-
 352         The arguments to the external function which will
 353         create a little bit of (template) code on the fly
 354         for allowing the (stable pointed) Haskell closure
 355         to be entered using an external calling convention
 356         (stdcall, ccall).
 357        -}
 358       adj_args      = [ mkIntLitInt (ccallConvToInt cconv)
 359                       , Var stbl_value
 360                       , mkLit (MachLabel fe_nm mb_sz_args)
 361                       , mkLit (mkStringLit arg_type_info)
 362                       ]
 363         -- name of external entry point providing these services.
 364         -- (probably in the RTS.)
 365       adjustor   = FSLIT("createAdjustor")
 366
 367       arg_type_info = map repCharCode arg_reps
 368       repCharCode F32 = 'f'
 369       repCharCode F64 = 'd'
 370       repCharCode I64 = 'l'
 371       repCharCode _   = 'i'
 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      in
 381      dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])  `thenDs` \ ccall_adj ->
 382         -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
 383
 384      let io_app = mkLams tvs                $
 385                   Lam cback                 $
 386                   mkCoerceI (mkSymCoI co)   $
 387                   mkApps (Var bindIOId)
 388                          [ Type stable_ptr_ty
 389                          , Type res_ty
 390                          , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
 391                          , Lam stbl_value ccall_adj
 392                          ]
 393
 394          fed = (id `setInlinePragma` NeverActive, io_app)
 395                 -- Never inline the f.e.d. function, because the litlit
 396                 -- might not be in scope in other modules.
 397      in
 398      returnDs ([fed], h_code, c_code)
 399
 400  where
 401   ty                       = idType id
 402   (tvs,sans_foralls)       = tcSplitForAllTys ty
 403   ([arg_ty], fn_res_ty)    = tcSplitFunTys sans_foralls
 404   Just (io_tc, res_ty, co) = tcSplitIOType_maybe fn_res_ty
 405         -- Must have an IO type; hence Just
 406         -- co : fn_res_ty ~ IO res_ty
 407
 408 toCName :: Id -> String
 409 toCName i = showSDoc (pprCode CStyle (ppr (idName i)))
 410 \end{code}
 411
 412 %*
 413 %
 414 \subsection{Generating @foreign export@ stubs}
 415 %
 416 %*
 417
 418 For each @foreign export@ function, a C stub function is generated.
 419 The C stub constructs the application of the exported Haskell function
 420 using the hugs/ghc rts invocation API.
 421
 422 \begin{code}
 423 mkFExportCBits :: FastString
 424                -> Maybe Id      -- Just==static, Nothing==dynamic
 425                -> [Type]
 426                -> Type
 427                -> Bool          -- True <=> returns an IO type
 428                -> CCallConv
 429                -> (SDoc,
 430                    SDoc,
 431                    [MachRep],   -- the argument reps
 432                    Int          -- total size of arguments
 433                   )
 434 mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
 435  = (header_bits, c_bits,
 436     [rep | (_,_,_,rep) <- arg_info],  -- just the real args
 437     sum [ machRepByteWidth rep | (_,_,_,rep) <- aug_arg_info] -- all the args
 438     )
 439  where
 440   -- list the arguments to the C function
 441   arg_info :: [(SDoc,           -- arg name
 442                 SDoc,           -- C type
 443                 Type,           -- Haskell type
 444                 MachRep)]       -- the MachRep
 445   arg_info  = [ (text ('a':show n), showStgType ty, ty,
 446                  typeMachRep (getPrimTyOf ty))
 447               | (ty,n) <- zip arg_htys [1::Int ..] ]
 448
 449   -- add some auxiliary args; the stable ptr in the wrapper case, and
 450   -- a slot for the dummy return address in the wrapper + ccall case
 451   aug_arg_info
 452     | isNothing maybe_target = stable_ptr_arg : insertRetAddr cc arg_info
 453     | otherwise              = arg_info
 454
 455   stable_ptr_arg =
 456         (text "the_stableptr", text "StgStablePtr", undefined,
 457          typeMachRep (mkStablePtrPrimTy alphaTy))
 458
 459   -- stuff to do with the return type of the C function
 460   res_hty_is_unit = res_hty `coreEqType` unitTy -- Look through any newtypes
 461
 462   cResType | res_hty_is_unit = text "void"
 463            | otherwise       = showStgType res_hty
 464
 465   -- Now we can cook up the prototype for the exported function.
 466   pprCconv = case cc of
 467                 CCallConv   -> empty
 468                 StdCallConv -> text (ccallConvAttribute cc)
 469
 470   header_bits = ptext SLIT("extern") <+> fun_proto <> semi
 471
 472   fun_proto = cResType <+> pprCconv <+> ftext c_nm <>
 473               parens (hsep (punctuate comma (map (\(nm,ty,_,_) -> ty <+> nm)
 474                                                  aug_arg_info)))
 475
 476   -- the target which will form the root of what we ask rts_evalIO to run
 477   the_cfun
 478      = case maybe_target of
 479           Nothing    -> text "(StgClosure*)deRefStablePtr(the_stableptr)"
 480           Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"
 481
 482   cap = text "cap" <> comma
 483
 484   -- the expression we give to rts_evalIO
 485   expr_to_run
 486      = foldl appArg the_cfun arg_info -- NOT aug_arg_info
 487        where
 488           appArg acc (arg_cname, _, arg_hty, _)
 489              = text "rts_apply"
 490                <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname))
 491
 492   -- various other bits for inside the fn
 493   declareResult = text "HaskellObj ret;"
 494   declareCResult | res_hty_is_unit = empty
 495                  | otherwise       = cResType <+> text "cret;"
 496
 497   assignCResult | res_hty_is_unit = empty
 498                 | otherwise       =
 499                         text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi
 500
 501   -- an extern decl for the fn being called
 502   extern_decl
 503      = case maybe_target of
 504           Nothing -> empty
 505           Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi
 506
 507
 508   -- finally, the whole darn thing
 509   c_bits =
 510     space $$
 511     extern_decl $$
 512     fun_proto  $$
 513     vcat
 514      [ lbrace
 515      ,   text "Capability *cap;"
 516      ,   declareResult
 517      ,   declareCResult
 518      ,   text "cap = rts_lock();"
 519           -- create the application + perform it.
 520      ,   text "cap=rts_evalIO" <> parens (
 521                 cap <>
 522                 text "rts_apply" <> parens (
 523                     cap <>
 524                     text "(HaskellObj)"
 525                  <> text (if is_IO_res_ty
 526                                 then "runIO_closure"
 527                                 else "runNonIO_closure")
 528                  <> comma
 529                  <> expr_to_run
 530                 ) <+> comma
 531                <> text "&ret"
 532              ) <> semi
 533      ,   text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm)
 534                                                 <> comma <> text "cap") <> semi
 535      ,   assignCResult
 536      ,   text "rts_unlock(cap);"
 537      ,   if res_hty_is_unit then empty
 538             else text "return cret;"
 539      , rbrace
 540      ]
 541
 542
 543 foreignExportInitialiser :: Id -> SDoc
 544 foreignExportInitialiser hs_fn =
 545    -- Initialise foreign exports by registering a stable pointer from an
 546    -- __attribute__((constructor)) function.
 547    -- The alternative is to do this from stginit functions generated in
 548    -- codeGen/CodeGen.lhs; however, stginit functions have a negative impact
 549    -- on binary sizes and link times because the static linker will think that
 550    -- all modules that are imported directly or indirectly are actually used by
 551    -- the program.
 552    -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)
 553    vcat
 554     [ text "static void stginit_export_" <> ppr hs_fn
 555          <> text "() __attribute__((constructor));"
 556     , text "static void stginit_export_" <> ppr hs_fn <> text "()"
 557     , braces (text "getStablePtr"
 558        <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure")
 559        <> semi)
 560     ]
 561
 562
 563 -- NB. the calculation here isn't strictly speaking correct.
 564 -- We have a primitive Haskell type (eg. Int#, Double#), and
 565 -- we want to know the size, when passed on the C stack, of
 566 -- the associated C type (eg. HsInt, HsDouble).  We don't have
 567 -- this information to hand, but we know what GHC's conventions
 568 -- are for passing around the primitive Haskell types, so we
 569 -- use that instead.  I hope the two coincide --SDM
 570 typeMachRep ty = argMachRep (typeCgRep ty)
 571
 572 mkHObj :: Type -> SDoc
 573 mkHObj t = text "rts_mk" <> text (showFFIType t)
 574
 575 unpackHObj :: Type -> SDoc
 576 unpackHObj t = text "rts_get" <> text (showFFIType t)
 577
 578 showStgType :: Type -> SDoc
 579 showStgType t = text "Hs" <> text (showFFIType t)
 580
 581 showFFIType :: Type -> String
 582 showFFIType t = getOccString (getName tc)
 583  where
 584   tc = case tcSplitTyConApp_maybe (repType t) of
 585             Just (tc,_) -> tc
 586             Nothing     -> pprPanic "showFFIType" (ppr t)
 587
 588 #if !defined(x86_64_TARGET_ARCH)
 589 insertRetAddr CCallConv args = ret_addr_arg : args
 590 insertRetAddr _ args = args
 591 #else
 592 -- On x86_64 we insert the return address after the 6th
 593 -- integer argument, because this is the point at which we
 594 -- need to flush a register argument to the stack (See rts/Adjustor.c for
 595 -- details).
 596 insertRetAddr CCallConv args = go 0 args
 597   where  go 6 args = ret_addr_arg : args
 598          go n (arg@(_,_,_,rep):args)
 599           | I64 <- rep = arg : go (n+1) args
 600           | otherwise  = arg : go n     args
 601          go n [] = []
 602 insertRetAddr _ args = args
 603 #endif
 604
 605 ret_addr_arg = (text "original_return_addr", text "void*", undefined,
 606                 typeMachRep addrPrimTy)
 607
 608 -- This function returns the primitive type associated with the boxed
 609 -- type argument to a foreign export (eg. Int ==> Int#).
 610 getPrimTyOf :: Type -> Type
 611 getPrimTyOf ty
 612   | isBoolTy rep_ty = intPrimTy
 613   -- Except for Bool, the types we are interested in have a single constructor
 614   -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).
 615   | otherwise =
 616   case splitProductType_maybe rep_ty of
 617      Just (_, _, data_con, [prim_ty]) ->
 618         ASSERT(dataConSourceArity data_con == 1)
 619         ASSERT2(isUnLiftedType prim_ty, ppr prim_ty)
 620         prim_ty
 621      _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)
 622   where
 623         rep_ty = repType ty
 624 \end{code}