import HsSyn
import DataCon
-import MachOp
-import SMRep
import CoreUtils
import Id
import Literal
import TcType
import Var
+import CmmExpr
+import CmmUtils
import HscTypes
import ForeignCall
import TysWiredIn
-> DsM ([Binding], SDoc, SDoc)
dsCImport id (CLabel cid) cconv _ = do
let ty = idType id
+ fod = case splitTyConApp_maybe (repType ty) of
+ Just (tycon, _)
+ | tyConUnique tycon == funPtrTyConKey ->
+ IsFunction
+ _ -> IsData
(resTy, foRhs) <- resultWrapper ty
ASSERT(fromJust resTy `coreEqType` addrPrimTy) -- typechecker ensures this
let
- rhs = foRhs (mkLit (MachLabel cid stdcall_info))
+ rhs = foRhs (Lit (MachLabel cid stdcall_info fod))
stdcall_info = fun_type_arg_stdcall_info cconv ty
in
return ([(id, rhs)], empty, empty)
+dsCImport id (CFunction target) cconv@PrimCallConv safety
+ = dsPrimCall id (CCall (CCallSpec target cconv safety))
dsCImport id (CFunction target) cconv safety
= dsFCall id (CCall (CCallSpec target cconv safety))
dsCImport id CWrapper cconv _
= let
(_tvs,sans_foralls) = tcSplitForAllTys arg_ty
(fe_arg_tys, _orig_res_ty) = tcSplitFunTys sans_foralls
- in
- Just $ sum (map (machRepByteWidth . typeMachRep . getPrimTyOf) fe_arg_tys)
+ in Just $ sum (map (widthInBytes . typeWidth . typeCmmType . getPrimTyOf) fe_arg_tys)
fun_type_arg_stdcall_info _other_conv _
= Nothing
\end{code}
%************************************************************************
%* *
+\subsection{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.
+
+\begin{code}
+dsPrimCall :: Id -> ForeignCall -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
+dsPrimCall fn_id fcall = do
+ let
+ ty = idType fn_id
+ (tvs, fun_ty) = tcSplitForAllTys ty
+ (arg_tys, io_res_ty) = tcSplitFunTys fun_ty
+ -- Must use tcSplit* functions because we want to
+ -- see that (IO t) in the corner
+
+ args <- newSysLocalsDs arg_tys
+
+ ccall_uniq <- newUnique
+ let
+ call_app = mkFCall ccall_uniq fcall (map Var args) io_res_ty
+ rhs = mkLams tvs (mkLams args call_app)
+ return ([(fn_id, rhs)], empty, empty)
+
+\end{code}
+
+%************************************************************************
+%* *
\subsection{Foreign export}
%* *
%************************************************************************
For each `@foreign export foo@' in a module M we generate:
\begin{itemize}
\item a C function `@foo@', which calls
-\item a Haskell stub `@M.$ffoo@', which calls
+\item a Haskell stub `@M.\$ffoo@', which calls
\end{itemize}
the user-written Haskell function `@M.foo@'.
-}
adj_args = [ mkIntLitInt (ccallConvToInt cconv)
, Var stbl_value
- , mkLit (MachLabel fe_nm mb_sz_args)
- , mkLit (mkStringLit typestring)
+ , Lit (MachLabel fe_nm mb_sz_args IsFunction)
+ , Lit (mkMachString typestring)
]
-- name of external entry point providing these services.
-- (probably in the RTS.)
, Lam stbl_value ccall_adj
]
- fed = (id `setInlinePragma` NeverActive, io_app)
+ fed = (id `setInlineActivation` NeverActive, io_app)
-- Never inline the f.e.d. function, because the litlit
-- might not be in scope in other modules.
)
mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
= (header_bits, c_bits, type_string,
- sum [ machRepByteWidth rep | (_,_,_,rep) <- aug_arg_info] -- all the args
+ sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args
+ -- NB. the calculation here isn't strictly speaking correct.
+ -- We have a primitive Haskell type (eg. Int#, Double#), and
+ -- we want to know the size, when passed on the C stack, of
+ -- the associated C type (eg. HsInt, HsDouble). We don't have
+ -- this information to hand, but we know what GHC's conventions
+ -- are for passing around the primitive Haskell types, so we
+ -- use that instead. I hope the two coincide --SDM
)
where
-- list the arguments to the C function
arg_info :: [(SDoc, -- arg name
SDoc, -- C type
Type, -- Haskell type
- MachRep)] -- the MachRep
+ CmmType)] -- the CmmType
arg_info = [ let stg_type = showStgType ty in
(arg_cname n stg_type,
stg_type,
ty,
- typeMachRep (getPrimTyOf ty))
+ typeCmmType (getPrimTyOf ty))
| (ty,n) <- zip arg_htys [1::Int ..] ]
arg_cname n stg_ty
stable_ptr_arg =
(text "the_stableptr", text "StgStablePtr", undefined,
- typeMachRep (mkStablePtrPrimTy alphaTy))
+ typeCmmType (mkStablePtrPrimTy alphaTy))
-- stuff to do with the return type of the C function
res_hty_is_unit = res_hty `coreEqType` unitTy -- Look through any newtypes
pprCconv = case cc of
CCallConv -> empty
StdCallConv -> text (ccallConvAttribute cc)
- CmmCallConv -> panic "mkFExportCBits/pprCconv CmmCallConv"
+ _ -> panic ("mkFExportCBits/pprCconv " ++ showPpr cc)
header_bits = ptext (sLit "extern") <+> fun_proto <> semi
]
--- NB. the calculation here isn't strictly speaking correct.
--- We have a primitive Haskell type (eg. Int#, Double#), and
--- we want to know the size, when passed on the C stack, of
--- the associated C type (eg. HsInt, HsDouble). We don't have
--- this information to hand, but we know what GHC's conventions
--- are for passing around the primitive Haskell types, so we
--- use that instead. I hope the two coincide --SDM
-typeMachRep :: Type -> MachRep
-typeMachRep ty = argMachRep (typeCgRep ty)
-
mkHObj :: Type -> SDoc
mkHObj t = text "rts_mk" <> text (showFFIType t)
Just (tc,_) -> tc
Nothing -> pprPanic "showFFIType" (ppr t)
-insertRetAddr :: CCallConv -> [(SDoc, SDoc, Type, MachRep)]
- -> [(SDoc, SDoc, Type, MachRep)]
+insertRetAddr :: CCallConv -> [(SDoc, SDoc, Type, CmmType)]
+ -> [(SDoc, SDoc, Type, CmmType)]
#if !defined(x86_64_TARGET_ARCH)
insertRetAddr CCallConv args = ret_addr_arg : args
insertRetAddr _ args = args
-- need to flush a register argument to the stack (See rts/Adjustor.c for
-- details).
insertRetAddr CCallConv args = go 0 args
- where go 6 args = ret_addr_arg : args
+ where go :: Int -> [(SDoc, SDoc, Type, CmmType)]
+ -> [(SDoc, SDoc, Type, CmmType)]
+ go 6 args = ret_addr_arg : args
go n (arg@(_,_,_,rep):args)
- | I64 <- rep = arg : go (n+1) args
+ | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args
| otherwise = arg : go n args
go _ [] = []
insertRetAddr _ args = args
#endif
-ret_addr_arg :: (SDoc, SDoc, Type, MachRep)
+ret_addr_arg :: (SDoc, SDoc, Type, CmmType)
ret_addr_arg = (text "original_return_addr", text "void*", undefined,
- typeMachRep addrPrimTy)
+ typeCmmType addrPrimTy)
-- This function returns the primitive type associated with the boxed
-- type argument to a foreign export (eg. Int ==> Int#).
projects / ghc-hetmet.git / blobdiff