ghc/compiler/deSugar/DsForeign.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1998
   3 %
   4 \section[DsCCall]{Desugaring \tr{foreign} declarations}
   5
   6 Expanding out @foreign import@ and @foreign export@ declarations.
   7
   8 \begin{code}
   9 module DsForeign ( dsForeigns ) where
  10
  11 #include "HsVersions.h"
  12
  13 import CoreSyn
  14
  15 import DsCCall          ( dsCCall, mkFCall, boxResult, unboxArg, resultWrapper )
  16 import DsMonad
  17
  18 import HsSyn            ( ForeignDecl(..), ForeignExport(..),
  19                           ForeignImport(..), CImportSpec(..) )
  20 import TcHsSyn          ( TypecheckedForeignDecl )
  21 import CoreUtils        ( exprType, mkInlineMe )
  22 import Id               ( Id, idType, idName, mkSysLocal, setInlinePragma )
  23 import Literal          ( Literal(..) )
  24 import Module           ( Module, moduleString )
  25 import Name             ( getOccString, NamedThing(..) )
  26 import OccName          ( encodeFS )
  27 import Type             ( repType, eqType )
  28 import TcType           ( Type, mkFunTys, mkForAllTys, mkTyConApp,
  29                           mkFunTy, tcSplitTyConApp_maybe,
  30                           tcSplitForAllTys, tcSplitFunTys, tcTyConAppArgs,
  31                         )
  32
  33 import ForeignCall      ( ForeignCall(..), CCallSpec(..),
  34                           Safety(..), playSafe,
  35                           CExportSpec(..),
  36                           CCallConv(..), ccallConvToInt,
  37                           ccallConvAttribute
  38                         )
  39 import CStrings         ( CLabelString )
  40 import TysWiredIn       ( unitTy, stablePtrTyCon )
  41 import TysPrim          ( addrPrimTy )
  42 import PrelNames        ( hasKey, ioTyConKey, newStablePtrName, bindIOName )
  43 import BasicTypes       ( Activation( NeverActive ) )
  44 import ErrUtils         ( addShortWarnLocLine )
  45 import Outputable
  46 import Maybe            ( fromJust )
  47 import FastString
  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 :: Module
  68            -> [TypecheckedForeignDecl]
  69            -> DsM ( [Id]                -- Foreign-exported binders;
  70                                         -- we have to generate code to register these
  71                   , [Binding]
  72                   , SDoc              -- Header file prototypes for
  73                                       -- "foreign exported" functions.
  74                   , SDoc              -- C stubs to use when calling
  75                                       -- "foreign exported" functions.
  76                   , [FastString]     -- headers that need to be included
  77                                       -- into C code generated for this module
  78                   )
  79 dsForeigns mod_name fos
  80   = foldlDs combine ([], [], empty, empty, []) fos
  81  where
  82   combine (acc_feb, acc_f, acc_h, acc_c, acc_header)
  83           (ForeignImport id _ spec depr loc)
  84     = dsFImport mod_name id spec                   `thenDs` \(bs, h, c, hd) ->
  85       warnDepr depr loc                            `thenDs` \_              ->
  86       returnDs (acc_feb, bs ++ acc_f, h $$ acc_h, c $$ acc_c, hd ++ acc_header)
  87
  88   combine (acc_feb, acc_f, acc_h, acc_c, acc_header)
  89           (ForeignExport id _ (CExport (CExportStatic ext_nm cconv)) depr loc)
  90     = dsFExport mod_name id (idType id)
  91                 ext_nm cconv False                 `thenDs` \(h, c) ->
  92       warnDepr depr loc                            `thenDs` \_              ->
  93       returnDs (acc_feb, acc_f, h $$ acc_h, c $$ acc_c, acc_header)
  94
  95   warnDepr False _   = returnDs ()
  96   warnDepr True  loc = dsWarn (addShortWarnLocLine loc msg)
  97    where
  98     msg = ptext SLIT("foreign declaration uses deprecated non-standard syntax")
  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 :: Module
 128           -> Id
 129           -> ForeignImport
 130           -> DsM ([Binding], SDoc, SDoc, [FastString])
 131 dsFImport modName id (CImport cconv safety header lib spec)
 132   = dsCImport modName id spec cconv safety        `thenDs` \(ids, h, c) ->
 133     returnDs (ids, h, c, if nullFastString header then [] else [header])
 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 modName id (DNImport spec)
 138   = dsFCall modName id (DNCall spec)              `thenDs` \(ids, h, c) ->
 139     returnDs (ids, h, c, [])
 140
 141 dsCImport :: Module
 142           -> Id
 143           -> CImportSpec
 144           -> CCallConv
 145           -> Safety
 146           -> DsM ([Binding], SDoc, SDoc)
 147 dsCImport modName id (CLabel cid)       _     _
 148  = ASSERT(fromJust resTy `eqType` addrPrimTy)    -- typechecker ensures this
 149    returnDs ([(id, rhs)], empty, empty)
 150  where
 151    (resTy, foRhs) = resultWrapper (idType id)
 152    rhs            = foRhs (mkLit (MachLabel cid))
 153 dsCImport modName id (CFunction target) cconv safety
 154   = dsFCall modName id (CCall (CCallSpec target cconv safety))
 155 dsCImport modName id CWrapper           cconv _
 156   = dsFExportDynamic modName id cconv
 157 \end{code}
 158
 159
 160 %************************************************************************
 161 %*                                                                      *
 162 \subsection{Foreign calls}
 163 %*                                                                      *
 164 %************************************************************************
 165
 166 \begin{code}
 167 dsFCall mod_Name fn_id fcall
 168   = let
 169         ty                   = idType fn_id
 170         (tvs, fun_ty)        = tcSplitForAllTys ty
 171         (arg_tys, io_res_ty) = tcSplitFunTys fun_ty
 172                 -- Must use tcSplit* functions because we want to
 173                 -- see that (IO t) in the corner
 174     in
 175     newSysLocalsDs arg_tys                      `thenDs` \ args ->
 176     mapAndUnzipDs unboxArg (map Var args)       `thenDs` \ (val_args, arg_wrappers) ->
 177
 178     let
 179         work_arg_ids  = [v | Var v <- val_args] -- All guaranteed to be vars
 180
 181         -- These are the ids we pass to boxResult, which are used to decide
 182         -- whether to touch# an argument after the call (used to keep
 183         -- ForeignObj#s live across a 'safe' foreign import).
 184         maybe_arg_ids | unsafe_call fcall = work_arg_ids
 185                       | otherwise         = []
 186     in
 187     boxResult maybe_arg_ids io_res_ty           `thenDs` \ (ccall_result_ty, res_wrapper) ->
 188
 189     getUniqueDs                                 `thenDs` \ ccall_uniq ->
 190     getUniqueDs                                 `thenDs` \ work_uniq ->
 191     let
 192         -- Build the worker
 193         worker_ty     = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
 194         the_ccall_app = mkFCall ccall_uniq fcall val_args ccall_result_ty
 195         work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)
 196         work_id       = mkSysLocal (encodeFS FSLIT("$wccall")) work_uniq worker_ty
 197
 198         -- Build the wrapper
 199         work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
 200         wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
 201         wrap_rhs     = mkInlineMe (mkLams (tvs ++ args) wrapper_body)
 202     in
 203     returnDs ([(work_id, work_rhs), (fn_id, wrap_rhs)], empty, empty)
 204
 205 unsafe_call (CCall (CCallSpec _ _ safety)) = playSafe safety
 206 unsafe_call (DNCall _)                     = False
 207 \end{code}
 208
 209
 210 %************************************************************************
 211 %*                                                                      *
 212 \subsection{Foreign export}
 213 %*                                                                      *
 214 %************************************************************************
 215
 216 The function that does most of the work for `@foreign export@' declarations.
 217 (see below for the boilerplate code a `@foreign export@' declaration expands
 218  into.)
 219
 220 For each `@foreign export foo@' in a module M we generate:
 221 \begin{itemize}
 222 \item a C function `@foo@', which calls
 223 \item a Haskell stub `@M.$ffoo@', which calls
 224 \end{itemize}
 225 the user-written Haskell function `@M.foo@'.
 226
 227 \begin{code}
 228 dsFExport :: Module
 229           -> Id                 -- Either the exported Id,
 230                                 -- or the foreign-export-dynamic constructor
 231           -> Type               -- The type of the thing callable from C
 232           -> CLabelString       -- The name to export to C land
 233           -> CCallConv
 234           -> Bool               -- True => foreign export dynamic
 235                                 --         so invoke IO action that's hanging off
 236                                 --         the first argument's stable pointer
 237           -> DsM ( SDoc         -- contents of Module_stub.h
 238                  , SDoc         -- contents of Module_stub.c
 239                  )
 240
 241 dsFExport mod_name fn_id ty ext_name cconv isDyn
 242    =
 243      let
 244         (tvs,sans_foralls)              = tcSplitForAllTys ty
 245         (fe_arg_tys', orig_res_ty)      = tcSplitFunTys sans_foralls
 246         -- We must use tcSplits here, because we want to see
 247         -- the (IO t) in the corner of the type!
 248         fe_arg_tys | isDyn     = tail fe_arg_tys'
 249                    | otherwise = fe_arg_tys'
 250      in
 251         -- Look at the result type of the exported function, orig_res_ty
 252         -- If it's IO t, return         (t, True)
 253         -- If it's plain t, return      (t, False)
 254      (case tcSplitTyConApp_maybe orig_res_ty of
 255         -- We must use tcSplit here so that we see the (IO t) in
 256         -- the type.  [IO t is transparent to plain splitTyConApp.]
 257
 258         Just (ioTyCon, [res_ty])
 259               -> ASSERT( ioTyCon `hasKey` ioTyConKey )
 260                  -- The function already returns IO t
 261                  returnDs (res_ty, True)
 262
 263         other -> -- The function returns t
 264                  returnDs (orig_res_ty, False)
 265      )
 266                                         `thenDs` \ (res_ty,             -- t
 267                                                     is_IO_res_ty) ->    -- Bool
 268      getModuleDs
 269                                         `thenDs` \ mod ->
 270      let
 271         (h_stub, c_stub)
 272            = mkFExportCBits ext_name
 273                             (if isDyn then Nothing else Just fn_id)
 274                             fe_arg_tys res_ty is_IO_res_ty cconv
 275      in
 276      returnDs (h_stub, c_stub)
 277 \end{code}
 278
 279 @foreign export dynamic@ lets you dress up Haskell IO actions
 280 of some fixed type behind an externally callable interface (i.e.,
 281 as a C function pointer). Useful for callbacks and stuff.
 282
 283 \begin{verbatim}
 284 foreign export dynamic f :: (Addr -> Int -> IO Int) -> IO Addr
 285
 286 -- Haskell-visible constructor, which is generated from the above:
 287 -- SUP: No check for NULL from createAdjustor anymore???
 288
 289 f :: (Addr -> Int -> IO Int) -> IO Addr
 290 f cback =
 291    bindIO (newStablePtr cback)
 292           (\StablePtr sp# -> IO (\s1# ->
 293               case _ccall_ createAdjustor cconv sp# ``f_helper'' s1# of
 294                  (# s2#, a# #) -> (# s2#, A# a# #)))
 295
 296 foreign export "f_helper" f_helper :: StablePtr (Addr -> Int -> IO Int) -> Addr -> Int -> IO Int
 297 -- `special' foreign export that invokes the closure pointed to by the
 298 -- first argument.
 299 \end{verbatim}
 300
 301 \begin{code}
 302 dsFExportDynamic :: Module
 303                  -> Id
 304                  -> CCallConv
 305                  -> DsM ([Binding], SDoc, SDoc)
 306 dsFExportDynamic mod_name id cconv
 307   =  newSysLocalDs ty                                    `thenDs` \ fe_id ->
 308      let
 309         -- hack: need to get at the name of the C stub we're about to generate.
 310        fe_nm       = mkFastString (moduleString mod_name ++ "_" ++ toCName fe_id)
 311      in
 312      dsFExport mod_name id export_ty fe_nm cconv True   `thenDs` \ (h_code, c_code) ->
 313      newSysLocalDs arg_ty                               `thenDs` \ cback ->
 314      dsLookupGlobalValue newStablePtrName               `thenDs` \ newStablePtrId ->
 315      let
 316         mk_stbl_ptr_app    = mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
 317      in
 318      dsLookupGlobalValue bindIOName                     `thenDs` \ bindIOId ->
 319      newSysLocalDs (mkTyConApp stablePtrTyCon [arg_ty]) `thenDs` \ stbl_value ->
 320      let
 321       stbl_app cont ret_ty
 322         = mkApps (Var bindIOId)
 323                  [ Type (mkTyConApp stablePtrTyCon [arg_ty])
 324                  , Type ret_ty
 325                  , mk_stbl_ptr_app
 326                  , cont
 327                  ]
 328
 329        {-
 330         The arguments to the external function which will
 331         create a little bit of (template) code on the fly
 332         for allowing the (stable pointed) Haskell closure
 333         to be entered using an external calling convention
 334         (stdcall, ccall).
 335        -}
 336       adj_args      = [ mkIntLitInt (ccallConvToInt cconv)
 337                       , Var stbl_value
 338                       , mkLit (MachLabel fe_nm)
 339                       ]
 340         -- name of external entry point providing these services.
 341         -- (probably in the RTS.)
 342       adjustor      = FSLIT("createAdjustor")
 343      in
 344      dsCCall adjustor adj_args PlayRisky False io_res_ty        `thenDs` \ ccall_adj ->
 345         -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
 346      let ccall_adj_ty = exprType ccall_adj
 347          ccall_io_adj = mkLams [stbl_value]                  $
 348                         Note (Coerce io_res_ty ccall_adj_ty)
 349                              ccall_adj
 350          io_app = mkLams tvs     $
 351                   mkLams [cback] $
 352                   stbl_app ccall_io_adj res_ty
 353          fed = (id `setInlinePragma` NeverActive, io_app)
 354                 -- Never inline the f.e.d. function, because the litlit
 355                 -- might not be in scope in other modules.
 356      in
 357      returnDs ([fed], h_code, c_code)
 358
 359  where
 360   ty                    = idType id
 361   (tvs,sans_foralls)    = tcSplitForAllTys ty
 362   ([arg_ty], io_res_ty) = tcSplitFunTys sans_foralls
 363   [res_ty]              = tcTyConAppArgs io_res_ty
 364         -- Must use tcSplit* to see the (IO t), which is a newtype
 365   export_ty             = mkFunTy (mkTyConApp stablePtrTyCon [arg_ty]) arg_ty
 366
 367 toCName :: Id -> String
 368 toCName i = showSDoc (pprCode CStyle (ppr (idName i)))
 369 \end{code}
 370
 371 %*
 372 %
 373 \subsection{Generating @foreign export@ stubs}
 374 %
 375 %*
 376
 377 For each @foreign export@ function, a C stub function is generated.
 378 The C stub constructs the application of the exported Haskell function
 379 using the hugs/ghc rts invocation API.
 380
 381 \begin{code}
 382 mkFExportCBits :: FastString
 383                -> Maybe Id      -- Just==static, Nothing==dynamic
 384                -> [Type]
 385                -> Type
 386                -> Bool          -- True <=> returns an IO type
 387                -> CCallConv
 388                -> (SDoc, SDoc)
 389 mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
 390  = (header_bits, c_bits)
 391  where
 392   -- Create up types and names for the real args
 393   arg_cnames, arg_ctys :: [SDoc]
 394   arg_cnames = mkCArgNames 1 arg_htys
 395   arg_ctys   = map showStgType arg_htys
 396
 397   -- and also for auxiliary ones; the stable ptr in the dynamic case, and
 398   -- a slot for the dummy return address in the dynamic + ccall case
 399   extra_cnames_and_ctys
 400      = case maybe_target of
 401           Nothing -> [(text "the_stableptr", text "StgStablePtr")]
 402           other   -> []
 403        ++
 404        case (maybe_target, cc) of
 405           (Nothing, CCallConv) -> [(text "original_return_addr", text "void*")]
 406           other                -> []
 407
 408   all_cnames_and_ctys :: [(SDoc, SDoc)]
 409   all_cnames_and_ctys
 410      = extra_cnames_and_ctys ++ zip arg_cnames arg_ctys
 411
 412   -- stuff to do with the return type of the C function
 413   res_hty_is_unit = res_hty `eqType` unitTy     -- Look through any newtypes
 414
 415   cResType | res_hty_is_unit = text "void"
 416            | otherwise       = showStgType res_hty
 417
 418   -- Now we can cook up the prototype for the exported function.
 419   pprCconv = case cc of
 420                 CCallConv   -> empty
 421                 StdCallConv -> text (ccallConvAttribute cc)
 422
 423   header_bits = ptext SLIT("extern") <+> fun_proto <> semi
 424
 425   fun_proto = cResType <+> pprCconv <+> ftext c_nm <>
 426               parens (hsep (punctuate comma (map (\(nm,ty) -> ty <+> nm)
 427                                                  all_cnames_and_ctys)))
 428
 429   -- the target which will form the root of what we ask rts_evalIO to run
 430   the_cfun
 431      = case maybe_target of
 432           Nothing    -> text "(StgClosure*)deRefStablePtr(the_stableptr)"
 433           Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"
 434
 435   -- the expression we give to rts_evalIO
 436   expr_to_run
 437      = foldl appArg the_cfun (zip arg_cnames arg_htys)
 438        where
 439           appArg acc (arg_cname, arg_hty)
 440              = text "rts_apply"
 441                <> parens (acc <> comma <> mkHObj arg_hty <> parens arg_cname)
 442
 443   -- various other bits for inside the fn
 444   declareResult = text "HaskellObj ret;"
 445
 446   return_what | res_hty_is_unit = empty
 447               | otherwise       = parens (unpackHObj res_hty <> parens (text "ret"))
 448
 449   -- an extern decl for the fn being called
 450   extern_decl
 451      = case maybe_target of
 452           Nothing -> empty
 453           Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi
 454
 455   -- finally, the whole darn thing
 456   c_bits =
 457     space $$
 458     extern_decl $$
 459     fun_proto  $$
 460     vcat
 461      [ lbrace
 462      ,   text "SchedulerStatus rc;"
 463      ,   declareResult
 464           -- create the application + perform it.
 465      ,   text (if is_IO_res_ty then "rc=rts_evalIO" else "rc=rts_eval")
 466          <> parens (expr_to_run <+> comma <> text "&ret")
 467          <> semi
 468      ,   text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm)
 469                                                 <> comma <> text "rc") <> semi
 470      ,   text "return" <> return_what <> semi
 471      , rbrace
 472      ]
 473
 474
 475 mkCArgNames :: Int -> [a] -> [SDoc]
 476 mkCArgNames n as = zipWith (\ _ n -> text ('a':show n)) as [n..]
 477
 478 mkHObj :: Type -> SDoc
 479 mkHObj t = text "rts_mk" <> text (showFFIType t)
 480
 481 unpackHObj :: Type -> SDoc
 482 unpackHObj t = text "rts_get" <> text (showFFIType t)
 483
 484 showStgType :: Type -> SDoc
 485 showStgType t = text "Hs" <> text (showFFIType t)
 486
 487 showFFIType :: Type -> String
 488 showFFIType t = getOccString (getName tc)
 489  where
 490   tc = case tcSplitTyConApp_maybe (repType t) of
 491             Just (tc,_) -> tc
 492             Nothing     -> pprPanic "showFFIType" (ppr t)
 493 \end{code}