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