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