summaryrefslogtreecommitdiff
path: root/compiler/GHC/HsToCore/Foreign/Prim.hs
blob: 888f2a1d6ee4fdd0adedd9b61f908f325b150e22 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
-- | 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 fn_id co fcall = do
    let
        ty                   = coercionLKind co
        (tvs, fun_ty)        = tcSplitForAllInvisTyVars ty
        (arg_tys, io_res_ty) = tcSplitFunTys fun_ty

    args <- newSysLocalsDs arg_tys  -- no FFI representation polymorphism

    ccall_uniq <- newUnique
    let
        call_app = mkFCall ccall_uniq fcall (map Var args) io_res_ty
        rhs      = mkLams tvs (mkLams args call_app)
        rhs'     = Cast rhs co
    return ([(fn_id, rhs')], mempty, mempty)