add -fsimpleopt-before-flatten

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

diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index 5340039..2c2d7f2 100644 (file)
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -43,7 +43,7 @@ import Outputable
 import FastString
 import Config
 import Constants
-
+import OrdList
 import Data.Maybe
 import Data.List
 \end{code}
@@ -66,9 +66,9 @@ type Binding = (Id, CoreExpr) -- No rec/nonrec structure;
                                -- the occurrence analyser will sort it all out
 
 dsForeigns :: [LForeignDecl Id] 
-          -> DsM (ForeignStubs, [Binding])
+          -> DsM (ForeignStubs, OrdList Binding)
 dsForeigns [] 
-  = return (NoStubs, [])
+  = return (NoStubs, nilOL)
 dsForeigns fos = do
     fives <- mapM do_ldecl fos
     let
@@ -79,7 +79,7 @@ dsForeigns fos = do
     return (ForeignStubs 
              (vcat hs)
              (vcat cs $$ vcat fe_init_code),
-           (concat bindss))
+            foldr (appOL . toOL) nilOL bindss)
   where
    do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl)
             
@@ -207,7 +207,7 @@ dsFCall fn_id fcall = do
         work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
         wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
         wrap_rhs     = mkLams (tvs ++ args) wrapper_body
-        fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineRule InlSat wrap_rhs (length args)
+        fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineUnfolding (Just (length args)) wrap_rhs
     
     return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs)], empty, empty)
 \end{code}
@@ -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
@@ -512,7 +525,7 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
   the_cfun
      = case maybe_target of
           Nothing    -> text "(StgClosure*)deRefStablePtr(the_stableptr)"
-          Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"
+          Just hs_fn -> char '&' <> ppr hs_fn <> text (closureSuffix hs_fn)
 
   cap = text "cap" <> comma
 
@@ -537,9 +550,8 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
   extern_decl
      = case maybe_target of
           Nothing -> empty
-          Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi
+          Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text (closureSuffix hs_fn) <> semi
 
-   
   -- finally, the whole darn thing
   c_bits =
     space $$
@@ -571,12 +583,16 @@ 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
      ]
 
+closureSuffix :: Id -> String
+closureSuffix hs_fn =
+    if depth==0 then "_closure" else "_"++(show depth)++"closure"
+        where depth = getNameDepth (Var.varName hs_fn)
 
 foreignExportInitialiser :: Id -> SDoc
 foreignExportInitialiser hs_fn =
@@ -593,11 +609,10 @@ foreignExportInitialiser hs_fn =
          <> text "() __attribute__((constructor));"
     , text "static void stginit_export_" <> ppr hs_fn <> text "()"
     , braces (text "getStablePtr"
-       <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure")
+       <> parens (text "(StgPtr) &" <> ppr hs_fn <> text (closureSuffix hs_fn))
        <> semi)
     ]
 
-
 mkHObj :: Type -> SDoc
 mkHObj t = text "rts_mk" <> text (showFFIType t)
 
@@ -608,11 +623,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)]