compiler/deSugar/DsForeign.lhs

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