From 5b7e2a875b089f31cd8dedb52d47ef9a93f276be Mon Sep 17 00:00:00 2001
From: Duncan Coutts <duncan@well-typed.com>
Date: Tue, 9 Jun 2009 10:59:45 +0000
Subject: [PATCH] Desugaring for "foreign import prim" Unlike normal foreign
 imports which desugar into a separate worker and wrapper,
 we use just a single wrapper decleration. The
 representation in Core of the call is currently as a
 foreign call. This means the args are all treated as fully
 strict. This is ok at the moment because we restrict the
 types for foreign import prim to be of unboxed types,
 however in future we may want to make prim imports be the
 normal cmm calling convention for Haskell functions, in
 which case we would not be able to assume all args are
 strict. At that point it may make more sense to represent
 cmm/prim calls distinct from foreign calls, and more like
 the we the existing PrimOp calls are handled.

---
 compiler/deSugar/DsForeign.lhs |   37 ++++++++++++++++++++++++++++++++++++-
 1 file changed, 36 insertions(+), 1 deletion(-)

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
 
-- 
1.7.10.4