Desugaring foreign declarations (see also DsCCall).
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module DsForeign ( dsForeigns ) where
#include "HsVersions.h"
import Module
import Name
import Type
+import TyCon
import Coercion
import TcType
+import Var
import HscTypes
import ForeignCall
dsForeigns fos = do
fives <- mapM do_ldecl fos
let
- (hs, cs, hdrs, idss, bindss) = unzip5 fives
+ (hs, cs, idss, bindss) = unzip4 fives
fe_ids = concat idss
fe_init_code = map foreignExportInitialiser fe_ids
--
return (ForeignStubs
(vcat hs)
- (vcat cs $$ vcat fe_init_code)
- (nub (concat hdrs)),
+ (vcat cs $$ vcat fe_init_code),
(concat bindss))
where
do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl)
do_decl (ForeignImport id _ spec) = do
traceIf (text "fi start" <+> ppr id)
- (bs, h, c, mbhd) <- dsFImport (unLoc id) spec
+ (bs, h, c) <- dsFImport (unLoc id) spec
traceIf (text "fi end" <+> ppr id)
- return (h, c, maybeToList mbhd, [], bs)
+ return (h, c, [], bs)
do_decl (ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv))) = do
(h, c, _, _) <- dsFExport id (idType id) ext_nm cconv False
- return (h, c, [], [id], [])
+ return (h, c, [id], [])
+
+ do_decl d = pprPanic "dsForeigns/do_decl" (ppr d)
\end{code}
\begin{code}
dsFImport :: Id
-> ForeignImport
- -> DsM ([Binding], SDoc, SDoc, Maybe FastString)
-dsFImport id (CImport cconv safety header lib spec) = do
- (ids, h, c) <- dsCImport id spec cconv safety no_hdrs
- return (ids, h, c, if no_hdrs then Nothing else Just header)
- where
- no_hdrs = nullFS header
+ -> DsM ([Binding], SDoc, SDoc)
+dsFImport id (CImport cconv safety _ _ spec) = do
+ (ids, h, c) <- dsCImport id spec cconv safety
+ return (ids, h, c)
-- FIXME: the `lib' field is needed for .NET ILX generation when invoking
-- routines that are external to the .NET runtime, but GHC doesn't
-- support such calls yet; if `nullFastString lib', the value was not given
dsFImport id (DNImport spec) = do
- (ids, h, c) <- dsFCall id (DNCall spec) True {- No headers -}
- return (ids, h, c, Nothing)
+ (ids, h, c) <- dsFCall id (DNCall spec)
+ return (ids, h, c)
dsCImport :: Id
-> CImportSpec
-> CCallConv
-> Safety
- -> Bool -- True <=> no headers in the f.i decl
-> DsM ([Binding], SDoc, SDoc)
-dsCImport id (CLabel cid) _ _ no_hdrs = 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
- return ([(setImpInline no_hdrs id, rhs)], empty, empty)
-dsCImport id (CFunction target) cconv safety no_hdrs
- = dsFCall id (CCall (CCallSpec target cconv safety)) no_hdrs
-dsCImport id CWrapper cconv _ _
+ let
+ rhs = foRhs (Lit (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
-setImpInline :: Bool -- True <=> No #include headers
- -- in the foreign import declaration
- -> Id -> Id
--- If there is a #include header in the foreign import
--- we make the worker non-inlinable, because we currently
--- don't keep the #include stuff in the CCallId, and hence
--- it won't be visible in the importing module, which can be
--- fatal.
--- (The #include stuff is just collected from the foreign import
--- decls in a module.)
--- If you want to do cross-module inlining of the c-calls themselves,
--- put the #include stuff in the package spec, not the foreign
--- import decl.
-setImpInline True id = id
-setImpInline False id = id `setInlinePragma` NeverActive
+-- 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}
%************************************************************************
\begin{code}
-dsFCall fn_id fcall no_hdrs = do
+dsFCall :: Id -> ForeignCall -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
+dsFCall fn_id fcall = do
let
ty = idType fn_id
(tvs, fun_ty) = tcSplitForAllTys ty
augmentResultDs
| forDotnet = do
- err_res <- newSysLocalDs addrPrimTy
return (\ (mb_res_ty, resWrap) ->
case mb_res_ty of
Nothing -> (Just (mkTyConApp (tupleTyCon Unboxed 1)
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 = setImpInline no_hdrs $ -- See comments with setImpInline
- 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
For each `@foreign export foo@' in a module M we generate:
\begin{itemize}
\item a C function `@foo@', which calls
-\item a Haskell stub `@M.$ffoo@', which calls
+\item a Haskell stub `@M.\$ffoo@', which calls
\end{itemize}
the user-written Haskell function `@M.foo@'.
(res_ty, -- t
is_IO_res_ty) <- -- Bool
case tcSplitIOType_maybe orig_res_ty of
- Just (ioTyCon, res_ty, co) -> return (res_ty, True)
+ Just (_ioTyCon, res_ty, _co) -> return (res_ty, True)
-- The function already returns IO t
-- ToDo: what about the coercion?
Nothing -> return (orig_res_ty, False)
-}
adj_args = [ mkIntLitInt (ccallConvToInt cconv)
, Var stbl_value
- , mkLit (MachLabel fe_nm mb_sz_args)
- , mkLit (mkStringLit typestring)
+ , Lit (MachLabel fe_nm mb_sz_args)
+ , Lit (mkMachString typestring)
]
-- 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
pprCconv = case cc of
CCallConv -> empty
StdCallConv -> text (ccallConvAttribute cc)
+ CmmCallConv -> panic "mkFExportCBits/pprCconv CmmCallConv"
+
+ header_bits = ptext (sLit "extern") <+> fun_proto <> semi
- header_bits = ptext SLIT("extern") <+> fun_proto <> semi
+ fun_args
+ | null aug_arg_info = text "void"
+ | otherwise = hsep $ punctuate comma
+ $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info
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 (hsep (punctuate comma (map (\(nm,ty,_,_) -> ty <+> nm)
- aug_arg_info)))
+ = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args
-- the target which will form the root of what we ask rts_evalIO to run
the_cfun
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
]
-- this information to hand, but we know what GHC's conventions
-- are for passing around the primitive Haskell types, so we
-- use that instead. I hope the two coincide --SDM
+typeMachRep :: Type -> MachRep
typeMachRep ty = argMachRep (typeCgRep ty)
mkHObj :: Type -> SDoc
Just (tc,_) -> tc
Nothing -> pprPanic "showFFIType" (ppr t)
+insertRetAddr :: CCallConv -> [(SDoc, SDoc, Type, MachRep)]
+ -> [(SDoc, SDoc, Type, MachRep)]
#if !defined(x86_64_TARGET_ARCH)
insertRetAddr CCallConv args = ret_addr_arg : args
insertRetAddr _ args = args
-- need to flush a register argument to the stack (See rts/Adjustor.c for
-- details).
insertRetAddr CCallConv args = go 0 args
- where go 6 args = ret_addr_arg : args
+ where go :: Int -> [(SDoc, SDoc, Type, MachRep)]
+ -> [(SDoc, SDoc, Type, MachRep)]
+ go 6 args = ret_addr_arg : args
go n (arg@(_,_,_,rep):args)
| I64 <- rep = arg : go (n+1) args
| otherwise = arg : go n args
- go n [] = []
+ go _ [] = []
insertRetAddr _ args = args
#endif
+ret_addr_arg :: (SDoc, SDoc, Type, MachRep)
ret_addr_arg = (text "original_return_addr", text "void*", undefined,
typeMachRep addrPrimTy)