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