X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsForeign.lhs;h=1b1b7f04f4a93cfc579734aa8f6ad2ffad64513c;hp=080289e8f9c5e49b8d6b9ef483737498c8ba5ca8;hb=1fede4bc9501744bf2269ce2a4cb9fb735969caa;hpb=176fa33f17dd78355cc572e006d2ab26898e2c69

diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index 080289e..1b1b7f0 100644
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -124,17 +124,10 @@ because it exposes the boxing to the call site.
 dsFImport :: Id
 	  -> ForeignImport
 	  -> DsM ([Binding], SDoc, SDoc)
-dsFImport id (CImport cconv safety _ _ spec) = do
+dsFImport id (CImport cconv safety _ spec) = do
     (ids, h, c) <- dsCImport id spec cconv safety
     return (ids, h, c)
 
-  -- FIXME: the `lib' field is needed for .NET ILX generation when invoking
-  --	    routines that are external to the .NET runtime, but GHC doesn't
-  --	    support such calls yet; if `nullFastString lib', the value was not given
-dsFImport id (DNImport spec) = do
-    (ids, h, c) <- dsFCall id (DNCall spec)
-    return (ids, h, c)
-
 dsCImport :: Id
 	  -> CImportSpec
 	  -> CCallConv
@@ -142,14 +135,21 @@ dsCImport :: Id
 	  -> 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 (Lit (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 _
@@ -193,30 +193,7 @@ dsFCall fn_id fcall = do
     let
         work_arg_ids  = [v | Var v <- val_args] -- All guaranteed to be vars
 
-        forDotnet =
-         case fcall of
-           DNCall{} -> True
-           _        -> False
-
-        topConDs
-          | forDotnet = Just <$> dsLookupGlobalId checkDotnetResName
-          | otherwise = return Nothing
-
-        augmentResultDs
-          | forDotnet = do
-                return (\ (mb_res_ty, resWrap) ->
-                              case mb_res_ty of
-                                Nothing -> (Just (mkTyConApp (tupleTyCon Unboxed 1)
-                                                             [ addrPrimTy ]),
-                                                 resWrap)
-                                Just x  -> (Just (mkTyConApp (tupleTyCon Unboxed 2)
-                                                             [ x, addrPrimTy ]),
-                                                 resWrap))
-          | otherwise = return id
-
-    augment <- augmentResultDs
-    topCon <- topConDs
-    (ccall_result_ty, res_wrapper) <- boxResult augment topCon io_res_ty
+    (ccall_result_ty, res_wrapper) <- boxResult io_res_ty
 
     ccall_uniq <- newUnique
     work_uniq  <- newUnique
@@ -238,6 +215,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}
 %*									*
 %************************************************************************
@@ -355,7 +365,7 @@ dsFExportDynamic id cconv = do
          -}
         adj_args      = [ mkIntLitInt (ccallConvToInt cconv)
                         , Var stbl_value
-                        , Lit (MachLabel fe_nm mb_sz_args)
+                        , Lit (MachLabel fe_nm mb_sz_args IsFunction)
                         , Lit (mkMachString typestring)
                         ]
           -- name of external entry point providing these services.
@@ -382,7 +392,7 @@ dsFExportDynamic id cconv = do
                         , 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.
 
@@ -482,7 +492,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