import HsSyn
import DataCon
import CoreUtils
+import CoreUnfold
import Id
import Literal
import Module
import TyCon
import Coercion
import TcType
-import Var
import CmmExpr
+import qualified Var
import CmmUtils
import HscTypes
import ForeignCall
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)
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
-- 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}
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
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
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
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 $$
<> 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
]
+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 =
<> 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)
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)]
-- 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