import Module
import Name
import Type
+import TyCon
import Coercion
import TcType
-> CCallConv
-> Safety
-> DsM ([Binding], SDoc, SDoc)
-dsCImport id (CLabel cid) _ _ = do
- (resTy, foRhs) <- resultWrapper (idType id)
+dsCImport id (CLabel cid) cconv _ = do
+ let ty = idType id
+ (resTy, foRhs) <- resultWrapper ty
ASSERT(fromJust resTy `coreEqType` addrPrimTy) -- typechecker ensures this
- let rhs = foRhs (mkLit (MachLabel cid Nothing)) in
+ let
+ rhs = foRhs (mkLit (MachLabel cid stdcall_info))
+ stdcall_info = fun_type_arg_stdcall_info cconv ty
+ in
return ([(id, rhs)], empty, empty)
+
dsCImport id (CFunction target) cconv safety
= dsFCall id (CCall (CCallSpec target cconv safety))
dsCImport id CWrapper cconv _
= dsFExportDynamic id cconv
+
+-- For stdcall labels, if the type was a FunPtr or newtype thereof,
+-- then we need to calculate the size of the arguments in order to add
+-- the @n suffix to the label.
+fun_type_arg_stdcall_info :: CCallConv -> Type -> Maybe Int
+fun_type_arg_stdcall_info StdCallConv ty
+ | Just (tc,[arg_ty]) <- splitTyConApp_maybe (repType ty),
+ tyConUnique tc == funPtrTyConKey
+ = let
+ (_tvs,sans_foralls) = tcSplitForAllTys arg_ty
+ (fe_arg_tys, orig_res_ty) = tcSplitFunTys sans_foralls
+ in
+ Just $ sum (map (machRepByteWidth . typeMachRep . getPrimTyOf) fe_arg_tys)
+fun_type_arg_stdcall_info _other_conv _
+ = Nothing
\end{code}
worker_ty = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
the_ccall_app = mkFCall ccall_uniq fcall val_args ccall_result_ty
work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app)
- work_id = mkSysLocal FSLIT("$wccall") work_uniq worker_ty
+ work_id = mkSysLocal (fsLit "$wccall") work_uniq worker_ty
-- Build the wrapper
work_app = mkApps (mkVarApps (Var work_id) tvs) val_args
]
-- name of external entry point providing these services.
-- (probably in the RTS.)
- adjustor = FSLIT("createAdjustor")
+ adjustor = fsLit "createAdjustor"
-- Determine the number of bytes of arguments to the stub function,
-- so that we can attach the '@N' suffix to its label if it is a
arg_cname n stg_ty
| libffi = char '*' <> parens (stg_ty <> char '*') <>
- ptext SLIT("args") <> brackets (int (n-1))
+ ptext (sLit "args") <> brackets (int (n-1))
| otherwise = text ('a':show n)
-- generate a libffi-style stub if this is a "wrapper" and libffi is enabled
CCallConv -> empty
StdCallConv -> text (ccallConvAttribute cc)
- header_bits = ptext SLIT("extern") <+> fun_proto <> semi
+ header_bits = ptext (sLit "extern") <+> fun_proto <> semi
fun_args
| null aug_arg_info = text "void"
fun_proto
| libffi
- = ptext SLIT("void") <+> ftext c_nm <>
- parens (ptext SLIT("void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr"))
+ = ptext (sLit "void") <+> ftext c_nm <>
+ parens (ptext (sLit "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr"))
| otherwise
= cResType <+> pprCconv <+> ftext c_nm <> parens fun_args
fun_proto $$
vcat
[ lbrace
- , ptext SLIT("Capability *cap;")
+ , ptext (sLit "Capability *cap;")
, declareResult
, declareCResult
, text "cap = rts_lock();"
-- create the application + perform it.
- , ptext SLIT("cap=rts_evalIO") <> parens (
+ , ptext (sLit "cap=rts_evalIO") <> parens (
cap <>
- ptext SLIT("rts_apply") <> parens (
+ ptext (sLit "rts_apply") <> parens (
cap <>
text "(HaskellObj)"
<> ptext (if is_IO_res_ty
- then SLIT("runIO_closure")
- else SLIT("runNonIO_closure"))
+ then (sLit "runIO_closure")
+ else (sLit "runNonIO_closure"))
<> comma
<> expr_to_run
) <+> comma
<> text "&ret"
) <> semi
- , ptext SLIT("rts_checkSchedStatus") <> parens (doubleQuotes (ftext c_nm)
+ , ptext (sLit "rts_checkSchedStatus") <> parens (doubleQuotes (ftext c_nm)
<> comma <> text "cap") <> semi
, assignCResult
- , ptext SLIT("rts_unlock(cap);")
+ , ptext (sLit "rts_unlock(cap);")
, if res_hty_is_unit then empty
else if libffi
then char '*' <> parens (cResType <> char '*') <>
- ptext SLIT("resp = cret;")
- else ptext SLIT("return cret;")
+ ptext (sLit "resp = cret;")
+ else ptext (sLit "return cret;")
, rbrace
]