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 #ifdef DEBUG
 392                         pprTrace "DsForeign: why is there an unsafeCoerce here?" (text "") $
 393 #endif
 394                         (Cast ccall_adj (mkUnsafeCoercion ccall_adj_ty io_res_ty ))
 395
 396          io_app = mkLams tvs     $
 397                   mkLams [cback] $
 398                   stbl_app ccall_io_adj res_ty
 399          fed = (id `setInlinePragma` NeverActive, io_app)
 400                 -- Never inline the f.e.d. function, because the litlit
 401                 -- might not be in scope in other modules.
 402      in
 403      returnDs ([fed], h_code, c_code)
 404
 405  where
 406   ty                    = idType id
 407   (tvs,sans_foralls)    = tcSplitForAllTys ty
 408   ([arg_ty], io_res_ty) = tcSplitFunTys sans_foralls
 409   [res_ty]              = tcTyConAppArgs io_res_ty
 410         -- Must use tcSplit* to see the (IO t), which is a newtype
 411
 412 toCName :: Id -> String
 413 toCName i = showSDoc (pprCode CStyle (ppr (idName i)))
 414 \end{code}
 415
 416 %*
 417 %
 418 \subsection{Generating @foreign export@ stubs}
 419 %
 420 %*
 421
 422 For each @foreign export@ function, a C stub function is generated.
 423 The C stub constructs the application of the exported Haskell function
 424 using the hugs/ghc rts invocation API.
 425
 426 \begin{code}
 427 mkFExportCBits :: FastString
 428                -> Maybe Id      -- Just==static, Nothing==dynamic
 429                -> [Type]
 430                -> Type
 431                -> Bool          -- True <=> returns an IO type
 432                -> CCallConv
 433                -> (SDoc,
 434                    SDoc,
 435                    [MachRep],   -- the argument reps
 436                    Int          -- total size of arguments
 437                   )
 438 mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
 439  = (header_bits, c_bits,
 440     [rep | (_,_,_,rep) <- arg_info],  -- just the real args
 441     sum [ machRepByteWidth rep | (_,_,_,rep) <- aug_arg_info] -- all the args
 442     )
 443  where
 444   -- list the arguments to the C function
 445   arg_info :: [(SDoc,           -- arg name
 446                 SDoc,           -- C type
 447                 Type,           -- Haskell type
 448                 MachRep)]       -- the MachRep
 449   arg_info  = [ (text ('a':show n), showStgType ty, ty,
 450                  typeMachRep (getPrimTyOf ty))
 451               | (ty,n) <- zip arg_htys [1::Int ..] ]
 452
 453   -- add some auxiliary args; the stable ptr in the wrapper case, and
 454   -- a slot for the dummy return address in the wrapper + ccall case
 455   aug_arg_info
 456     | isNothing maybe_target = stable_ptr_arg : insertRetAddr cc arg_info
 457     | otherwise              = arg_info
 458
 459   stable_ptr_arg =
 460         (text "the_stableptr", text "StgStablePtr", undefined,
 461          typeMachRep (mkStablePtrPrimTy alphaTy))
 462
 463   -- stuff to do with the return type of the C function
 464   res_hty_is_unit = res_hty `coreEqType` unitTy -- Look through any newtypes
 465
 466   cResType | res_hty_is_unit = text "void"
 467            | otherwise       = showStgType res_hty
 468
 469   -- Now we can cook up the prototype for the exported function.
 470   pprCconv = case cc of
 471                 CCallConv   -> empty
 472                 StdCallConv -> text (ccallConvAttribute cc)
 473
 474   header_bits = ptext SLIT("extern") <+> fun_proto <> semi
 475
 476   fun_proto = cResType <+> pprCconv <+> ftext c_nm <>
 477               parens (hsep (punctuate comma (map (\(nm,ty,_,_) -> ty <+> nm)
 478                                                  aug_arg_info)))
 479
 480   -- the target which will form the root of what we ask rts_evalIO to run
 481   the_cfun
 482      = case maybe_target of
 483           Nothing    -> text "(StgClosure*)deRefStablePtr(the_stableptr)"
 484           Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"
 485
 486   cap = text "cap" <> comma
 487
 488   -- the expression we give to rts_evalIO
 489   expr_to_run
 490      = foldl appArg the_cfun arg_info -- NOT aug_arg_info
 491        where
 492           appArg acc (arg_cname, _, arg_hty, _)
 493              = text "rts_apply"
 494                <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname))
 495
 496   -- various other bits for inside the fn
 497   declareResult = text "HaskellObj ret;"
 498   declareCResult | res_hty_is_unit = empty
 499                  | otherwise       = cResType <+> text "cret;"
 500
 501   assignCResult | res_hty_is_unit = empty
 502                 | otherwise       =
 503                         text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi
 504
 505   -- an extern decl for the fn being called
 506   extern_decl
 507      = case maybe_target of
 508           Nothing -> empty
 509           Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi
 510
 511
 512    -- Initialise foreign exports by registering a stable pointer from an
 513    -- __attribute__((constructor)) function.
 514    -- The alternative is to do this from stginit functions generated in
 515    -- codeGen/CodeGen.lhs; however, stginit functions have a negative impact
 516    -- on binary sizes and link times because the static linker will think that
 517    -- all modules that are imported directly or indirectly are actually used by
 518    -- the program.
 519    -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)
 520
 521   initialiser
 522      = case maybe_target of
 523           Nothing -> empty
 524           Just hs_fn ->
 525             vcat
 526              [ text "static void stginit_export_" <> ppr hs_fn
 527                   <> text "() __attribute__((constructor));"
 528              , text "static void stginit_export_" <> ppr hs_fn <> text "()"
 529              , braces (text "getStablePtr"
 530                 <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure")
 531                 <> semi)
 532              ]
 533
 534   -- finally, the whole darn thing
 535   c_bits =
 536     space $$
 537     extern_decl $$
 538     fun_proto  $$
 539     vcat
 540      [ lbrace
 541      ,   text "Capability *cap;"
 542      ,   declareResult
 543      ,   declareCResult
 544      ,   text "cap = rts_lock();"
 545           -- create the application + perform it.
 546      ,   text "cap=rts_evalIO" <> parens (
 547                 cap <>
 548                 text "rts_apply" <> parens (
 549                     cap <>
 550                     text "(HaskellObj)"
 551                  <> text (if is_IO_res_ty
 552                                 then "runIO_closure"
 553                                 else "runNonIO_closure")
 554                  <> comma
 555                  <> expr_to_run
 556                 ) <+> comma
 557                <> text "&ret"
 558              ) <> semi
 559      ,   text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm)
 560                                                 <> comma <> text "cap") <> semi
 561      ,   assignCResult
 562      ,   text "rts_unlock(cap);"
 563      ,   if res_hty_is_unit then empty
 564             else text "return cret;"
 565      , rbrace
 566      ] $$
 567     initialiser
 568
 569 -- NB. the calculation here isn't strictly speaking correct.
 570 -- We have a primitive Haskell type (eg. Int#, Double#), and
 571 -- we want to know the size, when passed on the C stack, of
 572 -- the associated C type (eg. HsInt, HsDouble).  We don't have
 573 -- this information to hand, but we know what GHC's conventions
 574 -- are for passing around the primitive Haskell types, so we
 575 -- use that instead.  I hope the two coincide --SDM
 576 typeMachRep ty = argMachRep (typeCgRep ty)
 577
 578 mkHObj :: Type -> SDoc
 579 mkHObj t = text "rts_mk" <> text (showFFIType t)
 580
 581 unpackHObj :: Type -> SDoc
 582 unpackHObj t = text "rts_get" <> text (showFFIType t)
 583
 584 showStgType :: Type -> SDoc
 585 showStgType t = text "Hs" <> text (showFFIType t)
 586
 587 showFFIType :: Type -> String
 588 showFFIType t = getOccString (getName tc)
 589  where
 590   tc = case tcSplitTyConApp_maybe (repType t) of
 591             Just (tc,_) -> tc
 592             Nothing     -> pprPanic "showFFIType" (ppr t)
 593
 594 #if !defined(x86_64_TARGET_ARCH)
 595 insertRetAddr CCallConv args = ret_addr_arg : args
 596 insertRetAddr _ args = args
 597 #else
 598 -- On x86_64 we insert the return address after the 6th
 599 -- integer argument, because this is the point at which we
 600 -- need to flush a register argument to the stack (See rts/Adjustor.c for
 601 -- details).
 602 insertRetAddr CCallConv args = go 0 args
 603   where  go 6 args = ret_addr_arg : args
 604          go n (arg@(_,_,_,rep):args)
 605           | I64 <- rep = arg : go (n+1) args
 606           | otherwise  = arg : go n     args
 607          go n [] = []
 608 insertRetAddr _ args = args
 609 #endif
 610
 611 ret_addr_arg = (text "original_return_addr", text "void*", undefined,
 612                 typeMachRep addrPrimTy)
 613
 614 -- This function returns the primitive type associated with the boxed
 615 -- type argument to a foreign export (eg. Int ==> Int#).
 616 getPrimTyOf :: Type -> Type
 617 getPrimTyOf ty
 618   | isBoolTy rep_ty = intPrimTy
 619   -- Except for Bool, the types we are interested in have a single constructor
 620   -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).
 621   | otherwise =
 622   case splitProductType_maybe rep_ty of
 623      Just (_, _, data_con, [prim_ty]) ->
 624         ASSERT(dataConSourceArity data_con == 1)
 625         ASSERT2(isUnLiftedType prim_ty, ppr prim_ty)
 626         prim_ty
 627      _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)
 628   where
 629         rep_ty = repType ty
 630 \end{code}