X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsForeign.lhs;h=034949fc4519ba8d4720d18721f0f4a35e36c741;hb=e9f9ec1e57d53b9302a395ce0d02c0fa59e28341;hp=9127676cf2aae092cf4ebfc9e8561939903399c6;hpb=909691a910d99495baf396fca3ab7e82f2e2eb51;p=ghc-hetmet.git

diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index 9127676..034949f 100644
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -19,6 +19,7 @@ import DsMonad
 import HsSyn
 import DataCon
 import CoreUtils
+import CoreUnfold
 import Id
 import Literal
 import Module
@@ -91,8 +92,6 @@ dsForeigns fos = do
    do_decl (ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv))) = do
       (h, c, _, _) <- dsFExport id (idType id) ext_nm cconv False
       return (h, c, [id], [])
-
-   do_decl d = pprPanic "dsForeigns/do_decl" (ppr d)
 \end{code}
 
 
@@ -128,13 +127,6 @@ 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
@@ -200,30 +192,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
@@ -237,9 +206,10 @@ dsFCall fn_id fcall = do
         -- Build the wrapper
         work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
         wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
-        wrap_rhs     = mkInlineMe (mkLams (tvs ++ args) wrapper_body)
+        wrap_rhs     = mkLams (tvs ++ args) wrapper_body
+        fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineRule wrap_rhs (Just (length args))
     
-    return ([(work_id, work_rhs), (fn_id, wrap_rhs)], empty, empty)
+    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs)], empty, empty)
 \end{code}
 
 
@@ -599,8 +569,8 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
 						<> comma <> text "cap") <> semi
      ,   assignCResult
      ,   ptext (sLit "rts_unlock(cap);")
-     ,   if res_hty_is_unit then empty
-            else if libffi 
+     ,   ppUnless res_hty_is_unit $
+         if libffi 
                   then char '*' <> parens (cResType <> char '*') <> 
                        ptext (sLit "resp = cret;")
                   else ptext (sLit "return cret;")