compiler/deSugar/DsForeign.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The AQUA Project, Glasgow University, 1998
   4 %
   5
   6 Desugaring foreign declarations (see also DsCCall).
   7
   8 \begin{code}
   9 module DsForeign ( dsForeigns ) where
  10
  11 #include "HsVersions.h"
  12 import TcRnMonad        -- temp
  13
  14 import CoreSyn
  15
  16 import DsCCall
  17 import DsMonad
  18
  19 import HsSyn
  20 import DataCon
  21 import CoreUtils
  22 import Id
  23 import Literal
  24 import Module
  25 import Name
  26 import Type
  27 import TyCon
  28 import Coercion
  29 import TcType
  30 import Var
  31
  32 import CmmExpr
  33 import CmmUtils
  34 import HscTypes
  35 import ForeignCall
  36 import TysWiredIn
  37 import TysPrim
  38 import PrelNames
  39 import BasicTypes
  40 import SrcLoc
  41 import Outputable
  42 import FastString
  43 import Config
  44 import Constants
  45
  46 import Data.Maybe
  47 import Data.List
  48 \end{code}
  49
  50 Desugaring of @foreign@ declarations is naturally split up into
  51 parts, an @import@ and an @export@  part. A @foreign import@
  52 declaration
  53 \begin{verbatim}
  54   foreign import cc nm f :: prim_args -> IO prim_res
  55 \end{verbatim}
  56 is the same as
  57 \begin{verbatim}
  58   f :: prim_args -> IO prim_res
  59   f a1 ... an = _ccall_ nm cc a1 ... an
  60 \end{verbatim}
  61 so we reuse the desugaring code in @DsCCall@ to deal with these.
  62
  63 \begin{code}
  64 type Binding = (Id, CoreExpr)   -- No rec/nonrec structure;
  65                                 -- the occurrence analyser will sort it all out
  66
  67 dsForeigns :: [LForeignDecl Id]
  68            -> DsM (ForeignStubs, [Binding])
  69 dsForeigns []
  70   = return (NoStubs, [])
  71 dsForeigns fos = do
  72     fives <- mapM do_ldecl fos
  73     let
  74         (hs, cs, idss, bindss) = unzip4 fives
  75         fe_ids = concat idss
  76         fe_init_code = map foreignExportInitialiser fe_ids
  77     --
  78     return (ForeignStubs
  79              (vcat hs)
  80              (vcat cs $$ vcat fe_init_code),
  81            (concat bindss))
  82   where
  83    do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl)
  84
  85    do_decl (ForeignImport id _ spec) = do
  86       traceIf (text "fi start" <+> ppr id)
  87       (bs, h, c) <- dsFImport (unLoc id) spec
  88       traceIf (text "fi end" <+> ppr id)
  89       return (h, c, [], bs)
  90
  91    do_decl (ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv))) = do
  92       (h, c, _, _) <- dsFExport id (idType id) ext_nm cconv False
  93       return (h, c, [id], [])
  94
  95    do_decl d = pprPanic "dsForeigns/do_decl" (ppr d)
  96 \end{code}
  97
  98
  99 %************************************************************************
 100 %*                                                                      *
 101 \subsection{Foreign import}
 102 %*                                                                      *
 103 %************************************************************************
 104
 105 Desugaring foreign imports is just the matter of creating a binding
 106 that on its RHS unboxes its arguments, performs the external call
 107 (using the @CCallOp@ primop), before boxing the result up and returning it.
 108
 109 However, we create a worker/wrapper pair, thus:
 110
 111         foreign import f :: Int -> IO Int
 112 ==>
 113         f x = IO ( \s -> case x of { I# x# ->
 114                          case fw s x# of { (# s1, y# #) ->
 115                          (# s1, I# y# #)}})
 116
 117         fw s x# = ccall f s x#
 118
 119 The strictness/CPR analyser won't do this automatically because it doesn't look
 120 inside returned tuples; but inlining this wrapper is a Really Good Idea
 121 because it exposes the boxing to the call site.
 122
 123 \begin{code}
 124 dsFImport :: Id
 125           -> ForeignImport
 126           -> DsM ([Binding], SDoc, SDoc)
 127 dsFImport id (CImport cconv safety _ _ spec) = do
 128     (ids, h, c) <- dsCImport id spec cconv safety
 129     return (ids, h, c)
 130
 131   -- FIXME: the `lib' field is needed for .NET ILX generation when invoking
 132   --        routines that are external to the .NET runtime, but GHC doesn't
 133   --        support such calls yet; if `nullFastString lib', the value was not given
 134 dsFImport id (DNImport spec) = do
 135     (ids, h, c) <- dsFCall id (DNCall spec)
 136     return (ids, h, c)
 137
 138 dsCImport :: Id
 139           -> CImportSpec
 140           -> CCallConv
 141           -> Safety
 142           -> DsM ([Binding], SDoc, SDoc)
 143 dsCImport id (CLabel cid) cconv _ = do
 144    let ty = idType id
 145    (resTy, foRhs) <- resultWrapper ty
 146    ASSERT(fromJust resTy `coreEqType` addrPrimTy)    -- typechecker ensures this
 147     let
 148         rhs = foRhs (Lit (MachLabel cid stdcall_info))
 149         stdcall_info = fun_type_arg_stdcall_info cconv ty
 150     in
 151     return ([(id, rhs)], empty, empty)
 152
 153 dsCImport id (CFunction target) cconv safety
 154   = dsFCall id (CCall (CCallSpec target cconv safety))
 155 dsCImport id CWrapper cconv _
 156   = dsFExportDynamic id cconv
 157
 158 -- For stdcall labels, if the type was a FunPtr or newtype thereof,
 159 -- then we need to calculate the size of the arguments in order to add
 160 -- the @n suffix to the label.
 161 fun_type_arg_stdcall_info :: CCallConv -> Type -> Maybe Int
 162 fun_type_arg_stdcall_info StdCallConv ty
 163   | Just (tc,[arg_ty]) <- splitTyConApp_maybe (repType ty),
 164     tyConUnique tc == funPtrTyConKey
 165   = let
 166        (_tvs,sans_foralls)        = tcSplitForAllTys arg_ty
 167        (fe_arg_tys, _orig_res_ty) = tcSplitFunTys sans_foralls
 168     in Just $ sum (map (widthInBytes . typeWidth . typeCmmType . getPrimTyOf) fe_arg_tys)
 169 fun_type_arg_stdcall_info _other_conv _
 170   = Nothing
 171 \end{code}
 172
 173
 174 %************************************************************************
 175 %*                                                                      *
 176 \subsection{Foreign calls}
 177 %*                                                                      *
 178 %************************************************************************
 179
 180 \begin{code}
 181 dsFCall :: Id -> ForeignCall -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
 182 dsFCall fn_id fcall = do
 183     let
 184         ty                   = idType fn_id
 185         (tvs, fun_ty)        = tcSplitForAllTys ty
 186         (arg_tys, io_res_ty) = tcSplitFunTys fun_ty
 187                 -- Must use tcSplit* functions because we want to
 188                 -- see that (IO t) in the corner
 189
 190     args <- newSysLocalsDs arg_tys
 191     (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args)
 192
 193     let
 194         work_arg_ids  = [v | Var v <- val_args] -- All guaranteed to be vars
 195
 196         forDotnet =
 197          case fcall of
 198            DNCall{} -> True
 199            _        -> False
 200
 201         topConDs
 202           | forDotnet = Just <$> dsLookupGlobalId checkDotnetResName
 203           | otherwise = return Nothing
 204
 205         augmentResultDs
 206           | forDotnet = do
 207                 return (\ (mb_res_ty, resWrap) ->
 208                               case mb_res_ty of
 209                                 Nothing -> (Just (mkTyConApp (tupleTyCon Unboxed 1)
 210                                                              [ addrPrimTy ]),
 211                                                  resWrap)
 212                                 Just x  -> (Just (mkTyConApp (tupleTyCon Unboxed 2)
 213                                                              [ x, addrPrimTy ]),
 214                                                  resWrap))
 215           | otherwise = return id
 216
 217     augment <- augmentResultDs
 218     topCon <- topConDs
 219     (ccall_result_ty, res_wrapper) <- boxResult augment topCon io_res_ty
 220
 221     ccall_uniq <- newUnique
 222     work_uniq  <- newUnique
 223     let
 224         -- Build the worker
 225         worker_ty     = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
 226         the_ccall_app = mkFCall ccall_uniq fcall val_args ccall_result_ty
 227         work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)
 228         work_id       = 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
 235     return ([(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                  , String       -- string describing type to pass to createAdj.
 268                  , Int          -- size of args to stub function
 269                  )
 270
 271 dsFExport fn_id ty ext_name cconv isDyn=  do
 272     let
 273        (_tvs,sans_foralls)             = tcSplitForAllTys ty
 274        (fe_arg_tys', orig_res_ty)      = tcSplitFunTys sans_foralls
 275        -- We must use tcSplits here, because we want to see
 276        -- the (IO t) in the corner of the type!
 277        fe_arg_tys | isDyn     = tail fe_arg_tys'
 278                   | otherwise = fe_arg_tys'
 279
 280        -- Look at the result type of the exported function, orig_res_ty
 281        -- If it's IO t, return         (t, True)
 282        -- If it's plain t, return      (t, False)
 283     (res_ty,             -- t
 284      is_IO_res_ty) <-    -- Bool
 285         case tcSplitIOType_maybe orig_res_ty of
 286            Just (_ioTyCon, res_ty, _co) -> return (res_ty, True)
 287                    -- The function already returns IO t
 288                    -- ToDo: what about the coercion?
 289            Nothing                    -> return (orig_res_ty, False)
 290                    -- The function returns t
 291
 292     return $
 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 = do
 333     fe_id <-  newSysLocalDs ty
 334     mod <- getModuleDs
 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
 339     cback <- newSysLocalDs arg_ty
 340     newStablePtrId <- dsLookupGlobalId newStablePtrName
 341     stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName
 342     let
 343         stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]
 344         export_ty     = mkFunTy stable_ptr_ty arg_ty
 345     bindIOId <- dsLookupGlobalId bindIOName
 346     stbl_value <- newSysLocalDs stable_ptr_ty
 347     (h_code, c_code, typestring, args_size) <- dsFExport id export_ty fe_nm cconv True
 348     let
 349          {-
 350           The arguments to the external function which will
 351           create a little bit of (template) code on the fly
 352           for allowing the (stable pointed) Haskell closure
 353           to be entered using an external calling convention
 354           (stdcall, ccall).
 355          -}
 356         adj_args      = [ mkIntLitInt (ccallConvToInt cconv)
 357                         , Var stbl_value
 358                         , Lit (MachLabel fe_nm mb_sz_args)
 359                         , Lit (mkMachString typestring)
 360                         ]
 361           -- name of external entry point providing these services.
 362           -- (probably in the RTS.)
 363         adjustor   = fsLit "createAdjustor"
 364
 365           -- Determine the number of bytes of arguments to the stub function,
 366           -- so that we can attach the '@N' suffix to its label if it is a
 367           -- stdcall on Windows.
 368         mb_sz_args = case cconv of
 369                         StdCallConv -> Just args_size
 370                         _           -> Nothing
 371
 372     ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])
 373         -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
 374
 375     let io_app = mkLams tvs                $
 376                  Lam cback                 $
 377                  mkCoerceI (mkSymCoI co)   $
 378                  mkApps (Var bindIOId)
 379                         [ Type stable_ptr_ty
 380                         , Type res_ty
 381                         , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
 382                         , Lam stbl_value ccall_adj
 383                         ]
 384
 385         fed = (id `setInlinePragma` NeverActive, io_app)
 386                -- Never inline the f.e.d. function, because the litlit
 387                -- might not be in scope in other modules.
 388
 389     return ([fed], h_code, c_code)
 390
 391  where
 392   ty                       = idType id
 393   (tvs,sans_foralls)       = tcSplitForAllTys ty
 394   ([arg_ty], fn_res_ty)    = tcSplitFunTys sans_foralls
 395   Just (io_tc, res_ty, co) = tcSplitIOType_maybe fn_res_ty
 396         -- Must have an IO type; hence Just
 397         -- co : fn_res_ty ~ IO res_ty
 398
 399 toCName :: Id -> String
 400 toCName i = showSDoc (pprCode CStyle (ppr (idName i)))
 401 \end{code}
 402
 403 %*
 404 %
 405 \subsection{Generating @foreign export@ stubs}
 406 %
 407 %*
 408
 409 For each @foreign export@ function, a C stub function is generated.
 410 The C stub constructs the application of the exported Haskell function
 411 using the hugs/ghc rts invocation API.
 412
 413 \begin{code}
 414 mkFExportCBits :: FastString
 415                -> Maybe Id      -- Just==static, Nothing==dynamic
 416                -> [Type]
 417                -> Type
 418                -> Bool          -- True <=> returns an IO type
 419                -> CCallConv
 420                -> (SDoc,
 421                    SDoc,
 422                    String,      -- the argument reps
 423                    Int          -- total size of arguments
 424                   )
 425 mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
 426  = (header_bits, c_bits, type_string,
 427     sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args
 428          -- NB. the calculation here isn't strictly speaking correct.
 429          -- We have a primitive Haskell type (eg. Int#, Double#), and
 430          -- we want to know the size, when passed on the C stack, of
 431          -- the associated C type (eg. HsInt, HsDouble).  We don't have
 432          -- this information to hand, but we know what GHC's conventions
 433          -- are for passing around the primitive Haskell types, so we
 434          -- use that instead.  I hope the two coincide --SDM
 435     )
 436  where
 437   -- list the arguments to the C function
 438   arg_info :: [(SDoc,           -- arg name
 439                 SDoc,           -- C type
 440                 Type,           -- Haskell type
 441                 CmmType)]       -- the CmmType
 442   arg_info  = [ let stg_type = showStgType ty in
 443                 (arg_cname n stg_type,
 444                  stg_type,
 445                  ty,
 446                  typeCmmType (getPrimTyOf ty))
 447               | (ty,n) <- zip arg_htys [1::Int ..] ]
 448
 449   arg_cname n stg_ty
 450         | libffi    = char '*' <> parens (stg_ty <> char '*') <>
 451                       ptext (sLit "args") <> brackets (int (n-1))
 452         | otherwise = text ('a':show n)
 453
 454   -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled
 455   libffi = cLibFFI && isNothing maybe_target
 456
 457   type_string
 458       -- libffi needs to know the result type too:
 459       | libffi    = primTyDescChar res_hty : arg_type_string
 460       | otherwise = arg_type_string
 461
 462   arg_type_string = [primTyDescChar ty | (_,_,ty,_) <- arg_info]
 463                 -- just the real args
 464
 465   -- add some auxiliary args; the stable ptr in the wrapper case, and
 466   -- a slot for the dummy return address in the wrapper + ccall case
 467   aug_arg_info
 468     | isNothing maybe_target = stable_ptr_arg : insertRetAddr cc arg_info
 469     | otherwise              = arg_info
 470
 471   stable_ptr_arg =
 472         (text "the_stableptr", text "StgStablePtr", undefined,
 473          typeCmmType (mkStablePtrPrimTy alphaTy))
 474
 475   -- stuff to do with the return type of the C function
 476   res_hty_is_unit = res_hty `coreEqType` unitTy -- Look through any newtypes
 477
 478   cResType | res_hty_is_unit = text "void"
 479            | otherwise       = showStgType res_hty
 480
 481   -- Now we can cook up the prototype for the exported function.
 482   pprCconv = case cc of
 483                 CCallConv   -> empty
 484                 StdCallConv -> text (ccallConvAttribute cc)
 485                 CmmCallConv -> panic "mkFExportCBits/pprCconv CmmCallConv"
 486
 487   header_bits = ptext (sLit "extern") <+> fun_proto <> semi
 488
 489   fun_args
 490     | null aug_arg_info = text "void"
 491     | otherwise         = hsep $ punctuate comma
 492                                $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info
 493
 494   fun_proto
 495     | libffi
 496       = ptext (sLit "void") <+> ftext c_nm <>
 497           parens (ptext (sLit "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr"))
 498     | otherwise
 499       = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args
 500
 501   -- the target which will form the root of what we ask rts_evalIO to run
 502   the_cfun
 503      = case maybe_target of
 504           Nothing    -> text "(StgClosure*)deRefStablePtr(the_stableptr)"
 505           Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"
 506
 507   cap = text "cap" <> comma
 508
 509   -- the expression we give to rts_evalIO
 510   expr_to_run
 511      = foldl appArg the_cfun arg_info -- NOT aug_arg_info
 512        where
 513           appArg acc (arg_cname, _, arg_hty, _)
 514              = text "rts_apply"
 515                <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname))
 516
 517   -- various other bits for inside the fn
 518   declareResult = text "HaskellObj ret;"
 519   declareCResult | res_hty_is_unit = empty
 520                  | otherwise       = cResType <+> text "cret;"
 521
 522   assignCResult | res_hty_is_unit = empty
 523                 | otherwise       =
 524                         text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi
 525
 526   -- an extern decl for the fn being called
 527   extern_decl
 528      = case maybe_target of
 529           Nothing -> empty
 530           Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi
 531
 532
 533   -- finally, the whole darn thing
 534   c_bits =
 535     space $$
 536     extern_decl $$
 537     fun_proto  $$
 538     vcat
 539      [ lbrace
 540      ,   ptext (sLit "Capability *cap;")
 541      ,   declareResult
 542      ,   declareCResult
 543      ,   text "cap = rts_lock();"
 544           -- create the application + perform it.
 545      ,   ptext (sLit "cap=rts_evalIO") <> parens (
 546                 cap <>
 547                 ptext (sLit "rts_apply") <> parens (
 548                     cap <>
 549                     text "(HaskellObj)"
 550                  <> ptext (if is_IO_res_ty
 551                                 then (sLit "runIO_closure")
 552                                 else (sLit "runNonIO_closure"))
 553                  <> comma
 554                  <> expr_to_run
 555                 ) <+> comma
 556                <> text "&ret"
 557              ) <> semi
 558      ,   ptext (sLit "rts_checkSchedStatus") <> parens (doubleQuotes (ftext c_nm)
 559                                                 <> comma <> text "cap") <> semi
 560      ,   assignCResult
 561      ,   ptext (sLit "rts_unlock(cap);")
 562      ,   if res_hty_is_unit then empty
 563             else if libffi
 564                   then char '*' <> parens (cResType <> char '*') <>
 565                        ptext (sLit "resp = cret;")
 566                   else ptext (sLit "return cret;")
 567      , rbrace
 568      ]
 569
 570
 571 foreignExportInitialiser :: Id -> SDoc
 572 foreignExportInitialiser hs_fn =
 573    -- Initialise foreign exports by registering a stable pointer from an
 574    -- __attribute__((constructor)) function.
 575    -- The alternative is to do this from stginit functions generated in
 576    -- codeGen/CodeGen.lhs; however, stginit functions have a negative impact
 577    -- on binary sizes and link times because the static linker will think that
 578    -- all modules that are imported directly or indirectly are actually used by
 579    -- the program.
 580    -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)
 581    vcat
 582     [ text "static void stginit_export_" <> ppr hs_fn
 583          <> text "() __attribute__((constructor));"
 584     , text "static void stginit_export_" <> ppr hs_fn <> text "()"
 585     , braces (text "getStablePtr"
 586        <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure")
 587        <> semi)
 588     ]
 589
 590
 591 mkHObj :: Type -> SDoc
 592 mkHObj t = text "rts_mk" <> text (showFFIType t)
 593
 594 unpackHObj :: Type -> SDoc
 595 unpackHObj t = text "rts_get" <> text (showFFIType t)
 596
 597 showStgType :: Type -> SDoc
 598 showStgType t = text "Hs" <> text (showFFIType t)
 599
 600 showFFIType :: Type -> String
 601 showFFIType t = getOccString (getName tc)
 602  where
 603   tc = case tcSplitTyConApp_maybe (repType t) of
 604             Just (tc,_) -> tc
 605             Nothing     -> pprPanic "showFFIType" (ppr t)
 606
 607 insertRetAddr :: CCallConv -> [(SDoc, SDoc, Type, CmmType)]
 608                            -> [(SDoc, SDoc, Type, CmmType)]
 609 #if !defined(x86_64_TARGET_ARCH)
 610 insertRetAddr CCallConv args = ret_addr_arg : args
 611 insertRetAddr _ args = args
 612 #else
 613 -- On x86_64 we insert the return address after the 6th
 614 -- integer argument, because this is the point at which we
 615 -- need to flush a register argument to the stack (See rts/Adjustor.c for
 616 -- details).
 617 insertRetAddr CCallConv args = go 0 args
 618   where  go :: Int -> [(SDoc, SDoc, Type, CmmType)]
 619                    -> [(SDoc, SDoc, Type, CmmType)]
 620          go 6 args = ret_addr_arg : args
 621          go n (arg@(_,_,_,rep):args)
 622           | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args
 623           | otherwise  = arg : go n     args
 624          go _ [] = []
 625 insertRetAddr _ args = args
 626 #endif
 627
 628 ret_addr_arg :: (SDoc, SDoc, Type, CmmType)
 629 ret_addr_arg = (text "original_return_addr", text "void*", undefined,
 630                 typeCmmType addrPrimTy)
 631
 632 -- This function returns the primitive type associated with the boxed
 633 -- type argument to a foreign export (eg. Int ==> Int#).
 634 getPrimTyOf :: Type -> Type
 635 getPrimTyOf ty
 636   | isBoolTy rep_ty = intPrimTy
 637   -- Except for Bool, the types we are interested in have a single constructor
 638   -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).
 639   | otherwise =
 640   case splitProductType_maybe rep_ty of
 641      Just (_, _, data_con, [prim_ty]) ->
 642         ASSERT(dataConSourceArity data_con == 1)
 643         ASSERT2(isUnLiftedType prim_ty, ppr prim_ty)
 644         prim_ty
 645      _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)
 646   where
 647         rep_ty = repType ty
 648
 649 -- represent a primitive type as a Char, for building a string that
 650 -- described the foreign function type.  The types are size-dependent,
 651 -- e.g. 'W' is a signed 32-bit integer.
 652 primTyDescChar :: Type -> Char
 653 primTyDescChar ty
 654  | ty `coreEqType` unitTy = 'v'
 655  | otherwise
 656  = case typePrimRep (getPrimTyOf ty) of
 657      IntRep      -> signed_word
 658      WordRep     -> unsigned_word
 659      Int64Rep    -> 'L'
 660      Word64Rep   -> 'l'
 661      AddrRep     -> 'p'
 662      FloatRep    -> 'f'
 663      DoubleRep   -> 'd'
 664      _           -> pprPanic "primTyDescChar" (ppr ty)
 665   where
 666     (signed_word, unsigned_word)
 667        | wORD_SIZE == 4  = ('W','w')
 668        | wORD_SIZE == 8  = ('L','l')
 669        | otherwise       = panic "primTyDescChar"
 670 \end{code}