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 Coercion
  37 import TcType
  38
  39 import HscTypes
  40 import ForeignCall
  41 import TysWiredIn
  42 import TysPrim
  43 import PrelNames
  44 import BasicTypes
  45 import SrcLoc
  46 import Outputable
  47 import FastString
  48 import Config
  49 import Constants
  50
  51 import Data.Maybe
  52 import Data.List
  53 \end{code}
  54
  55 Desugaring of @foreign@ declarations is naturally split up into
  56 parts, an @import@ and an @export@  part. A @foreign import@
  57 declaration
  58 \begin{verbatim}
  59   foreign import cc nm f :: prim_args -> IO prim_res
  60 \end{verbatim}
  61 is the same as
  62 \begin{verbatim}
  63   f :: prim_args -> IO prim_res
  64   f a1 ... an = _ccall_ nm cc a1 ... an
  65 \end{verbatim}
  66 so we reuse the desugaring code in @DsCCall@ to deal with these.
  67
  68 \begin{code}
  69 type Binding = (Id, CoreExpr)   -- No rec/nonrec structure;
  70                                 -- the occurrence analyser will sort it all out
  71
  72 dsForeigns :: [LForeignDecl Id]
  73            -> DsM (ForeignStubs, [Binding])
  74 dsForeigns []
  75   = return (NoStubs, [])
  76 dsForeigns fos = do
  77     fives <- mapM do_ldecl fos
  78     let
  79         (hs, cs, hdrs, idss, bindss) = unzip5 fives
  80         fe_ids = concat idss
  81         fe_init_code = map foreignExportInitialiser fe_ids
  82     --
  83     return (ForeignStubs
  84              (vcat hs)
  85              (vcat cs $$ vcat fe_init_code)
  86              (nub (concat hdrs)),
  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, mbhd) <- dsFImport (unLoc id) spec
  94       traceIf (text "fi end" <+> ppr id)
  95       return (h, c, maybeToList mbhd, [], 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, Maybe FastString)
 131 dsFImport id (CImport cconv safety header lib spec) = do
 132     (ids, h, c) <- dsCImport id spec cconv safety no_hdrs
 133     return (ids, h, c, if no_hdrs then Nothing else Just header)
 134   where
 135     no_hdrs = nullFS header
 136
 137   -- FIXME: the `lib' field is needed for .NET ILX generation when invoking
 138   --        routines that are external to the .NET runtime, but GHC doesn't
 139   --        support such calls yet; if `nullFastString lib', the value was not given
 140 dsFImport id (DNImport spec) = do
 141     (ids, h, c) <- dsFCall id (DNCall spec) True {- No headers -}
 142     return (ids, h, c, Nothing)
 143
 144 dsCImport :: Id
 145           -> CImportSpec
 146           -> CCallConv
 147           -> Safety
 148           -> Bool       -- True <=> no headers in the f.i decl
 149           -> DsM ([Binding], SDoc, SDoc)
 150 dsCImport id (CLabel cid) _ _ no_hdrs = do
 151    (resTy, foRhs) <- resultWrapper (idType id)
 152    ASSERT(fromJust resTy `coreEqType` addrPrimTy)    -- typechecker ensures this
 153     let rhs = foRhs (mkLit (MachLabel cid Nothing)) in
 154     return ([(setImpInline no_hdrs id, rhs)], empty, empty)
 155 dsCImport id (CFunction target) cconv safety no_hdrs
 156   = dsFCall id (CCall (CCallSpec target cconv safety)) no_hdrs
 157 dsCImport id CWrapper cconv _ _
 158   = dsFExportDynamic id cconv
 159
 160 setImpInline :: Bool    -- True <=> No #include headers
 161                         -- in the foreign import declaration
 162              -> Id -> Id
 163 -- If there is a #include header in the foreign import
 164 -- we make the worker non-inlinable, because we currently
 165 -- don't keep the #include stuff in the CCallId, and hence
 166 -- it won't be visible in the importing module, which can be
 167 -- fatal.
 168 -- (The #include stuff is just collected from the foreign import
 169 --  decls in a module.)
 170 -- If you want to do cross-module inlining of the c-calls themselves,
 171 -- put the #include stuff in the package spec, not the foreign
 172 -- import decl.
 173 setImpInline True  id = id
 174 setImpInline False id = id `setInlinePragma` NeverActive
 175 \end{code}
 176
 177
 178 %************************************************************************
 179 %*                                                                      *
 180 \subsection{Foreign calls}
 181 %*                                                                      *
 182 %************************************************************************
 183
 184 \begin{code}
 185 dsFCall fn_id fcall no_hdrs = do
 186     let
 187         ty                   = idType fn_id
 188         (tvs, fun_ty)        = tcSplitForAllTys ty
 189         (arg_tys, io_res_ty) = tcSplitFunTys fun_ty
 190                 -- Must use tcSplit* functions because we want to
 191                 -- see that (IO t) in the corner
 192
 193     args <- newSysLocalsDs arg_tys
 194     (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args)
 195
 196     let
 197         work_arg_ids  = [v | Var v <- val_args] -- All guaranteed to be vars
 198
 199         forDotnet =
 200          case fcall of
 201            DNCall{} -> True
 202            _        -> False
 203
 204         topConDs
 205           | forDotnet = Just <$> dsLookupGlobalId checkDotnetResName
 206           | otherwise = return Nothing
 207
 208         augmentResultDs
 209           | forDotnet = do
 210                 err_res <- newSysLocalDs addrPrimTy
 211                 return (\ (mb_res_ty, resWrap) ->
 212                               case mb_res_ty of
 213                                 Nothing -> (Just (mkTyConApp (tupleTyCon Unboxed 1)
 214                                                              [ addrPrimTy ]),
 215                                                  resWrap)
 216                                 Just x  -> (Just (mkTyConApp (tupleTyCon Unboxed 2)
 217                                                              [ x, addrPrimTy ]),
 218                                                  resWrap))
 219           | otherwise = return id
 220
 221     augment <- augmentResultDs
 222     topCon <- topConDs
 223     (ccall_result_ty, res_wrapper) <- boxResult augment topCon io_res_ty
 224
 225     ccall_uniq <- newUnique
 226     work_uniq  <- newUnique
 227     let
 228         -- Build the worker
 229         worker_ty     = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
 230         the_ccall_app = mkFCall ccall_uniq fcall val_args ccall_result_ty
 231         work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)
 232         work_id       = setImpInline no_hdrs $  -- See comments with setImpInline
 233                         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}