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, moduleUserString )
  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 \end{code}
  48
  49 Desugaring of @foreign@ declarations is naturally split up into
  50 parts, an @import@ and an @export@  part. A @foreign import@
  51 declaration
  52 \begin{verbatim}
  53   foreign import cc nm f :: prim_args -> IO prim_res
  54 \end{verbatim}
  55 is the same as
  56 \begin{verbatim}
  57   f :: prim_args -> IO prim_res
  58   f a1 ... an = _ccall_ nm cc a1 ... an
  59 \end{verbatim}
  60 so we reuse the desugaring code in @DsCCall@ to deal with these.
  61
  62 \begin{code}
  63 type Binding = (Id, CoreExpr)   -- No rec/nonrec structure;
  64                                 -- the occurrence analyser will sort it all out
  65
  66 dsForeigns :: Module
  67            -> [TypecheckedForeignDecl]
  68            -> DsM ( [Id]                -- Foreign-exported binders;
  69                                         -- we have to generate code to register these
  70                   , [Binding]
  71                   , SDoc              -- Header file prototypes for
  72                                       -- "foreign exported" functions.
  73                   , SDoc              -- C stubs to use when calling
  74                                       -- "foreign exported" functions.
  75                   , [FAST_STRING]     -- headers that need to be included
  76                                       -- into C code generated for this module
  77                   )
  78 dsForeigns mod_name fos
  79   = foldlDs combine ([], [], empty, empty, []) fos
  80  where
  81   combine (acc_feb, acc_f, acc_h, acc_c, acc_header)
  82           (ForeignImport id _ spec depr loc)
  83     = dsFImport mod_name id spec                   `thenDs` \(bs, h, c, hd) ->
  84       warnDepr depr loc                            `thenDs` \_              ->
  85       returnDs (acc_feb, bs ++ acc_f, h $$ acc_h, c $$ acc_c, hd ++ acc_header)
  86
  87   combine (acc_feb, acc_f, acc_h, acc_c, acc_header)
  88           (ForeignExport id _ (CExport (CExportStatic ext_nm cconv)) depr loc)
  89     = dsFExport mod_name id (idType id)
  90                 ext_nm cconv False                 `thenDs` \(h, c) ->
  91       warnDepr depr loc                            `thenDs` \_              ->
  92       returnDs (acc_feb, acc_f, h $$ acc_h, c $$ acc_c, acc_header)
  93
  94   warnDepr False _   = returnDs ()
  95   warnDepr True  loc = dsWarn (addShortWarnLocLine loc msg)
  96    where
  97     msg = ptext SLIT("foreign declaration uses deprecated non-standard syntax")
  98 \end{code}
  99
 100
 101 %************************************************************************
 102 %*                                                                      *
 103 \subsection{Foreign import}
 104 %*                                                                      *
 105 %************************************************************************
 106
 107 Desugaring foreign imports is just the matter of creating a binding
 108 that on its RHS unboxes its arguments, performs the external call
 109 (using the @CCallOp@ primop), before boxing the result up and returning it.
 110
 111 However, we create a worker/wrapper pair, thus:
 112
 113         foreign import f :: Int -> IO Int
 114 ==>
 115         f x = IO ( \s -> case x of { I# x# ->
 116                          case fw s x# of { (# s1, y# #) ->
 117                          (# s1, I# y# #)}})
 118
 119         fw s x# = ccall f s x#
 120
 121 The strictness/CPR analyser won't do this automatically because it doesn't look
 122 inside returned tuples; but inlining this wrapper is a Really Good Idea
 123 because it exposes the boxing to the call site.
 124
 125 \begin{code}
 126 dsFImport :: Module
 127           -> Id
 128           -> ForeignImport
 129           -> DsM ([Binding], SDoc, SDoc, [FAST_STRING])
 130 dsFImport modName id (CImport cconv safety header lib spec)
 131   = dsCImport modName id spec cconv safety        `thenDs` \(ids, h, c) ->
 132     returnDs (ids, h, c, if _NULL_ header then [] else [header])
 133   -- FIXME: the `lib' field is needed for .NET ILX generation when invoking
 134   --        routines that are external to the .NET runtime, but GHC doesn't
 135   --        support such calls yet; if `_NULL_ lib', the value was not given
 136 dsFImport modName id (DNImport spec)
 137   = dsFCall modName id (DNCall spec)              `thenDs` \(ids, h, c) ->
 138     returnDs (ids, h, c, [])
 139
 140 dsCImport :: Module
 141           -> Id
 142           -> CImportSpec
 143           -> CCallConv
 144           -> Safety
 145           -> DsM ([Binding], SDoc, SDoc)
 146 dsCImport modName id (CLabel cid)       _     _
 147  = ASSERT(fromJust resTy `eqType` addrPrimTy)    -- typechecker ensures this
 148    returnDs ([(id, rhs)], empty, empty)
 149  where
 150    (resTy, foRhs) = resultWrapper (idType id)
 151    rhs            = foRhs (mkLit (MachLabel cid))
 152 dsCImport modName id (CFunction target) cconv safety
 153   = dsFCall modName id (CCall (CCallSpec target cconv safety))
 154 dsCImport modName id CWrapper           cconv _
 155   = dsFExportDynamic modName id cconv
 156 \end{code}
 157
 158
 159 %************************************************************************
 160 %*                                                                      *
 161 \subsection{Foreign calls}
 162 %*                                                                      *
 163 %************************************************************************
 164
 165 \begin{code}
 166 dsFCall mod_Name fn_id fcall
 167   = let
 168         ty                   = idType fn_id
 169         (tvs, fun_ty)        = tcSplitForAllTys ty
 170         (arg_tys, io_res_ty) = tcSplitFunTys fun_ty
 171                 -- Must use tcSplit* functions because we want to
 172                 -- see that (IO t) in the corner
 173     in
 174     newSysLocalsDs arg_tys                      `thenDs` \ args ->
 175     mapAndUnzipDs unboxArg (map Var args)       `thenDs` \ (val_args, arg_wrappers) ->
 176
 177     let
 178         work_arg_ids  = [v | Var v <- val_args] -- All guaranteed to be vars
 179
 180         -- These are the ids we pass to boxResult, which are used to decide
 181         -- whether to touch# an argument after the call (used to keep
 182         -- ForeignObj#s live across a 'safe' foreign import).
 183         maybe_arg_ids | unsafe_call fcall = work_arg_ids
 184                       | otherwise         = []
 185     in
 186     boxResult maybe_arg_ids io_res_ty           `thenDs` \ (ccall_result_ty, res_wrapper) ->
 187
 188     getUniqueDs                                 `thenDs` \ ccall_uniq ->
 189     getUniqueDs                                 `thenDs` \ work_uniq ->
 190     let
 191         -- Build the worker
 192         worker_ty     = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
 193         the_ccall_app = mkFCall ccall_uniq fcall val_args ccall_result_ty
 194         work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)
 195         work_id       = mkSysLocal (encodeFS SLIT("$wccall")) work_uniq worker_ty
 196
 197         -- Build the wrapper
 198         work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
 199         wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
 200         wrap_rhs     = mkInlineMe (mkLams (tvs ++ args) wrapper_body)
 201     in
 202     returnDs ([(work_id, work_rhs), (fn_id, wrap_rhs)], empty, empty)
 203
 204 unsafe_call (CCall (CCallSpec _ _ safety)) = playSafe safety
 205 unsafe_call (DNCall _)                     = False
 206 \end{code}
 207
 208
 209 %************************************************************************
 210 %*                                                                      *
 211 \subsection{Foreign export}
 212 %*                                                                      *
 213 %************************************************************************
 214
 215 The function that does most of the work for `@foreign export@' declarations.
 216 (see below for the boilerplate code a `@foreign export@' declaration expands
 217  into.)
 218
 219 For each `@foreign export foo@' in a module M we generate:
 220 \begin{itemize}
 221 \item a C function `@foo@', which calls
 222 \item a Haskell stub `@M.$ffoo@', which calls
 223 \end{itemize}
 224 the user-written Haskell function `@M.foo@'.
 225
 226 \begin{code}
 227 dsFExport :: Module
 228           -> Id                 -- Either the exported Id,
 229                                 -- or the foreign-export-dynamic constructor
 230           -> Type               -- The type of the thing callable from C
 231           -> CLabelString       -- The name to export to C land
 232           -> CCallConv
 233           -> Bool               -- True => foreign export dynamic
 234                                 --         so invoke IO action that's hanging off
 235                                 --         the first argument's stable pointer
 236           -> DsM ( SDoc         -- contents of Module_stub.h
 237                  , SDoc         -- contents of Module_stub.c
 238                  )
 239
 240 dsFExport mod_name fn_id ty ext_name cconv isDyn
 241    =
 242      let
 243         (tvs,sans_foralls)              = tcSplitForAllTys ty
 244         (fe_arg_tys', orig_res_ty)      = tcSplitFunTys sans_foralls
 245         -- We must use tcSplits here, because we want to see
 246         -- the (IO t) in the corner of the type!
 247         fe_arg_tys | isDyn     = tail fe_arg_tys'
 248                    | otherwise = fe_arg_tys'
 249      in
 250         -- Look at the result type of the exported function, orig_res_ty
 251         -- If it's IO t, return         (t, True)
 252         -- If it's plain t, return      (t, False)
 253      (case tcSplitTyConApp_maybe orig_res_ty of
 254         -- We must use tcSplit here so that we see the (IO t) in
 255         -- the type.  [IO t is transparent to plain splitTyConApp.]
 256
 257         Just (ioTyCon, [res_ty])
 258               -> ASSERT( ioTyCon `hasKey` ioTyConKey )
 259                  -- The function already returns IO t
 260                  returnDs (res_ty, True)
 261
 262         other -> -- The function returns t
 263                  returnDs (orig_res_ty, False)
 264      )
 265                                         `thenDs` \ (res_ty,             -- t
 266                                                     is_IO_res_ty) ->    -- Bool
 267      getModuleDs
 268                                         `thenDs` \ mod ->
 269      let
 270         (h_stub, c_stub)
 271            = mkFExportCBits (moduleUserString mod) ext_name
 272                             (if isDyn then Nothing else Just fn_id)
 273                             fe_arg_tys res_ty is_IO_res_ty cconv
 274      in
 275      returnDs (h_stub, c_stub)
 276 \end{code}
 277
 278 @foreign export dynamic@ lets you dress up Haskell IO actions
 279 of some fixed type behind an externally callable interface (i.e.,
 280 as a C function pointer). Useful for callbacks and stuff.
 281
 282 \begin{verbatim}
 283 foreign export dynamic f :: (Addr -> Int -> IO Int) -> IO Addr
 284
 285 -- Haskell-visible constructor, which is generated from the above:
 286 -- SUP: No check for NULL from createAdjustor anymore???
 287
 288 f :: (Addr -> Int -> IO Int) -> IO Addr
 289 f cback =
 290    bindIO (newStablePtr cback)
 291           (\StablePtr sp# -> IO (\s1# ->
 292               case _ccall_ createAdjustor cconv sp# ``f_helper'' s1# of
 293                  (# s2#, a# #) -> (# s2#, A# a# #)))
 294
 295 foreign export "f_helper" f_helper :: StablePtr (Addr -> Int -> IO Int) -> Addr -> Int -> IO Int
 296 -- `special' foreign export that invokes the closure pointed to by the
 297 -- first argument.
 298 \end{verbatim}
 299
 300 \begin{code}
 301 dsFExportDynamic :: Module
 302                  -> Id
 303                  -> CCallConv
 304                  -> DsM ([Binding], SDoc, SDoc)
 305 dsFExportDynamic mod_name id cconv
 306   =  newSysLocalDs ty                                    `thenDs` \ fe_id ->
 307      let
 308         -- hack: need to get at the name of the C stub we're about to generate.
 309        fe_nm       = _PK_ (moduleUserString mod_name ++ "_" ++ toCName fe_id)
 310      in
 311      dsFExport mod_name id export_ty fe_nm cconv True   `thenDs` \ (h_code, c_code) ->
 312      newSysLocalDs arg_ty                               `thenDs` \ cback ->
 313      dsLookupGlobalValue newStablePtrName               `thenDs` \ newStablePtrId ->
 314      let
 315         mk_stbl_ptr_app    = mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
 316      in
 317      dsLookupGlobalValue bindIOName                     `thenDs` \ bindIOId ->
 318      newSysLocalDs (mkTyConApp stablePtrTyCon [arg_ty]) `thenDs` \ stbl_value ->
 319      let
 320       stbl_app cont ret_ty
 321         = mkApps (Var bindIOId)
 322                  [ Type (mkTyConApp stablePtrTyCon [arg_ty])
 323                  , Type ret_ty
 324                  , mk_stbl_ptr_app
 325                  , cont
 326                  ]
 327
 328        {-
 329         The arguments to the external function which will
 330         create a little bit of (template) code on the fly
 331         for allowing the (stable pointed) Haskell closure
 332         to be entered using an external calling convention
 333         (stdcall, ccall).
 334        -}
 335       adj_args      = [ mkIntLitInt (ccallConvToInt cconv)
 336                       , Var stbl_value
 337                       , mkLit (MachLabel fe_nm)
 338                       ]
 339         -- name of external entry point providing these services.
 340         -- (probably in the RTS.)
 341       adjustor      = SLIT("createAdjustor")
 342      in
 343      dsCCall adjustor adj_args PlayRisky False io_res_ty        `thenDs` \ ccall_adj ->
 344         -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
 345      let ccall_adj_ty = exprType ccall_adj
 346          ccall_io_adj = mkLams [stbl_value]                  $
 347                         Note (Coerce io_res_ty ccall_adj_ty)
 348                              ccall_adj
 349          io_app = mkLams tvs     $
 350                   mkLams [cback] $
 351                   stbl_app ccall_io_adj res_ty
 352          fed = (id `setInlinePragma` NeverActive, io_app)
 353                 -- Never inline the f.e.d. function, because the litlit
 354                 -- might not be in scope in other modules.
 355      in
 356      returnDs ([fed], h_code, c_code)
 357
 358  where
 359   ty                    = idType id
 360   (tvs,sans_foralls)    = tcSplitForAllTys ty
 361   ([arg_ty], io_res_ty) = tcSplitFunTys sans_foralls
 362   [res_ty]              = tcTyConAppArgs io_res_ty
 363         -- Must use tcSplit* to see the (IO t), which is a newtype
 364   export_ty             = mkFunTy (mkTyConApp stablePtrTyCon [arg_ty]) arg_ty
 365
 366 toCName :: Id -> String
 367 toCName i = showSDoc (pprCode CStyle (ppr (idName i)))
 368 \end{code}
 369
 370 %*
 371 %
 372 \subsection{Generating @foreign export@ stubs}
 373 %
 374 %*
 375
 376 For each @foreign export@ function, a C stub function is generated.
 377 The C stub constructs the application of the exported Haskell function
 378 using the hugs/ghc rts invocation API.
 379
 380 \begin{code}
 381 mkFExportCBits :: String
 382                -> FAST_STRING
 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 mod_nm 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 <+> ptext 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 (ptext 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}