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
  12 #include "HsVersions.h"
  13
  14 import CoreSyn
  15
  16 import DsCCall          ( getIoOkDataCon, boxResult, unboxArg,
  17                           can'tSeeDataConsPanic
  18                         )
  19 import DsMonad
  20 import DsUtils
  21
  22 import HsSyn            ( ExtName(..), ForeignDecl(..), isDynamic, ForKind(..) )
  23 import CallConv
  24 import TcHsSyn          ( maybeBoxedPrimType, TypecheckedForeignDecl )
  25 import CoreUtils        ( coreExprType )
  26 import Id               ( Id, dataConArgTys, idType, idName,
  27                           mkVanillaId, dataConRawArgTys,
  28                           dataConTyCon, mkIdVisible
  29                         )
  30 import IdInfo           ( noIdInfo )
  31 import Literal          ( Literal(..), mkMachInt )
  32 import Maybes           ( maybeToBool )
  33 import Name             ( nameString, occNameString, nameOccName, nameUnique )
  34 import PrelVals         ( packStringForCId, eRROR_ID )
  35 import PrimOp           ( PrimOp(..) )
  36 import Type             ( isUnpointedType, splitAlgTyConApp_maybe,
  37                           splitTyConApp_maybe, splitFunTys, splitForAllTys,
  38                           Type, mkFunTys, applyTy, mkForAllTys, mkTyConApp,
  39                           typePrimRep, mkTyVarTy, mkFunTy, splitAppTy
  40                         )
  41 import PrimRep          ( showPrimRepToUser, PrimRep(..) )
  42 import TyVar            ( TyVar )
  43 import TyCon            ( tyConDataCons )
  44 import TysPrim          ( byteArrayPrimTy, realWorldStatePrimTy,
  45                           byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
  46                           realWorldTy, addrPrimTy, mkStablePtrPrimTy,
  47                           intPrimTy
  48                         )
  49 import TysWiredIn       ( getStatePairingConInfo,
  50                           unitDataCon, stringTy,
  51                           realWorldStateTy, stateDataCon,
  52                           isFFIArgumentTy, unitTy,
  53                           addrTy, stablePtrTyCon,
  54                           stateAndPtrPrimDataCon,
  55                           addrDataCon
  56                         )
  57 import Outputable
  58 \end{code}
  59
  60 Desugaring of @foreign@ declarations is naturally split up into
  61 parts, an @import@ and an @export@  part. A @foreign import@
  62 declaration
  63
  64   foreign import cc nm f :: prim_args -> IO prim_res
  65
  66 is the same as
  67
  68   f :: prim_args -> IO prim_res
  69   f a1 ... an = _ccall_ nm cc a1 ... an
  70
  71 so we reuse the desugaring code in @DsCCall@ to deal with these.
  72
  73 \begin{code}
  74 dsForeigns :: [TypecheckedForeignDecl]
  75            -> DsM ( [CoreBinding]        -- desugared foreign imports
  76                   , [CoreBinding]        -- helper functions for foreign exports
  77                   , SDoc                 -- auxilliary code to emit into .hc file
  78                   , SDoc                 -- Header file prototypes for "foreign exported" functions.
  79                   , SDoc                 -- C stubs to use when calling "foreign exported" funs.
  80                   )
  81 dsForeigns fos = foldlDs combine ([],[],empty,empty,empty) fos
  82  where
  83   combine (acc_fi, acc_fe, acc_hc, acc_h, acc_c) fo@(ForeignDecl i imp_exp _ ext_nm cconv _)
  84     | isForeignImport =
  85         dsFImport i (idType i) uns ext_nm cconv  `thenDs` \ b ->
  86         returnDs (b:acc_fi, acc_fe, acc_hc, acc_h, acc_c)
  87     | isForeignLabel =
  88         dsFLabel i ext_nm `thenDs` \ b ->
  89         returnDs (b:acc_fi, acc_fe, acc_hc, acc_h, acc_c)
  90     | isDynamic ext_nm =
  91         dsFExportDynamic i (idType i) ext_nm cconv  `thenDs` \ (fi,fe,hc,h,c) ->
  92         returnDs (fi:acc_fi, fe:acc_fe, hc $$ acc_hc, h $$ acc_h, c $$ acc_c)
  93     | otherwise        =
  94         dsFExport i (idType i) ext_nm cconv False   `thenDs` \ (fe,hc,h,c) ->
  95         returnDs (acc_fi, fe:acc_fe, hc $$ acc_hc, h $$ acc_h, c $$ acc_c)
  96
  97    where
  98     isForeignImport =
  99         case imp_exp of
 100           FoImport _ -> True
 101           _          -> False
 102
 103     isForeignLabel =
 104         case imp_exp of
 105           FoLabel -> True
 106           _       -> False
 107
 108     (FoImport uns)   = imp_exp
 109
 110 \end{code}
 111
 112 Desugaring foreign imports is just the matter of creating a binding
 113 that on its RHS unboxes its arguments, performs the external call
 114 (using the CCallOp primop), before boxing the result up and returning it.
 115
 116 \begin{code}
 117 dsFImport :: Id
 118           -> Type               -- Type of foreign import.
 119           -> Bool               -- True <=> might cause Haskell GC
 120           -> ExtName
 121           -> CallConv
 122           -> DsM CoreBinding
 123 dsFImport nm ty may_not_gc ext_name cconv =
 124     newSysLocalDs realWorldStatePrimTy  `thenDs` \ old_s ->
 125     mkArgs ty                           `thenDs` \ (tvs, args, io_res_ty)  ->
 126     mapAndUnzipDs unboxArg args         `thenDs` \ (unboxed_args, arg_wrappers) ->
 127     let
 128          final_args = Var old_s : unboxed_args
 129          (ioOkDataCon, ioDataCon, result_ty) = getIoOkDataCon io_res_ty
 130     in
 131     boxResult ioOkDataCon result_ty     `thenDs` \ (final_result_ty, res_wrapper) ->
 132     (case ext_name of
 133        Dynamic       -> getUniqueDs `thenDs` \ u -> returnDs (Right u)
 134        ExtName fs _  -> returnDs (Left fs)) `thenDs` \ label ->
 135     let
 136         the_ccall_op = CCallOp label False (not may_not_gc) cconv
 137                                (map coreExprType final_args)
 138                                final_result_ty
 139     in
 140     mkPrimDs the_ccall_op (map VarArg final_args) `thenDs` \ the_prim_app ->
 141     let
 142         the_body = mkValLam [old_s]
 143                             (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
 144     in
 145     newSysLocalDs (coreExprType the_body) `thenDs` \ ds ->
 146     let
 147       io_app = mkValApp (mkTyApp (Var ioDataCon) [result_ty]) [VarArg ds]
 148       fo_rhs = mkTyLam  tvs $
 149                mkValLam (map (\ (Var x) -> x) args)
 150                         (mkCoLetAny (NonRec ds the_body) io_app)
 151     in
 152     returnDs (NonRec nm fo_rhs)
 153
 154 mkArgs :: Type -> DsM ([TyVar], [CoreExpr], Type)
 155 mkArgs ty =
 156   case splitFunTys sans_foralls of
 157     (arg_tys, res_ty) ->
 158        newSysLocalsDs arg_tys  `thenDs` \ ds_args ->
 159        returnDs (tvs, map Var ds_args, res_ty)
 160   where
 161    (tvs, sans_foralls) = splitForAllTys ty
 162
 163 \end{code}
 164
 165
 166 \begin{code}
 167 dsFLabel :: Id -> ExtName -> DsM CoreBinding
 168 dsFLabel nm ext_name =
 169     returnDs (NonRec nm fo_rhs)
 170   where
 171    fo_rhs = mkCon addrDataCon [] [LitArg (MachLitLit enm AddrRep)]
 172    enm    =
 173     case ext_name of
 174       ExtName f _ -> f
 175
 176 \end{code}
 177
 178
 179
 180 \begin{code}
 181 dsFExport :: Id
 182           -> Type               -- Type of foreign export.
 183           -> ExtName
 184           -> CallConv
 185           -> Bool               -- True => invoke IO action that's hanging off
 186                                 -- the first argument's stable pointer
 187           -> DsM (CoreBinding, SDoc, SDoc, SDoc)
 188 dsFExport i ty ext_name cconv isDyn =
 189      newSysLocalDs  realWorldStatePrimTy                `thenDs` \ s1 ->
 190      newSysLocalDs  realWorldStatePrimTy                `thenDs` \ s3 ->
 191      newSysLocalDs  helper_ty                           `thenDs` \ f_helper ->
 192      newSysLocalsDs helper_arg_tys                      `thenDs` \ helper_args ->
 193      newSysLocalDs  res_ty                              `thenDs` \ v1 ->
 194      unboxResult    the_prim_result_ty res_ty s3 v1     `thenDs` \ (state_and_prim_ty, unpack_result) ->
 195      zipWithDs boxArg fe_arg_tys helper_args            `thenDs` \ stuff ->
 196      (if isDyn then
 197         newSysLocalDs realWorldStatePrimTy              `thenDs` \ s11 ->
 198         newSysLocalDs stbl_ptr_ty                       `thenDs` \ stbl_ptr ->
 199         newSysLocalDs stbl_ptr_to_ty                    `thenDs` \ f ->
 200         mkPrimDs DeRefStablePtrOp
 201                  [TyArg stbl_ptr_to_ty,
 202                   VarArg (Var stbl_ptr),
 203                   VarArg (Var s1)]                      `thenDs` \ the_deref_app ->
 204         let
 205          stbl_app = \ cont ->
 206             Case the_deref_app
 207                  (AlgAlts [(stateAndPtrPrimDataCon, [s11, f], cont)]
 208                           NoDefault)
 209         in
 210         returnDs (f, stbl_app, s11, stbl_ptr)
 211       else
 212         returnDs (i,
 213                   \ body -> body,
 214                   s1,
 215                   panic "stbl_ptr"  -- should never be touched.
 216                   ))                                    `thenDs` \ (i, getFun_wrapper, s2, stbl_ptr) ->
 217      let
 218       (boxed_args, arg_wrappers)  = unzip stuff
 219
 220       wrapper_args
 221        | isDyn      = stbl_ptr:helper_args
 222        | otherwise  = helper_args
 223
 224       wrapper_arg_tys
 225        | isDyn      = stbl_ptr_ty:helper_arg_tys
 226        | otherwise  = helper_arg_tys
 227
 228       fe_app   = mkGenApp (Var i) (map (TyArg . mkTyVarTy) tvs ++ map VarArg boxed_args)
 229       the_app  =
 230         getFun_wrapper $
 231         mkValApp (Note (Coerce io_result_ty io_res) fe_app)
 232                  [VarArg s2]
 233      in
 234      newFailLocalDs  (coreExprType the_app)     `thenDs` \ wild ->
 235      getModuleAndGroupDs                        `thenDs` \ (mod,_) ->
 236      getUniqueDs                                `thenDs` \ uniq ->
 237      let
 238
 239       the_body =
 240            mkTyLam  tvs          $
 241            mkValLam wrapper_args $
 242            mkValLam [s1]         $
 243            foldr ($) (perform_and_unpack) arg_wrappers
 244
 245       perform_and_unpack =
 246          Case the_app (AlgAlts [(ioOkDataCon, [s3, v1], unpack_result)]
 247                       (BindDefault wild err))
 248
 249       c_nm =
 250         case ext_name of
 251           ExtName fs _ -> fs
 252
 253       full_msg = "Exception caught: " ++ _UNPK_ (nameString (idName i))
 254       msg = NoRepStr (_PK_ full_msg)
 255       err = mkApp (Var eRROR_ID) [state_and_prim_ty] [LitArg msg]
 256
 257       f_helper_glob = (mkIdVisible mod uniq f_helper)
 258       (hc_stub, h_stub, c_stub) = fexportEntry c_nm f_helper_glob wrapper_arg_tys the_prim_result_ty cconv
 259      in
 260      returnDs (NonRec f_helper_glob the_body, hc_stub, h_stub, c_stub)
 261   where
 262    (tvs,sans_foralls)                     = splitForAllTys ty
 263    (fe_arg_tys', io_res)                  = splitFunTys sans_foralls
 264    (ioOkDataCon, ioDataCon, res_ty)       = getIoOkDataCon io_res
 265
 266    maybe_data_type                        = splitAlgTyConApp_maybe res_ty
 267    Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
 268    (the_data_con : other_data_cons)       = data_cons
 269
 270    data_con_arg_tys                   = dataConArgTys the_data_con tycon_arg_tys
 271    (prim_result_ty : other_args_tys)  = data_con_arg_tys
 272
 273    ioDataConTy                          = idType ioDataCon
 274    (io_tvs, ioDataConTy')               = splitForAllTys ioDataConTy
 275    ([arg_ty], _)                        = splitFunTys ioDataConTy'
 276    io_result_ty                         = applyTy (mkForAllTys io_tvs arg_ty) res_ty
 277
 278    (_, stbl_ptr_ty')                    = splitForAllTys stbl_ptr_ty
 279    (_, stbl_ptr_to_ty)                  = splitAppTy stbl_ptr_ty'
 280
 281    fe_arg_tys
 282      | isDyn        = tail fe_arg_tys'
 283      | otherwise    = fe_arg_tys'
 284
 285    (stbl_ptr_ty, helper_arg_tys) =
 286      case (map unboxTy fe_arg_tys') of
 287        (x:xs) | isDyn -> (x,xs)
 288        ls             -> (error "stbl_ptr_ty", ls)
 289
 290    helper_ty      =
 291         mkForAllTys tvs $
 292         mkFunTys (arg_tys ++ [realWorldStatePrimTy])
 293                  state_and_prim_ty
 294         where
 295           arg_tys
 296            | isDyn      = stbl_ptr_ty : helper_arg_tys
 297            | otherwise  = helper_arg_tys
 298
 299    the_prim_result_ty
 300      | null data_con_arg_tys   = Nothing
 301      | otherwise               = Just prim_result_ty
 302
 303    state_and_prim_ty
 304      | (null other_data_cons) &&
 305        (null data_con_arg_tys) = realWorldStateTy
 306      | otherwise               = snd (getStatePairingConInfo (unboxTy res_ty))
 307 \end{code}
 308
 309 "foreign export dynamic" lets you dress up Haskell IO actions
 310 of some fixed type behind an externally callable interface (i.e.,
 311 as a C function pointer). Useful for callbacks and stuff.
 312
 313 \begin{verbatim}
 314 foreign export stdcall f :: (Addr -> Int -> IO Int) -> IO Addr
 315
 316 -- Haskell-visible constructor, which is generated from the
 317 -- above:
 318
 319 f :: (Addr -> Int -> IO Int) -> IO Addr
 320 f cback = IO ( \ s1# ->
 321   case makeStablePtr# cback s1# of { StateAndStablePtr# s2# sp# ->
 322   case _ccall_ "mkAdjustor" sp# ``f_helper'' s2# of
 323     StateAndAddr# s3# a# ->
 324     case addr2Int# a# of
 325       0# -> IOfail s# err
 326       _  ->
 327          let
 328           a :: Addr
 329           a = A# a#
 330          in
 331          IOok s3# a)
 332
 333 foreign export "f_helper" f_helper :: StablePtr (Addr -> Int -> IO Int) -> Addr -> Int -> IO Int
 334 -- `special' foreign export that invokes the closure pointed to by the
 335 -- first argument.
 336 \end{verbatim}
 337
 338 \begin{code}
 339 dsFExportDynamic :: Id
 340                  -> Type                -- Type of foreign export.
 341                  -> ExtName
 342                  -> CallConv
 343                  -> DsM (CoreBinding, CoreBinding, SDoc, SDoc, SDoc)
 344 dsFExportDynamic i ty ext_name cconv =
 345      newSysLocalDs ty                                    `thenDs` \ fe_id ->
 346      let
 347         -- hack: need to get at the name of the C stub we're about to generate.
 348        fe_nm         = toCName fe_id
 349        fe_ext_name = ExtName (_PK_ fe_nm) Nothing
 350      in
 351      dsFExport  i export_ty fe_ext_name cconv True       `thenDs` \ (fe@(NonRec fe_helper fe_expr), hc_code, h_code, c_code) ->
 352      newSysLocalDs  realWorldStatePrimTy                 `thenDs` \ s1 ->
 353      newSysLocalDs  realWorldStatePrimTy                 `thenDs` \ s2 ->
 354      newSysLocalDs  realWorldStatePrimTy                 `thenDs` \ s3 ->
 355      newSysLocalDs  arg_ty                               `thenDs` \ cback_arg ->
 356      newSysLocalDs  arg_ty                               `thenDs` \ cback ->
 357      newSysLocalDs  (mkStablePtrPrimTy arg_ty)           `thenDs` \ stbl ->
 358      newSysLocalDs  addrPrimTy                           `thenDs` \ addrPrim ->
 359      newSysLocalDs  addrTy                               `thenDs` \ addr ->
 360      mkPrimDs MakeStablePtrOp [TyArg arg_ty,
 361                                VarArg (Var cback),
 362                                VarArg (Var s1)]          `thenDs` \ mkStablePtr_app ->
 363      mkPrimDs Addr2IntOp [VarArg (Var addrPrim)]         `thenDs` \ the_addr2Int_app ->
 364      boxArg addrTy addrPrim                              `thenDs` \ (addr_result, addrPrim_wrapper) ->
 365      let
 366        (stateAndStablePtrPrimDataCon, _)             = getStatePairingConInfo (mkStablePtrPrimTy arg_ty)
 367        (stateAndAddrPrimDataCon, stateAndAddrPrimTy) = getStatePairingConInfo addrPrimTy
 368
 369        cc
 370         | cconv == stdCallConv = 1
 371         | otherwise            = 0
 372
 373        ccall_args   = [Var s2, Lit (mkMachInt cc),
 374                        Var stbl,
 375                        Lit (MachLitLit (_PK_ fe_nm) AddrRep)]
 376
 377        label        = Left SLIT("createAdjustor")
 378        the_ccall_op = CCallOp label False False{-won't GC-} cCallConv
 379                               (map coreExprType ccall_args)
 380                               stateAndAddrPrimTy
 381      in
 382      mkPrimDs the_ccall_op (map VarArg ccall_args)     `thenDs` \ the_ccall_app ->
 383      mkConDs  ioOkDataCon
 384               [TyArg res_ty, VarArg (Var s3), VarArg (Var addr_result)]
 385                                                        `thenDs` \ ioOkApp ->
 386      newSysLocalDs intPrimTy                           `thenDs` \ default_val ->
 387      let
 388         the_mkStablePtr = \ cont ->
 389           Case mkStablePtr_app
 390               (AlgAlts [(stateAndStablePtrPrimDataCon, [s2, stbl], cont)]
 391                        NoDefault)
 392
 393         the_ccall = \ cont ->
 394           Case the_ccall_app
 395                (AlgAlts [(stateAndAddrPrimDataCon, [s3, addrPrim], cont)]
 396                         NoDefault)
 397         the_addr2Int = \ cont ->
 398           Case the_addr2Int_app
 399                (PrimAlts [(mkMachInt 0, io_fail)]
 400                          (BindDefault default_val cont))
 401
 402         io_fail  = mkApp (Var eRROR_ID) [coreExprType wrap_res] [LitArg msg]
 403         full_msg = "Exception caught: " ++ _UNPK_ (nameString (idName i))
 404         msg      = NoRepStr (_PK_ full_msg)
 405
 406         wrap_res = addrPrim_wrapper ioOkApp
 407         the_body =
 408           mkTyLam tvs          $
 409           mkValLam  [cback,s1] $
 410           the_mkStablePtr      $
 411           the_ccall            $
 412           the_addr2Int  wrap_res
 413
 414       in
 415       newSysLocalDs (coreExprType the_body) `thenDs` \ ds ->
 416       newSysLocalDs (mkFunTy realWorldStatePrimTy
 417                              (coreExprType ioOkApp))  `thenDs` \ ap ->
 418       let
 419         io_app    = mkValApp (mkTyApp (Var ioDataCon) [res_ty]) [VarArg ap]
 420         io_action =
 421           mkTyLam tvs           $
 422           mkValLam  [cback_arg] $
 423           mkCoLetAny (NonRec ds the_body) $
 424           mkCoLetAny (NonRec ap (mkValApp (mkTyApp (Var ds) (map mkTyVarTy tvs)) [VarArg cback_arg])) $
 425           io_app
 426       in
 427       returnDs (NonRec i io_action, fe, hc_code, h_code, c_code)
 428  where
 429   (tvs,sans_foralls)               = splitForAllTys ty
 430   ([arg_ty], io_res)               = splitFunTys sans_foralls
 431   (ioOkDataCon, ioDataCon, res_ty) = getIoOkDataCon io_res
 432
 433   ioDataConTy                      = idType ioDataCon
 434   (io_tvs, ioDataConTy')           = splitForAllTys ioDataConTy
 435 --  ([arg_ty], _)                  = splitFunTys ioDataConTy'
 436   io_result_ty                     = applyTy (mkForAllTys io_tvs arg_ty) res_ty
 437
 438   export_ty                        = mkFunTy (mkTyConApp stablePtrTyCon [arg_ty]) arg_ty
 439
 440 toCName :: Id -> String
 441 toCName i = showSDoc (pprCode CStyle (ppr (idName i)))
 442
 443 \end{code}
 444
 445 %*
 446 %
 447 \subsection{Helper functions}
 448 %
 449 %*
 450
 451 @boxArg@ boxes up an argument in preparation for calling
 452 a function that maybe expects a boxed version of it, i.e.,
 453
 454 \begin{verbatim}
 455 boxArg Addr a# ==> let ds_foo :: Addr ; ds_foo = A# a# in f ...ds_foo..
 456 \end{verbatim}
 457
 458 \begin{code}
 459 boxArg :: Type                       -- Expected type after possible boxing of arg.
 460        -> Id                         -- The (unboxed) argument
 461        -> DsM (Id,                   -- To pass as the actual, boxed argument
 462                CoreExpr -> CoreExpr  -- Wrapper to box the arg
 463                 )
 464 boxArg box_ty prim_arg
 465   | isUnpointedType box_ty = returnDs (prim_arg, \body -> body)
 466     -- Data types with a single constructor,
 467     -- which has a single, primitive-typed arg
 468   | otherwise
 469   = newSysLocalDs box_ty                `thenDs` \ box_arg ->
 470     returnDs ( box_arg
 471              , Let (NonRec box_arg (mkCon box_data_con tys_applied [VarArg prim_arg]))
 472              )
 473   where
 474     maybe_boxed_prim_arg_ty  = maybeBoxedPrimType box_ty
 475     (Just (_,tys_applied,_)) = splitAlgTyConApp_maybe box_ty
 476     (Just (box_data_con, _)) = maybe_boxed_prim_arg_ty
 477 \end{code}
 478
 479 @foreign export@ed functions may return a value back to the outside world.
 480 @unboxResult@ takes care of converting from the (boxed) value that the
 481 exported action returns to the (unboxed) value that is returned across
 482 the border.
 483
 484 \begin{code}
 485 unboxResult :: Maybe Type            -- the (unboxed) type we want to return (along with the state token)
 486                                      -- Nothing => no result, just the state token.
 487             -> Type                  -- the (boxed) type we have in our hand.
 488             -> Id                    -- the state token
 489             -> Id                    -- boxed arg
 490             -> DsM (Type,            -- type of returned expression.
 491                     CoreExpr)        -- expr that unboxes result and returns state+unboxed result.
 492
 493 unboxResult mb_res_uboxed_ty res_ty new_s v_boxed
 494  | not (maybeToBool mb_res_uboxed_ty)
 495  =   -- no result, just return state token
 496     mkConDs stateDataCon [ TyArg realWorldTy
 497                          , VarArg (Var new_s)] `thenDs` \ the_st ->
 498     returnDs (realWorldStateTy, the_st)
 499
 500  | null data_cons
 501   -- oops! can't see the data constructors
 502  = can'tSeeDataConsPanic "result" res_ty
 503
 504  | (maybeToBool maybe_data_type) &&         -- Data type
 505    (null other_data_cons)        &&         --  - with one constructor,
 506    isUnpointedType res_uboxed_ty            --  - and of primitive type.
 507                                             -- (Glasgow extension)
 508  =
 509    newSysLocalDs res_uboxed_ty         `thenDs` \ v_unboxed ->
 510    mkConDs state_and_prim_datacon
 511            ((TyArg realWorldTy):map (TyArg ) tycon_arg_tys ++
 512             [ VarArg (Var new_s)
 513             , VarArg (Var v_unboxed)]) `thenDs` \ the_result ->
 514    let
 515     the_alt = (the_data_con, [v_unboxed], the_result)
 516    in
 517    returnDs (state_and_prim_ty,
 518              Case (Var v_boxed) (AlgAlts [the_alt] NoDefault))
 519
 520   | otherwise
 521   = pprPanic "unboxResult: " (ppr res_ty)
 522  where
 523     (Just res_uboxed_ty)                   = mb_res_uboxed_ty
 524
 525     maybe_data_type                        = splitAlgTyConApp_maybe res_ty
 526     Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
 527     (the_data_con : other_data_cons)       = data_cons
 528
 529     (state_and_prim_datacon, state_and_prim_ty) = getStatePairingConInfo res_uboxed_ty
 530
 531 \end{code}
 532
 533 Returned the unboxed type of a (primitive) type:
 534
 535 \begin{code}
 536 unboxTy :: Type -> Type
 537 unboxTy ty
 538  | isUnpointedType ty || (ty == unitTy) = ty
 539  | otherwise          =
 540      ASSERT( isFFIArgumentTy ty ) -- legal arg types subsume result types.
 541      case splitTyConApp_maybe ty of
 542         Just (tyc,ts) ->
 543                 case (tyConDataCons tyc) of
 544                   [dc] -> case (dataConArgTys dc ts) of
 545                               [ubox]   -> ubox
 546                                 -- HACK: for the array types, the prim type is
 547                                 -- the second tycon arg.
 548                               [_,ubox] -> ubox
 549                               _        -> pprPanic "unboxTy: " (ppr ty)
 550                   _ ->  pprPanic "unboxTy: " (ppr ty)
 551         _ ->  pprPanic "unboxTy: " (ppr ty)
 552
 553 \end{code}
 554
 555 %*
 556 %
 557 \subsection{Generating @foreign export@ stubs}
 558 %
 559 %*
 560
 561 [Severe hack to get @foreign export@ off the ground:]
 562
 563 For each @foreign export@ function, a C stub together with a @.hc@ stub
 564 is generated. The C stub enters the .hc stub, setting up the passing of
 565 parameters from C land to STG land through the use of global variables
 566 (don't worry, this just a temporary solution!). Ditto for the result.
 567
 568 [
 569 The generation of .hc code will go once the transition is
 570 made over to the new rts. Hence the hack, instead of extending
 571 AbsCSyn to cope with the .hc code generated.
 572 ]
 573
 574 \begin{code}
 575 fexportEntry :: FAST_STRING -> Id -> [Type] -> Maybe Type -> CallConv -> (SDoc, SDoc, SDoc)
 576 fexportEntry c_nm helper args res cc =
 577    ( paramArea $$ stopTemplate $$ startTemplate $$ vtblTemplate, h_code, c_code )
 578  where
 579   (h_code, c_code) = mkCStub c_nm h_stub_nm args res cc
 580
 581   paramArea =
 582     vcat (zipWith declVar ( res_ty : param_tys ) ( res_name : param_names ) )
 583
 584    -- name of the (Haskell) helper function generated by the desugarer.
 585   h_nm      = ppr helper
 586   h_stub_nm = text foreign_export_prefix <> h_nm
 587   closure   = h_nm <> text "_closure"
 588
 589   param_names = zipWith (\ i _ -> h_stub_nm <> text ('_':show i)) [1..] args
 590   param_tys   = map (ppr.typePrimRep) args
 591
 592   (res_name, res_ty) =
 593     case res of
 594       Nothing -> (empty, empty)
 595       Just t  -> (h_stub_nm <> text "_res", ppr (typePrimRep t))
 596
 597   startTemplate =
 598     vcat
 599       [ text "extern realWorldZh_closure;"
 600       , ptext SLIT("STGFUN") <> parens (h_stub_nm)
 601       , lbrace
 602       ,  ptext SLIT("FUNBEGIN;")
 603       ,  text  "RestoreAllStgRegs();"
 604       ,  stackCheck param_names
 605       ,  pushRetReg
 606       ,  pushCont
 607       ,  pushRealWorld
 608       ,  vcat (map pushArg (reverse param_names))
 609       ,  text "Node=" <> closure <> semi
 610       ,  text "ENT_VIA_NODE();"   -- ticky count
 611       ,  text "InfoPtr=(D_)(INFO_PTR(Node));"
 612       ,  text "JMP_(ENTRY_CODE(InfoPtr));"
 613       ,  text "FUNEND;"
 614       , rbrace
 615       ]
 616
 617   stopTemplate =
 618     vcat
 619       [ ptext SLIT("STGFUN") <> parens (text "stop" <> h_stub_nm <> text "DirectReturn")
 620       , lbrace
 621       ,  ptext SLIT("FUNBEGIN;")
 622       ,  assignResult
 623       ,  popRetReg
 624       ,  text "#if defined(__STG_GCC_REGS__)"
 625       ,  text "SaveAllStgRegs();"
 626       ,  text "#else"
 627       ,  text "SAVE_Hp = Hp;"
 628       ,  text "SAVE_HpLim = HpLim;"
 629       ,  text "#endif"
 630       ,  text "JMP_(miniInterpretEnd);"
 631       ,  text "FUNEND;"
 632       , rbrace
 633       ]
 634
 635   vtblTemplate =
 636     vcat
 637       [ text "const W_ vtbl_" <> h_stub_nm <> text "[] = {"
 638       , vcat (punctuate comma (replicate 8 dir_ret))
 639       , text "};"
 640       ]
 641    where
 642     dir_ret = text "(W_)stop" <> h_stub_nm <> text "DirectReturn"
 643
 644   assignResult =
 645     case res of
 646       Nothing -> empty
 647       Just _  -> res_name <> equals <> text "R3.i;" -- wrong
 648
 649   pushRetReg =
 650     text "SpB -= BREL(1);" $$
 651     text "*SpB = (W_)RetReg;"
 652
 653   popRetReg =
 654     text "RetReg=(StgRetAddr)*SpB;" $$
 655     text "SpB += BREL(1);"
 656
 657   pushCont =
 658     text "RetReg=(StgRetAddr)UNVEC(stop" <> h_stub_nm <>
 659     text "DirectReturn,vtbl_" <> h_stub_nm <> text ");"
 660
 661   pushRealWorld =
 662     text "SpB -= BREL(1);" $$
 663     text "*SpB = (W_)realWorldZh_closure;"
 664
 665
 666   pushArg nm =
 667      text "SpB -= BREL(1);" $$
 668      text "*SpB = (W_)" <> nm <> semi
 669
 670   stackCheck args =
 671      text "STK_CHK(LivenessReg,0," <> sz <> text ",0,0,0,0);"
 672    where
 673      sz = parens $
 674           hsep $ punctuate (text " + ") (text "1":(map sizer args))
 675
 676      sizer x = text "BYTES_TO_STGWORDS" <> parens (text "sizeof" <> parens x)
 677
 678 foreign_export_prefix :: String
 679 foreign_export_prefix = "__fexp_"
 680
 681 mkCStub :: FAST_STRING -> SDoc -> [Type] -> Maybe Type -> CallConv -> (SDoc, SDoc)
 682 mkCStub c_nm h_stub_nm args res cc =
 683  ( hsep [ ptext SLIT("extern")
 684         , cResType
 685         , pprCconv
 686         , ptext c_nm
 687         , parens (hsep (punctuate comma (zipWith (<+>) stubParamTypes stubArgs)))
 688         , semi
 689         ]
 690  , vcat
 691      [ externDecls
 692      , cResType
 693      , pprCconv
 694      , ptext c_nm <> parens (hsep (punctuate comma stubArgs))
 695      , vcat (zipWith declVar stubParamTypes stubArgs)
 696      , lbrace
 697      ,  vcat (zipWith assignArgs param_names c_args)
 698      ,  text "miniInterpret" <> parens (parens (text "StgFunPtr") <> h_stub_nm) <> semi
 699      ,  returnResult
 700      , rbrace
 701      ]
 702  )
 703  where
 704   -- tedious hack to let us deal with caller-cleans-up-stack
 705   -- discipline that the C calling convention uses.
 706   stubParamTypes
 707      | cc == cCallConv = ptext SLIT("void*") : cParamTypes
 708      | otherwise       = cParamTypes
 709   stubArgs
 710      | cc == cCallConv = ptext SLIT("_a0") : c_args
 711      | otherwise       = c_args
 712
 713   param_names = zipWith (\ i _ -> h_stub_nm <> text ('_':show i)) [1..] args
 714   cParamTypes  = map (text.showPrimRepToUser.typePrimRep) args
 715   (cResType, cResDecl) =
 716    case res of
 717      Nothing -> (text "void", empty)
 718      Just t  -> (text (showPrimRepToUser (typePrimRep t)),
 719                  text "extern" <+> cResType <+> res_name <> semi)
 720
 721   pprCconv
 722    | cc == cCallConv = empty
 723    | otherwise       = pprCallConv cc
 724
 725   externDecls =
 726     vcat (zipWith mkExtern cParamTypes param_names) $$
 727     cResDecl $$
 728     text "extern void" <+> h_stub_nm <> text "();"
 729
 730   mkExtern ty nm = text "extern" <+> ty <+> nm <> semi
 731
 732   c_args = zipWith (\ _ n -> text ('a':show n)) args [0..]
 733
 734   assignArgs p_nm c_arg = p_nm <+> equals <+> c_arg <> semi
 735
 736   returnResult =
 737     case res of
 738       Nothing -> empty
 739       Just _  -> text "return" <+> res_name <> semi
 740
 741   (res_name, res_ty) =
 742     case res of
 743       Nothing -> (empty, empty)
 744       Just t  -> (h_stub_nm <> text "_res", ppr (typePrimRep t))
 745
 746 declVar :: SDoc -> SDoc -> SDoc
 747 declVar ty var = ty <+> var <> semi
 748
 749 \end{code}
 750
 751 When exporting
 752
 753    f :: Int -> Int -> Int -> IO Int
 754
 755 we'll emit the following stuff into the .hc file
 756
 757 \begin{pseudocode}
 758 StgInt __f_param_1;
 759 StgInt __f_param_2;
 760 StgInt __f_param_3;
 761 StgInt __f_res;
 762
 763 STGFUN(ds_f)
 764 {
 765    FUNBEGIN;
 766    RestoreAllStgRegs();
 767    STK_CHK(LivenessReg,0/*A*/,(SIZE_IN_WORDS(StgInt) +
 768                                SIZE_IN_WORDS(StgInt) +
 769                                SIZE_IN_WORDS(StgInt) + 1)/*B*/, 0, 0, 0/*prim*/, 0/*re-enter*/);
 770    RetReg = (StgRetAddr) UNVEC(stopds_fDirectReturn,vtbl_stopds_f);
 771    SpB  -= BREL(1);
 772    *SpB  = (W_)__f_param_3;
 773    SpB  -= BREL(1);
 774    *SpB  = (W_)__f_param_2;
 775    SpB  -= BREL(1);
 776    *SpB  = (W_)__f_param_1;
 777
 778     SpB -= BREL(1);
 779     *SpB = (W_) realWorldZh_closure;
 780
 781     Node = ds_f_helper_closure;
 782     ENT_VIA_NODE();
 783     InfoPtr=(D_)(INFO_PTR(Node));
 784     JMP_(ENTRY_CODE(InfoPtr));
 785     FUNEND;
 786 }
 787
 788 STGFUN(stop_ds_fDirectReturn)
 789 {
 790    FUNBEGIN;
 791    __f_res=R1.i;
 792    SaveAllStgRegs();
 793    RESUME(miniInterpretEnd);
 794    FUNEND;
 795 }
 796
 797 const W_ vtbl_stopds_f[] = {
 798   (W_) stopds_fDirectReturn,
 799   (W_) stopds_fDirectReturn,
 800   (W_) stopds_fDirectReturn,
 801   (W_) stopds_fDirectReturn,
 802   (W_) stopds_fDirectReturn,
 803   (W_) stopds_fDirectReturn,
 804   (W_) stopds_fDirectReturn,
 805   (W_) stopds_fDirectReturn
 806 };
 807
 808 \end{pseudocode}
 809
 810 and a C stub
 811
 812 \begin{pseudocode}
 813 extern StgInt __f_param_1;
 814 extern StgInt __f_param_2;
 815 extern StgInt __f_param_3;
 816 extern StgInt __f_res;
 817
 818 extern void ds_f();
 819 extern void miniInterpret(StgAddr);
 820
 821 int
 822 f(a1,a2,a3)
 823 int a1;
 824 int a2;
 825 int a3;
 826 {
 827  __f_param_1=a1;
 828  __f_param_2=a2;
 829  __f_param_3=a3;
 830  miniInterpret((StgAddr)ds_f);
 831  return (__f_res);
 832 }
 833
 834 \end{pseudocode}