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