Implement INLINABLE pragma

[ghc-hetmet.git] / compiler / deSugar / DsForeign.lhs

diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index 83dac63..d73cd53 100644 (file)
--- 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
@@ -205,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` mkInlineUnfolding (Just (length args)) wrap_rhs
     
-    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}
 
 
@@ -486,6 +488,19 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
   cResType | res_hty_is_unit = text "void"
           | otherwise       = showStgType res_hty
 
+  -- when the return type is integral and word-sized or smaller, it
+  -- must be assigned as type ffi_arg (#3516).  To see what type
+  -- libffi is expecting here, take a look in its own testsuite, e.g.
+  -- libffi/testsuite/libffi.call/cls_align_ulonglong.c
+  ffi_cResType
+     | is_ffi_arg_type = text "ffi_arg"
+     | otherwise       = cResType
+     where
+       res_ty_key = getUnique (getName (typeTyCon res_hty))
+       is_ffi_arg_type = res_ty_key `notElem`
+              [floatTyConKey, doubleTyConKey,
+               int64TyConKey, word64TyConKey]
+
   -- Now we can cook up the prototype for the exported function.
   pprCconv = case cc of
                CCallConv   -> empty
@@ -567,9 +582,9 @@ 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 
-                  then char '*' <> parens (cResType <> char '*') <> 
+     ,   ppUnless res_hty_is_unit $
+         if libffi 
+                  then char '*' <> parens (ffi_cResType <> char '*') <>
                        ptext (sLit "resp = cret;")
                   else ptext (sLit "return cret;")
      , rbrace
@@ -606,11 +621,12 @@ showStgType :: Type -> SDoc
 showStgType t = text "Hs" <> text (showFFIType t)
 
 showFFIType :: Type -> String
-showFFIType t = getOccString (getName tc)
- where
-  tc = case tcSplitTyConApp_maybe (repType t) of
-           Just (tc,_) -> tc
-           Nothing     -> pprPanic "showFFIType" (ppr t)
+showFFIType t = getOccString (getName (typeTyCon t))
+
+typeTyCon :: Type -> TyCon
+typeTyCon ty = case tcSplitTyConApp_maybe (repType ty) of
+                 Just (tc,_) -> tc
+                Nothing     -> pprPanic "DsForeign.typeTyCon" (ppr ty)
 
 insertRetAddr :: CCallConv -> [(SDoc, SDoc, Type, CmmType)]
                            -> [(SDoc, SDoc, Type, CmmType)]