X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsForeign.lhs;h=9dea2ade73665cc9c15b6b852df88f0206e657bf;hp=7071ab7ef470e2e247f698148f2569d62eeec056;hb=5b7e2a875b089f31cd8dedb52d47ef9a93f276be;hpb=2da37f4f15790377900fa6c38ff8fdcd394dfaa2 diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index 7071ab7..9dea2ad 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -155,6 +155,8 @@ dsCImport id (CLabel cid) cconv _ = do 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 _ @@ -243,6 +245,39 @@ dsFCall fn_id fcall = do %************************************************************************ %* * +\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} %* * %************************************************************************ @@ -487,7 +522,7 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc 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