From 3891512c4c770dadd0372ad84d2dec72b34652d2 Mon Sep 17 00:00:00 2001
From: Simon Marlow <marlowsd@gmail.com>
Date: Mon, 29 Mar 2010 15:42:20 +0000
Subject: [PATCH] fix return type cast in f.i.wrapper when using libffi
 (#3516)

Original fix submitted by
  Sergei Trofimovich <slyfox@community.haskell.org>
modified by me:
 - exclude 64-bit types
 - compare uniques, not strings
 - #include "ffi.h" is conditional
---
 compiler/deSugar/DsForeign.lhs |   26 ++++++++++++++++++++------
 compiler/main/CodeOutput.lhs   |    6 ++++++
 2 files changed, 26 insertions(+), 6 deletions(-)

diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index 034949f..51f03c2 100644
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -488,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
@@ -571,7 +584,7 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
      ,   ptext (sLit "rts_unlock(cap);")
      ,   ppUnless res_hty_is_unit $
          if libffi 
-                  then char '*' <> parens (cResType <> char '*') <> 
+                  then char '*' <> parens (ffi_cResType <> char '*') <>
                        ptext (sLit "resp = cret;")
                   else ptext (sLit "return cret;")
      , rbrace
@@ -608,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)]
diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs
index 2d68b83..83f23cf 100644
--- a/compiler/main/CodeOutput.lhs
+++ b/compiler/main/CodeOutput.lhs
@@ -27,6 +27,7 @@ import Util
 import Cmm		( RawCmm )
 import HscTypes
 import DynFlags
+import Config
 
 import ErrUtils		( dumpIfSet_dyn, showPass, ghcExit )
 import Outputable
@@ -225,6 +226,10 @@ outputForeignStubs dflags mod location stubs
 	       concatMap mk_include (includes rts_pkg)
 	    mk_include i = "#include \"" ++ i ++ "\"\n"
 
+            -- wrapper code mentions the ffi_arg type, which comes from ffi.h
+            ffi_includes | cLibFFI   = "#include \"ffi.h\"\n"
+                         | otherwise = ""
+
 	stub_h_file_exists
            <- outputForeignStubs_help stub_h stub_h_output_w
 		("#include \"HsFFI.h\"\n" ++ cplusplus_hdr) cplusplus_ftr
@@ -237,6 +242,7 @@ outputForeignStubs dflags mod location stubs
 		("#define IN_STG_CODE 0\n" ++ 
 		 "#include \"Rts.h\"\n" ++
 		 rts_includes ++
+		 ffi_includes ++
 		 cplusplus_hdr)
 		 cplusplus_ftr
 	   -- We're adding the default hc_header to the stub file, but this
-- 
1.7.10.4