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