mkForeignLabel,
addLabelSize,
+ foreignLabelStdcallInfo,
mkCCLabel, mkCCSLabel,
addLabelSize label _
= label
+foreignLabelStdcallInfo :: CLabel -> Maybe Int
+foreignLabelStdcallInfo (ForeignLabel _ info _) = info
+foreignLabelStdcallInfo _lbl = Nothing
+
-- Cost centres etc.
mkCCLabel cc = CC_Label cc
pprExternDecl in_srt lbl
-- do not print anything for "known external" things
| not (needsCDecl lbl) = empty
- | otherwise =
+ | Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz
+ | otherwise =
hcat [ visibility, label_type (labelType lbl),
lparen, pprCLabel lbl, text ");" ]
where
| externallyVisibleCLabel lbl = char 'E'
| otherwise = char 'I'
+ -- If the label we want to refer to is a stdcall function (on Windows) then
+ -- we must generate an appropriate prototype for it, so that the C compiler will
+ -- add the @n suffix to the label (#2276)
+ stdcall_decl sz =
+ ptext (sLit "extern __attribute__((stdcall)) void ") <> pprCLabel lbl
+ <> parens (commafy (replicate (sz `quot` wORD_SIZE) (machRepCType wordRep)))
+ <> semi
type TEState = (UniqSet LocalReg, FiniteMap CLabel ())
newtype TE a = TE { unTE :: TEState -> (a, TEState) }
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}