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