import FastString
import Config
import Constants
-
+import OrdList
import Data.Maybe
import Data.List
\end{code}
-- 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
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)
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 needSaturated 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}
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
, 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
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)]