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