-- | Foreign primitive calls
--
-- This is for `@foreign import prim@' declarations.
--
-- Currently, at the core level we pretend that these primitive calls are
-- foreign calls. It may make more sense in future to have them as a distinct
-- kind of Id, or perhaps to bundle them with PrimOps since semantically and for
-- calling convention they are really prim ops.
module GHC.HsToCore.Foreign.Prim
  ( dsPrimCall
  )
where

import GHC.Prelude

import GHC.Tc.Utils.Monad        -- temp
import GHC.Tc.Utils.TcType

import GHC.Core
import GHC.Core.Type
import GHC.Core.Coercion

import GHC.HsToCore.Monad
import GHC.HsToCore.Foreign.Call

import GHC.Types.Id
import GHC.Types.ForeignStubs
import GHC.Types.ForeignCall

dsPrimCall :: Id -> Coercion -> ForeignCall
           -> DsM ([(Id, Expr TyVar)], CHeader, CStub)
dsPrimCall :: Id
-> Coercion -> ForeignCall -> DsM ([(Id, Expr Id)], CHeader, CStub)
dsPrimCall Id
fn_id Coercion
co ForeignCall
fcall = do
    let
        ty :: Type
ty                   = Coercion -> Type
coercionLKind Coercion
co
        ([Id]
tvs, Type
fun_ty)        = Type -> ([Id], Type)
tcSplitForAllInvisTyVars Type
ty
        ([Scaled Type]
arg_tys, Type
io_res_ty) = Type -> ([Scaled Type], Type)
tcSplitFunTys Type
fun_ty

    [Id]
args <- [Scaled Type] -> DsM [Id]
newSysLocalsDs [Scaled Type]
arg_tys  -- no FFI representation polymorphism

    Unique
ccall_uniq <- TcRnIf DsGblEnv DsLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
    let
        call_app :: Expr Id
call_app = Unique -> ForeignCall -> [Expr Id] -> Type -> Expr Id
mkFCall Unique
ccall_uniq ForeignCall
fcall ((Id -> Expr Id) -> [Id] -> [Expr Id]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Expr Id
forall b. Id -> Expr b
Var [Id]
args) Type
io_res_ty
        rhs :: Expr Id
rhs      = [Id] -> Expr Id -> Expr Id
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
tvs ([Id] -> Expr Id -> Expr Id
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
args Expr Id
call_app)
        rhs' :: Expr Id
rhs'     = Expr Id -> Coercion -> Expr Id
forall b. Expr b -> Coercion -> Expr b
Cast Expr Id
rhs Coercion
co
    ([(Id, Expr Id)], CHeader, CStub)
-> DsM ([(Id, Expr Id)], CHeader, CStub)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Id
fn_id, Expr Id
rhs')], CHeader
forall a. Monoid a => a
mempty, CStub
forall a. Monoid a => a
mempty)