merge GHC HEAD

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

diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index 5340039..aee1594 100644 (file)
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -28,7 +28,6 @@ import Type
 import TyCon
 import Coercion
 import TcType
-import Var
 
 import CmmExpr
 import CmmUtils
@@ -43,7 +42,7 @@ import Outputable
 import FastString
 import Config
 import Constants
-
+import OrdList
 import Data.Maybe
 import Data.List
 \end{code}
@@ -66,9 +65,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 +78,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)
             
@@ -140,7 +139,7 @@ dsCImport id (CLabel cid) cconv _ = do
                  IsFunction
              _ -> IsData
    (resTy, foRhs) <- resultWrapper ty
-   ASSERT(fromJust resTy `coreEqType` addrPrimTy)    -- typechecker ensures this
+   ASSERT(fromJust resTy `eqType` addrPrimTy)    -- typechecker ensures this
     let
         rhs = foRhs (Lit (MachLabel cid stdcall_info fod))
         stdcall_info = fun_type_arg_stdcall_info cconv ty
@@ -207,7 +206,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}
@@ -382,9 +381,9 @@ dsFExportDynamic id cconv = do
     ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])
         -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
 
-    let io_app = mkLams tvs                $
-                 Lam cback                 $
-                 mkCoerceI (mkSymCoI co)   $
+    let io_app = mkLams tvs                  $
+                 Lam cback                   $
+                 mkCoerce (mkSymCo co) $
                  mkApps (Var bindIOId)
                         [ Type stable_ptr_ty
                         , Type res_ty       
@@ -483,11 +482,24 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
         typeCmmType (mkStablePtrPrimTy alphaTy))
 
   -- stuff to do with the return type of the C function
-  res_hty_is_unit = res_hty `coreEqType` unitTy        -- Look through any newtypes
+  res_hty_is_unit = res_hty `eqType` unitTy    -- Look through any newtypes
 
   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 +524,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 +549,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 +582,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 +608,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 +622,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)]
@@ -661,7 +676,7 @@ getPrimTyOf ty
 -- e.g. 'W' is a signed 32-bit integer.
 primTyDescChar :: Type -> Char
 primTyDescChar ty
- | ty `coreEqType` unitTy = 'v'
+ | ty `eqType` unitTy = 'v'
  | otherwise
  = case typePrimRep (getPrimTyOf ty) of
      IntRep     -> signed_word