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 TyCon
  30 import Coercion
  31 import TcType
  32 import Var
  33
  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 (mkLit (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
 169         Just $ sum (map (machRepByteWidth . typeMachRep . getPrimTyOf) fe_arg_tys)
 170 fun_type_arg_stdcall_info _other_conv _
 171   = Nothing
 172 \end{code}
 173
 174
 175 %************************************************************************
 176 %*                                                                      *
 177 \subsection{Foreign calls}
 178 %*                                                                      *
 179 %************************************************************************
 180
 181 \begin{code}
 182 dsFCall :: Id -> ForeignCall -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
 183 dsFCall fn_id fcall = do
 184     let
 185         ty                   = idType fn_id
 186         (tvs, fun_ty)        = tcSplitForAllTys ty
 187         (arg_tys, io_res_ty) = tcSplitFunTys fun_ty
 188                 -- Must use tcSplit* functions because we want to
 189                 -- see that (IO t) in the corner
 190
 191     args <- newSysLocalsDs arg_tys
 192     (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args)
 193
 194     let
 195         work_arg_ids  = [v | Var v <- val_args] -- All guaranteed to be vars
 196
 197         forDotnet =
 198          case fcall of
 199            DNCall{} -> True
 200            _        -> False
 201
 202         topConDs
 203           | forDotnet = Just <$> dsLookupGlobalId checkDotnetResName
 204           | otherwise = return Nothing
 205
 206         augmentResultDs
 207           | forDotnet = do
 208                 return (\ (mb_res_ty, resWrap) ->
 209                               case mb_res_ty of
 210                                 Nothing -> (Just (mkTyConApp (tupleTyCon Unboxed 1)
 211                                                              [ addrPrimTy ]),
 212                                                  resWrap)
 213                                 Just x  -> (Just (mkTyConApp (tupleTyCon Unboxed 2)
 214                                                              [ x, addrPrimTy ]),
 215                                                  resWrap))
 216           | otherwise = return id
 217
 218     augment <- augmentResultDs
 219     topCon <- topConDs
 220     (ccall_result_ty, res_wrapper) <- boxResult augment topCon io_res_ty
 221
 222     ccall_uniq <- newUnique
 223     work_uniq  <- newUnique
 224     let
 225         -- Build the worker
 226         worker_ty     = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
 227         the_ccall_app = mkFCall ccall_uniq fcall val_args ccall_result_ty
 228         work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)
 229         work_id       = mkSysLocal (fsLit "$wccall") work_uniq worker_ty
 230
 231         -- Build the wrapper
 232         work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
 233         wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
 234         wrap_rhs     = mkInlineMe (mkLams (tvs ++ args) wrapper_body)
 235
 236     return ([(work_id, work_rhs), (fn_id, wrap_rhs)], empty, empty)
 237 \end{code}
 238
 239
 240 %************************************************************************
 241 %*                                                                      *
 242 \subsection{Foreign export}
 243 %*                                                                      *
 244 %************************************************************************
 245
 246 The function that does most of the work for `@foreign export@' declarations.
 247 (see below for the boilerplate code a `@foreign export@' declaration expands
 248  into.)
 249
 250 For each `@foreign export foo@' in a module M we generate:
 251 \begin{itemize}
 252 \item a C function `@foo@', which calls
 253 \item a Haskell stub `@M.$ffoo@', which calls
 254 \end{itemize}
 255 the user-written Haskell function `@M.foo@'.
 256
 257 \begin{code}
 258 dsFExport :: Id                 -- Either the exported Id,
 259                                 -- or the foreign-export-dynamic constructor
 260           -> Type               -- The type of the thing callable from C
 261           -> CLabelString       -- The name to export to C land
 262           -> CCallConv
 263           -> Bool               -- True => foreign export dynamic
 264                                 --         so invoke IO action that's hanging off
 265                                 --         the first argument's stable pointer
 266           -> DsM ( SDoc         -- contents of Module_stub.h
 267                  , SDoc         -- contents of Module_stub.c
 268                  , String       -- string describing type to pass to createAdj.
 269                  , Int          -- size of args to stub function
 270                  )
 271
 272 dsFExport fn_id ty ext_name cconv isDyn=  do
 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
 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     (res_ty,             -- t
 285      is_IO_res_ty) <-    -- Bool
 286         case tcSplitIOType_maybe orig_res_ty of
 287            Just (_ioTyCon, res_ty, _co) -> return (res_ty, True)
 288                    -- The function already returns IO t
 289                    -- ToDo: what about the coercion?
 290            Nothing                    -> return (orig_res_ty, False)
 291                    -- The function returns t
 292
 293     return $
 294       mkFExportCBits ext_name
 295                      (if isDyn then Nothing else Just fn_id)
 296                      fe_arg_tys res_ty is_IO_res_ty cconv
 297 \end{code}
 298
 299 @foreign import "wrapper"@ (previously "foreign export dynamic") lets
 300 you dress up Haskell IO actions of some fixed type behind an
 301 externally callable interface (i.e., as a C function pointer). Useful
 302 for callbacks and stuff.
 303
 304 \begin{verbatim}
 305 type Fun = Bool -> Int -> IO Int
 306 foreign import "wrapper" f :: Fun -> IO (FunPtr Fun)
 307
 308 -- Haskell-visible constructor, which is generated from the above:
 309 -- SUP: No check for NULL from createAdjustor anymore???
 310
 311 f :: Fun -> IO (FunPtr Fun)
 312 f cback =
 313    bindIO (newStablePtr cback)
 314           (\StablePtr sp# -> IO (\s1# ->
 315               case _ccall_ createAdjustor cconv sp# ``f_helper'' <arg info> s1# of
 316                  (# s2#, a# #) -> (# s2#, A# a# #)))
 317
 318 foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun)
 319
 320 -- and the helper in C:
 321
 322 f_helper(StablePtr s, HsBool b, HsInt i)
 323 {
 324         rts_evalIO(rts_apply(rts_apply(deRefStablePtr(s),
 325                                        rts_mkBool(b)), rts_mkInt(i)));
 326 }
 327 \end{verbatim}
 328
 329 \begin{code}
 330 dsFExportDynamic :: Id
 331                  -> CCallConv
 332                  -> DsM ([Binding], SDoc, SDoc)
 333 dsFExportDynamic id cconv = do
 334     fe_id <-  newSysLocalDs ty
 335     mod <- getModuleDs
 336     let
 337         -- hack: need to get at the name of the C stub we're about to generate.
 338         fe_nm    = mkFastString (unpackFS (zEncodeFS (moduleNameFS (moduleName mod))) ++ "_" ++ toCName fe_id)
 339
 340     cback <- newSysLocalDs arg_ty
 341     newStablePtrId <- dsLookupGlobalId newStablePtrName
 342     stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName
 343     let
 344         stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]
 345         export_ty     = mkFunTy stable_ptr_ty arg_ty
 346     bindIOId <- dsLookupGlobalId bindIOName
 347     stbl_value <- newSysLocalDs stable_ptr_ty
 348     (h_code, c_code, typestring, args_size) <- dsFExport id export_ty fe_nm cconv True
 349     let
 350          {-
 351           The arguments to the external function which will
 352           create a little bit of (template) code on the fly
 353           for allowing the (stable pointed) Haskell closure
 354           to be entered using an external calling convention
 355           (stdcall, ccall).
 356          -}
 357         adj_args      = [ mkIntLitInt (ccallConvToInt cconv)
 358                         , Var stbl_value
 359                         , mkLit (MachLabel fe_nm mb_sz_args)
 360                         , mkLit (mkStringLit typestring)
 361                         ]
 362           -- name of external entry point providing these services.
 363           -- (probably in the RTS.)
 364         adjustor   = fsLit "createAdjustor"
 365
 366           -- Determine the number of bytes of arguments to the stub function,
 367           -- so that we can attach the '@N' suffix to its label if it is a
 368           -- stdcall on Windows.
 369         mb_sz_args = case cconv of
 370                         StdCallConv -> Just args_size
 371                         _           -> Nothing
 372
 373     ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])
 374         -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
 375
 376     let io_app = mkLams tvs                $
 377                  Lam cback                 $
 378                  mkCoerceI (mkSymCoI co)   $
 379                  mkApps (Var bindIOId)
 380                         [ Type stable_ptr_ty
 381                         , Type res_ty
 382                         , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
 383                         , Lam stbl_value ccall_adj
 384                         ]
 385
 386         fed = (id `setInlinePragma` NeverActive, io_app)
 387                -- Never inline the f.e.d. function, because the litlit
 388                -- might not be in scope in other modules.
 389
 390     return ([fed], h_code, c_code)
 391
 392  where
 393   ty                       = idType id
 394   (tvs,sans_foralls)       = tcSplitForAllTys ty
 395   ([arg_ty], fn_res_ty)    = tcSplitFunTys sans_foralls
 396   Just (io_tc, res_ty, co) = tcSplitIOType_maybe fn_res_ty
 397         -- Must have an IO type; hence Just
 398         -- co : fn_res_ty ~ IO res_ty
 399
 400 toCName :: Id -> String
 401 toCName i = showSDoc (pprCode CStyle (ppr (idName i)))
 402 \end{code}
 403
 404 %*
 405 %
 406 \subsection{Generating @foreign export@ stubs}
 407 %
 408 %*
 409
 410 For each @foreign export@ function, a C stub function is generated.
 411 The C stub constructs the application of the exported Haskell function
 412 using the hugs/ghc rts invocation API.
 413
 414 \begin{code}
 415 mkFExportCBits :: FastString
 416                -> Maybe Id      -- Just==static, Nothing==dynamic
 417                -> [Type]
 418                -> Type
 419                -> Bool          -- True <=> returns an IO type
 420                -> CCallConv
 421                -> (SDoc,
 422                    SDoc,
 423                    String,      -- the argument reps
 424                    Int          -- total size of arguments
 425                   )
 426 mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
 427  = (header_bits, c_bits, type_string,
 428     sum [ machRepByteWidth rep | (_,_,_,rep) <- aug_arg_info] -- all the args
 429     )
 430  where
 431   -- list the arguments to the C function
 432   arg_info :: [(SDoc,           -- arg name
 433                 SDoc,           -- C type
 434                 Type,           -- Haskell type
 435                 MachRep)]       -- the MachRep
 436   arg_info  = [ let stg_type = showStgType ty in
 437                 (arg_cname n stg_type,
 438                  stg_type,
 439                  ty,
 440                  typeMachRep (getPrimTyOf ty))
 441               | (ty,n) <- zip arg_htys [1::Int ..] ]
 442
 443   arg_cname n stg_ty
 444         | libffi    = char '*' <> parens (stg_ty <> char '*') <>
 445                       ptext (sLit "args") <> brackets (int (n-1))
 446         | otherwise = text ('a':show n)
 447
 448   -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled
 449   libffi = cLibFFI && isNothing maybe_target
 450
 451   type_string
 452       -- libffi needs to know the result type too:
 453       | libffi    = primTyDescChar res_hty : arg_type_string
 454       | otherwise = arg_type_string
 455
 456   arg_type_string = [primTyDescChar ty | (_,_,ty,_) <- arg_info]
 457                 -- just the real args
 458
 459   -- add some auxiliary args; the stable ptr in the wrapper case, and
 460   -- a slot for the dummy return address in the wrapper + ccall case
 461   aug_arg_info
 462     | isNothing maybe_target = stable_ptr_arg : insertRetAddr cc arg_info
 463     | otherwise              = arg_info
 464
 465   stable_ptr_arg =
 466         (text "the_stableptr", text "StgStablePtr", undefined,
 467          typeMachRep (mkStablePtrPrimTy alphaTy))
 468
 469   -- stuff to do with the return type of the C function
 470   res_hty_is_unit = res_hty `coreEqType` unitTy -- Look through any newtypes
 471
 472   cResType | res_hty_is_unit = text "void"
 473            | otherwise       = showStgType res_hty
 474
 475   -- Now we can cook up the prototype for the exported function.
 476   pprCconv = case cc of
 477                 CCallConv   -> empty
 478                 StdCallConv -> text (ccallConvAttribute cc)
 479                 CmmCallConv -> panic "mkFExportCBits/pprCconv CmmCallConv"
 480
 481   header_bits = ptext (sLit "extern") <+> fun_proto <> semi
 482
 483   fun_args
 484     | null aug_arg_info = text "void"
 485     | otherwise         = hsep $ punctuate comma
 486                                $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info
 487
 488   fun_proto
 489     | libffi
 490       = ptext (sLit "void") <+> ftext c_nm <>
 491           parens (ptext (sLit "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr"))
 492     | otherwise
 493       = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args
 494
 495   -- the target which will form the root of what we ask rts_evalIO to run
 496   the_cfun
 497      = case maybe_target of
 498           Nothing    -> text "(StgClosure*)deRefStablePtr(the_stableptr)"
 499           Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"
 500
 501   cap = text "cap" <> comma
 502
 503   -- the expression we give to rts_evalIO
 504   expr_to_run
 505      = foldl appArg the_cfun arg_info -- NOT aug_arg_info
 506        where
 507           appArg acc (arg_cname, _, arg_hty, _)
 508              = text "rts_apply"
 509                <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname))
 510
 511   -- various other bits for inside the fn
 512   declareResult = text "HaskellObj ret;"
 513   declareCResult | res_hty_is_unit = empty
 514                  | otherwise       = cResType <+> text "cret;"
 515
 516   assignCResult | res_hty_is_unit = empty
 517                 | otherwise       =
 518                         text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi
 519
 520   -- an extern decl for the fn being called
 521   extern_decl
 522      = case maybe_target of
 523           Nothing -> empty
 524           Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi
 525
 526
 527   -- finally, the whole darn thing
 528   c_bits =
 529     space $$
 530     extern_decl $$
 531     fun_proto  $$
 532     vcat
 533      [ lbrace
 534      ,   ptext (sLit "Capability *cap;")
 535      ,   declareResult
 536      ,   declareCResult
 537      ,   text "cap = rts_lock();"
 538           -- create the application + perform it.
 539      ,   ptext (sLit "cap=rts_evalIO") <> parens (
 540                 cap <>
 541                 ptext (sLit "rts_apply") <> parens (
 542                     cap <>
 543                     text "(HaskellObj)"
 544                  <> ptext (if is_IO_res_ty
 545                                 then (sLit "runIO_closure")
 546                                 else (sLit "runNonIO_closure"))
 547                  <> comma
 548                  <> expr_to_run
 549                 ) <+> comma
 550                <> text "&ret"
 551              ) <> semi
 552      ,   ptext (sLit "rts_checkSchedStatus") <> parens (doubleQuotes (ftext c_nm)
 553                                                 <> comma <> text "cap") <> semi
 554      ,   assignCResult
 555      ,   ptext (sLit "rts_unlock(cap);")
 556      ,   if res_hty_is_unit then empty
 557             else if libffi
 558                   then char '*' <> parens (cResType <> char '*') <>
 559                        ptext (sLit "resp = cret;")
 560                   else ptext (sLit "return cret;")
 561      , rbrace
 562      ]
 563
 564
 565 foreignExportInitialiser :: Id -> SDoc
 566 foreignExportInitialiser hs_fn =
 567    -- Initialise foreign exports by registering a stable pointer from an
 568    -- __attribute__((constructor)) function.
 569    -- The alternative is to do this from stginit functions generated in
 570    -- codeGen/CodeGen.lhs; however, stginit functions have a negative impact
 571    -- on binary sizes and link times because the static linker will think that
 572    -- all modules that are imported directly or indirectly are actually used by
 573    -- the program.
 574    -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)
 575    vcat
 576     [ text "static void stginit_export_" <> ppr hs_fn
 577          <> text "() __attribute__((constructor));"
 578     , text "static void stginit_export_" <> ppr hs_fn <> text "()"
 579     , braces (text "getStablePtr"
 580        <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure")
 581        <> semi)
 582     ]
 583
 584
 585 -- NB. the calculation here isn't strictly speaking correct.
 586 -- We have a primitive Haskell type (eg. Int#, Double#), and
 587 -- we want to know the size, when passed on the C stack, of
 588 -- the associated C type (eg. HsInt, HsDouble).  We don't have
 589 -- this information to hand, but we know what GHC's conventions
 590 -- are for passing around the primitive Haskell types, so we
 591 -- use that instead.  I hope the two coincide --SDM
 592 typeMachRep :: Type -> MachRep
 593 typeMachRep ty = argMachRep (typeCgRep ty)
 594
 595 mkHObj :: Type -> SDoc
 596 mkHObj t = text "rts_mk" <> text (showFFIType t)
 597
 598 unpackHObj :: Type -> SDoc
 599 unpackHObj t = text "rts_get" <> text (showFFIType t)
 600
 601 showStgType :: Type -> SDoc
 602 showStgType t = text "Hs" <> text (showFFIType t)
 603
 604 showFFIType :: Type -> String
 605 showFFIType t = getOccString (getName tc)
 606  where
 607   tc = case tcSplitTyConApp_maybe (repType t) of
 608             Just (tc,_) -> tc
 609             Nothing     -> pprPanic "showFFIType" (ppr t)
 610
 611 insertRetAddr :: CCallConv -> [(SDoc, SDoc, Type, MachRep)]
 612                            -> [(SDoc, SDoc, Type, MachRep)]
 613 #if !defined(x86_64_TARGET_ARCH)
 614 insertRetAddr CCallConv args = ret_addr_arg : args
 615 insertRetAddr _ args = args
 616 #else
 617 -- On x86_64 we insert the return address after the 6th
 618 -- integer argument, because this is the point at which we
 619 -- need to flush a register argument to the stack (See rts/Adjustor.c for
 620 -- details).
 621 insertRetAddr CCallConv args = go 0 args
 622   where  go :: Int -> [(SDoc, SDoc, Type, MachRep)]
 623                    -> [(SDoc, SDoc, Type, MachRep)]
 624          go 6 args = ret_addr_arg : args
 625          go n (arg@(_,_,_,rep):args)
 626           | I64 <- rep = arg : go (n+1) args
 627           | otherwise  = arg : go n     args
 628          go _ [] = []
 629 insertRetAddr _ args = args
 630 #endif
 631
 632 ret_addr_arg :: (SDoc, SDoc, Type, MachRep)
 633 ret_addr_arg = (text "original_return_addr", text "void*", undefined,
 634                 typeMachRep addrPrimTy)
 635
 636 -- This function returns the primitive type associated with the boxed
 637 -- type argument to a foreign export (eg. Int ==> Int#).
 638 getPrimTyOf :: Type -> Type
 639 getPrimTyOf ty
 640   | isBoolTy rep_ty = intPrimTy
 641   -- Except for Bool, the types we are interested in have a single constructor
 642   -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).
 643   | otherwise =
 644   case splitProductType_maybe rep_ty of
 645      Just (_, _, data_con, [prim_ty]) ->
 646         ASSERT(dataConSourceArity data_con == 1)
 647         ASSERT2(isUnLiftedType prim_ty, ppr prim_ty)
 648         prim_ty
 649      _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)
 650   where
 651         rep_ty = repType ty
 652
 653 -- represent a primitive type as a Char, for building a string that
 654 -- described the foreign function type.  The types are size-dependent,
 655 -- e.g. 'W' is a signed 32-bit integer.
 656 primTyDescChar :: Type -> Char
 657 primTyDescChar ty
 658  | ty `coreEqType` unitTy = 'v'
 659  | otherwise
 660  = case typePrimRep (getPrimTyOf ty) of
 661      IntRep      -> signed_word
 662      WordRep     -> unsigned_word
 663      Int64Rep    -> 'L'
 664      Word64Rep   -> 'l'
 665      AddrRep     -> 'p'
 666      FloatRep    -> 'f'
 667      DoubleRep   -> 'd'
 668      _           -> pprPanic "primTyDescChar" (ppr ty)
 669   where
 670     (signed_word, unsigned_word)
 671        | wORD_SIZE == 4  = ('W','w')
 672        | wORD_SIZE == 8  = ('L','l')
 673        | otherwise       = panic "primTyDescChar"
 674 \end{code}