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