Commit cbdeae8f authored by simonpj's avatar simonpj

[project @ 2001-05-24 13:59:09 by simonpj]

------------------------------------------------------
	More stuff towards generalising 'foreign' declarations
	------------------------------------------------------

This is the second step towards generalising 'foreign' declarations to
handle langauges other than C.  Now I can handle

  foreign import dotnet type T
  foreign import dotnet "void Foo.Baz.f( T )" f :: T -> IO ()



			** WARNING **
	I believe that all the foreign stuff for C should
	work exactly as before, but I have not tested it
	thoroughly.  Sven, Manuel, Marcin: please give it a
	whirl and compare old with new output.


Lots of fiddling around with data types.  The main changes are

* HsDecls.lhs
	The ForeignDecl type and its friends
	Note also the ForeignType constructor to TyClDecl

* ForeignCall.lhs
	Here's where the stuff that survives right through
	compilation lives

* TcForeign.lhs DsForeign.lhs
	Substantial changes driven by the new data types

* Parser.y ParseIface.y RnSource
	Just what you'd expect
parent f70aaa98
...@@ -28,7 +28,7 @@ import Unique ( Unique{-instance Eq-} ) ...@@ -28,7 +28,7 @@ import Unique ( Unique{-instance Eq-} )
import UniqSupply ( uniqFromSupply, uniqsFromSupply, splitUniqSupply, import UniqSupply ( uniqFromSupply, uniqsFromSupply, splitUniqSupply,
UniqSupply ) UniqSupply )
import CmdLineOpts ( opt_EmitCExternDecls ) import CmdLineOpts ( opt_EmitCExternDecls )
import ForeignCall ( ForeignCall(..), CCallSpec(..), isDynamicTarget ) import ForeignCall ( ForeignCall(..), CCallSpec(..), isDynamicTarget, isCasmTarget )
import StgSyn ( StgOp(..) ) import StgSyn ( StgOp(..) )
import Panic ( panic ) import Panic ( panic )
import FastTypes import FastTypes
...@@ -341,9 +341,9 @@ flatAbsC (CSwitch discrim alts deflt) ...@@ -341,9 +341,9 @@ flatAbsC (CSwitch discrim alts deflt)
= flatAbsC absC `thenFlt` \ (alt_heres, alt_tops) -> = flatAbsC absC `thenFlt` \ (alt_heres, alt_tops) ->
returnFlt ( (tag, alt_heres), alt_tops ) returnFlt ( (tag, alt_heres), alt_tops )
flatAbsC stmt@(COpStmt results (StgFCallOp (CCall ccall@(CCallSpec target _ _ is_asm)) uniq) args _) flatAbsC stmt@(COpStmt results (StgFCallOp (CCall ccall@(CCallSpec target _ _)) uniq) args _)
| is_dynamic -- Emit a typedef if its a dynamic call | is_dynamic -- Emit a typedef if its a dynamic call
|| (opt_EmitCExternDecls && not is_asm) -- or we want extern decls || (opt_EmitCExternDecls && not (isCasmTarget target)) -- or we want extern decls
= returnFlt (stmt, CCallTypedef is_dynamic ccall uniq results args) = returnFlt (stmt, CCallTypedef is_dynamic ccall uniq results args)
where where
is_dynamic = isDynamicTarget target is_dynamic = isDynamicTarget target
......
...@@ -46,7 +46,7 @@ import Name ( NamedThing(..) ) ...@@ -46,7 +46,7 @@ import Name ( NamedThing(..) )
import DataCon ( dataConWrapId ) import DataCon ( dataConWrapId )
import Maybes ( maybeToBool, catMaybes ) import Maybes ( maybeToBool, catMaybes )
import PrimOp ( primOpNeedsWrapper ) import PrimOp ( primOpNeedsWrapper )
import ForeignCall ( ForeignCall(..), isDynamicTarget ) import ForeignCall ( ForeignCall(..) )
import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize ) import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize )
import SMRep ( pprSMRep ) import SMRep ( pprSMRep )
import Unique ( pprUnique, Unique{-instance NamedThing-} ) import Unique ( pprUnique, Unique{-instance NamedThing-} )
...@@ -284,7 +284,7 @@ pprAbsC (CCallProfCtrMacro op as) _ ...@@ -284,7 +284,7 @@ pprAbsC (CCallProfCtrMacro op as) _
pprAbsC (CCallProfCCMacro op as) _ pprAbsC (CCallProfCCMacro op as) _
= hcat [ptext op, lparen, = hcat [ptext op, lparen,
hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
pprAbsC stmt@(CCallTypedef is_tdef (CCallSpec op_str cconv _ _) uniq results args) _ pprAbsC stmt@(CCallTypedef is_tdef (CCallSpec op_str cconv _) uniq results args) _
= hsep [ ptext (if is_tdef then SLIT("typedef") else SLIT("extern")) = hsep [ ptext (if is_tdef then SLIT("typedef") else SLIT("extern"))
, ccall_res_ty , ccall_res_ty
, fun_nm , fun_nm
...@@ -775,13 +775,13 @@ Amendment to the above: if we can GC, we have to: ...@@ -775,13 +775,13 @@ Amendment to the above: if we can GC, we have to:
that the runtime check that PerformGC is being used sensibly will work. that the runtime check that PerformGC is being used sensibly will work.
\begin{code} \begin{code}
pprFCall call@(CCall (CCallSpec op_str cconv safety is_asm)) uniq args results vol_regs pprFCall call@(CCall (CCallSpec target cconv safety)) uniq args results vol_regs
= vcat [ = vcat [
char '{', char '{',
declare_local_vars, -- local var for *result* declare_local_vars, -- local var for *result*
vcat local_arg_decls, vcat local_arg_decls,
pp_save_context, pp_save_context,
process_casm local_vars pp_non_void_args casm_str, process_casm local_vars pp_non_void_args call_str,
pp_restore_context, pp_restore_context,
assign_results, assign_results,
char '}' char '}'
...@@ -814,16 +814,17 @@ pprFCall call@(CCall (CCallSpec op_str cconv safety is_asm)) uniq args results v ...@@ -814,16 +814,17 @@ pprFCall call@(CCall (CCallSpec op_str cconv safety is_asm)) uniq args results v
(declare_local_vars, local_vars, assign_results) (declare_local_vars, local_vars, assign_results)
= ppr_casm_results non_void_results = ppr_casm_results non_void_results
casm_str = if is_asm then _UNPK_ asm_str else ccall_str call_str = case target of
StaticTarget asm_str = op_str -- Must be static if it's a casm CasmTarget str -> _UNPK_ str
StaticTarget fn -> mk_ccall_str (pprCLabelString fn) ccall_args
DynamicTarget -> mk_ccall_str dyn_fun (tail ccall_args)
-- Remainder only used for ccall ccall_args = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..]
dyn_fun = parens (parens (ptext SLIT("_ccall_fun_ty") <> ppr uniq) <> text "%0")
fun_name = case op_str of
DynamicTarget -> parens (parens (ptext SLIT("_ccall_fun_ty") <> ppr uniq) <> text "%0")
StaticTarget st -> pprCLabelString st
ccall_str = showSDoc -- Remainder only used for ccall
mk_ccall_str fun_name ccall_fun_args = showSDoc
(hcat [ (hcat [
if null non_void_results if null non_void_results
then empty then empty
...@@ -832,11 +833,6 @@ pprFCall call@(CCall (CCallSpec op_str cconv safety is_asm)) uniq args results v ...@@ -832,11 +833,6 @@ pprFCall call@(CCall (CCallSpec op_str cconv safety is_asm)) uniq args results v
hcat (punctuate comma ccall_fun_args), hcat (punctuate comma ccall_fun_args),
text "));" text "));"
]) ])
ccall_fun_args | isDynamicTarget op_str = tail ccall_args
| otherwise = ccall_args
ccall_args = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..]
\end{code} \end{code}
If the argument is a heap object, we need to reach inside and pull out If the argument is a heap object, we need to reach inside and pull out
......
...@@ -49,7 +49,7 @@ import Id ( Id, idType, isId, ...@@ -49,7 +49,7 @@ import Id ( Id, idType, isId,
import VarSet import VarSet
import Literal ( isLitLitLit, litSize ) import Literal ( isLitLitLit, litSize )
import PrimOp ( primOpIsDupable, primOpOutOfLine ) import PrimOp ( primOpIsDupable, primOpOutOfLine )
import ForeignCall ( ForeignCall(..), ccallIsCasm ) import ForeignCall ( okToExposeFCall )
import IdInfo ( InlinePragInfo(..), OccInfo(..), GlobalIdDetails(..), import IdInfo ( InlinePragInfo(..), OccInfo(..), GlobalIdDetails(..),
isNeverInlinePrag isNeverInlinePrag
) )
...@@ -490,10 +490,6 @@ okToUnfoldInHiFile e = opt_UnfoldCasms || go e ...@@ -490,10 +490,6 @@ okToUnfoldInHiFile e = opt_UnfoldCasms || go e
not (any isLitLitLit [ lit | (LitAlt lit, _, _) <- alts ]) not (any isLitLitLit [ lit | (LitAlt lit, _, _) <- alts ])
go (Note _ body) = go body go (Note _ body) = go body
go (Type _) = True go (Type _) = True
-- ok to unfold a PrimOp as long as it's not a _casm_
okToExposeFCall (CCall cc) = not (ccallIsCasm cc)
okToExposeFCall other = True
\end{code} \end{code}
......
...@@ -26,7 +26,7 @@ import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety, CC ...@@ -26,7 +26,7 @@ import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety, CC
import DataCon ( splitProductType_maybe, dataConSourceArity, dataConWrapId ) import DataCon ( splitProductType_maybe, dataConSourceArity, dataConWrapId )
import ForeignCall ( ForeignCall, CCallTarget(..) ) import ForeignCall ( ForeignCall, CCallTarget(..) )
import Type ( isUnLiftedType, splitAlgTyConApp_maybe, mkFunTys, import Type ( isUnLiftedType, splitAlgTyConApp_maybe, mkFunTys,
splitTyConApp_maybe, tyVarsOfType, mkForAllTys, splitTyConApp_maybe, tyVarsOfType, mkForAllTys, isPrimitiveType,
isNewType, repType, isUnLiftedType, mkFunTy, mkTyConApp, isNewType, repType, isUnLiftedType, mkFunTy, mkTyConApp,
Type Type
) )
...@@ -96,7 +96,9 @@ dsCCall lbl args may_gc is_asm result_ty ...@@ -96,7 +96,9 @@ dsCCall lbl args may_gc is_asm result_ty
boxResult [] result_ty `thenDs` \ (ccall_result_ty, res_wrapper) -> boxResult [] result_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
getUniqueDs `thenDs` \ uniq -> getUniqueDs `thenDs` \ uniq ->
let let
the_fcall = CCall (CCallSpec (StaticTarget lbl) CCallConv may_gc is_asm) target | is_asm = CasmTarget lbl
| otherwise = StaticTarget lbl
the_fcall = CCall (CCallSpec target CCallConv may_gc)
the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
in in
returnDs (foldr ($) (res_wrapper the_prim_app) arg_wrappers) returnDs (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
...@@ -134,8 +136,8 @@ unboxArg :: CoreExpr -- The supplied argument ...@@ -134,8 +136,8 @@ unboxArg :: CoreExpr -- The supplied argument
-- where W is a CoreExpr that probably mentions x# -- where W is a CoreExpr that probably mentions x#
unboxArg arg unboxArg arg
-- Unlifted types: nothing to unbox -- Primtive types: nothing to unbox
| isUnLiftedType arg_ty | isPrimitiveType arg_ty
= returnDs (arg, \body -> body) = returnDs (arg, \body -> body)
-- Newtypes -- Newtypes
...@@ -293,7 +295,7 @@ resultWrapper :: Type ...@@ -293,7 +295,7 @@ resultWrapper :: Type
CoreExpr -> CoreExpr) -- Wrapper for the result CoreExpr -> CoreExpr) -- Wrapper for the result
resultWrapper result_ty resultWrapper result_ty
-- Base case 1: primitive types -- Base case 1: primitive types
| isUnLiftedType result_ty | isPrimitiveType result_ty
= (Just result_ty, \e -> e) = (Just result_ty, \e -> e)
-- Base case 1: the unit type () -- Base case 1: the unit type ()
......
...@@ -15,8 +15,7 @@ import CoreSyn ...@@ -15,8 +15,7 @@ import CoreSyn
import DsCCall ( dsCCall, mkFCall, boxResult, unboxArg, resultWrapper ) import DsCCall ( dsCCall, mkFCall, boxResult, unboxArg, resultWrapper )
import DsMonad import DsMonad
import HsSyn ( ExtName(..), ForeignDecl(..), isDynamicExtName, ForKind(..) ) import HsSyn ( ForeignDecl(..), FoExport(..), FoImport(..) )
import HsDecls ( extNameStatic )
import TcHsSyn ( TypecheckedForeignDecl ) import TcHsSyn ( TypecheckedForeignDecl )
import CoreUtils ( exprType, mkInlineMe ) import CoreUtils ( exprType, mkInlineMe )
import Id ( Id, idType, idName, mkVanillaGlobal, mkSysLocal, import Id ( Id, idType, idName, mkVanillaGlobal, mkSysLocal,
...@@ -35,9 +34,10 @@ import Type ( repType, splitTyConApp_maybe, ...@@ -35,9 +34,10 @@ import Type ( repType, splitTyConApp_maybe,
) )
import ForeignCall ( ForeignCall(..), CCallSpec(..), import ForeignCall ( ForeignCall(..), CCallSpec(..),
Safety(..), playSafe, Safety(..), playSafe,
CCallTarget(..), dynamicTarget, CExportSpec(..),
CCallConv(..), ccallConvToInt CCallConv(..), ccallConvToInt
) )
import CStrings ( CLabelString )
import TysWiredIn ( unitTy, addrTy, stablePtrTyCon ) import TysWiredIn ( unitTy, addrTy, stablePtrTyCon )
import TysPrim ( addrPrimTy ) import TysPrim ( addrPrimTy )
import PrelNames ( hasKey, ioTyConKey, deRefStablePtrName, newStablePtrName, import PrelNames ( hasKey, ioTyConKey, deRefStablePtrName, newStablePtrName,
...@@ -75,36 +75,25 @@ dsForeigns :: Module ...@@ -75,36 +75,25 @@ dsForeigns :: Module
, SDoc -- C stubs to use when calling , SDoc -- C stubs to use when calling
-- "foreign exported" functions. -- "foreign exported" functions.
) )
dsForeigns mod_name fos = foldlDs combine ([], [], empty, empty) fos dsForeigns mod_name fos
= foldlDs combine ([], [], empty, empty) fos
where where
combine (acc_feb, acc_f, acc_h, acc_c) fo@(ForeignDecl i imp_exp _ ext_nm cconv _) combine (acc_feb, acc_f, acc_h, acc_c) (ForeignImport id _ spec _)
| isForeignImport = -- foreign import (dynamic)? = dsFImport mod_name id spec `thenDs` \ (bs, h, c) ->
dsFImport i (idType i) uns ext_nm cconv `thenDs` \ bs -> returnDs (acc_feb, bs ++ acc_f, h $$ acc_h, c $$ acc_c)
returnDs (acc_feb, bs ++ acc_f, acc_h, acc_c)
| isForeignLabel = combine (acc_feb, acc_f, acc_h, acc_c) (ForeignExport id _ (CExport (CExportStatic ext_nm cconv)) _)
dsFLabel i (idType i) ext_nm `thenDs` \ b -> = dsFExport mod_name id (idType id) ext_nm cconv False `thenDs` \ (feb, b, h, c) ->
returnDs (acc_feb, b:acc_f, acc_h, acc_c) returnDs (feb:acc_feb, b : acc_f, h $$ acc_h, c $$ acc_c)
| isDynamicExtName ext_nm =
dsFExportDynamic i (idType i) mod_name ext_nm cconv `thenDs` \ (feb,bs,h,c) ->
returnDs (feb:acc_feb, bs ++ acc_f, h $$ acc_h, c $$ acc_c)
| otherwise = -- foreign export
dsFExport i (idType i) mod_name ext_nm cconv False `thenDs` \ (feb,fe,h,c) ->
returnDs (feb:acc_feb, fe:acc_f, h $$ acc_h, c $$ acc_c)
where
isForeignImport =
case imp_exp of
FoImport _ -> True
_ -> False
isForeignLabel =
case imp_exp of
FoLabel -> True
_ -> False
FoImport uns = imp_exp
\end{code} \end{code}
%************************************************************************
%* *
\subsection{Foreign import}
%* *
%************************************************************************
Desugaring foreign imports is just the matter of creating a binding Desugaring foreign imports is just the matter of creating a binding
that on its RHS unboxes its arguments, performs the external call that on its RHS unboxes its arguments, performs the external call
(using the @CCallOp@ primop), before boxing the result up and returning it. (using the @CCallOp@ primop), before boxing the result up and returning it.
...@@ -125,14 +114,33 @@ because it exposes the boxing to the call site. ...@@ -125,14 +114,33 @@ because it exposes the boxing to the call site.
\begin{code} \begin{code}
dsFImport :: Id dsFImport :: Module
-> Type -- Type of foreign import. -> Id
-> Safety -- Whether can re-enter the Haskell RTS, do GC etc -> FoImport
-> ExtName -> DsM ([Binding], SDoc, SDoc)
-> CCallConv dsFImport mod_name lbl_id (LblImport ext_nm)
-> DsM [Binding] = ASSERT(fromJust res_ty == addrPrimTy) -- typechecker ensures this
dsFImport fn_id ty safety ext_name cconv returnDs ([(lbl_id, rhs)], empty, empty)
where
(res_ty, fo_rhs) = resultWrapper (idType lbl_id)
rhs = fo_rhs (mkLit (MachLabel ext_nm))
dsFImport mod_name fn_id (CImport spec) = dsFCall mod_name fn_id (CCall spec)
dsFImport mod_name fn_id (DNImport spec) = dsFCall mod_name fn_id (DNCall spec)
dsFImport mod_name fn_id (CDynImport cconv) = dsFExportDynamic mod_name fn_id cconv
\end{code}
%************************************************************************
%* *
\subsection{Foreign calls}
%* *
%************************************************************************
\begin{code}
dsFCall mod_Name fn_id fcall
= let = let
ty = idType fn_id
(tvs, fun_ty) = splitForAllTys ty (tvs, fun_ty) = splitForAllTys ty
(arg_tys, io_res_ty) = splitFunTys fun_ty (arg_tys, io_res_ty) = splitFunTys fun_ty
in in
...@@ -145,22 +153,17 @@ dsFImport fn_id ty safety ext_name cconv ...@@ -145,22 +153,17 @@ dsFImport fn_id ty safety ext_name cconv
-- These are the ids we pass to boxResult, which are used to decide -- These are the ids we pass to boxResult, which are used to decide
-- whether to touch# an argument after the call (used to keep -- whether to touch# an argument after the call (used to keep
-- ForeignObj#s live across a 'safe' foreign import). -- ForeignObj#s live across a 'safe' foreign import).
maybe_arg_ids | playSafe safety = work_arg_ids maybe_arg_ids | unsafe_call fcall = work_arg_ids
| otherwise = [] | otherwise = []
in in
boxResult maybe_arg_ids io_res_ty `thenDs` \ (ccall_result_ty, res_wrapper) -> boxResult maybe_arg_ids io_res_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
getUniqueDs `thenDs` \ ccall_uniq -> getUniqueDs `thenDs` \ ccall_uniq ->
getUniqueDs `thenDs` \ work_uniq -> getUniqueDs `thenDs` \ work_uniq ->
let let
lbl = case ext_name of
Dynamic -> dynamicTarget
ExtName fs _ -> StaticTarget fs
-- Build the worker -- Build the worker
worker_ty = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty) worker_ty = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
the_ccall = CCall (CCallSpec lbl cconv safety False) the_ccall_app = mkFCall ccall_uniq fcall val_args ccall_result_ty
the_ccall_app = mkFCall ccall_uniq the_ccall val_args ccall_result_ty
work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app) work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app)
work_id = mkSysLocal SLIT("$wccall") work_uniq worker_ty work_id = mkSysLocal SLIT("$wccall") work_uniq worker_ty
...@@ -169,20 +172,18 @@ dsFImport fn_id ty safety ext_name cconv ...@@ -169,20 +172,18 @@ dsFImport fn_id ty safety ext_name cconv
wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
wrap_rhs = mkInlineMe (mkLams (tvs ++ args) wrapper_body) wrap_rhs = mkInlineMe (mkLams (tvs ++ args) wrapper_body)
in in
returnDs [(work_id, work_rhs), (fn_id, wrap_rhs)] returnDs ([(work_id, work_rhs), (fn_id, wrap_rhs)], empty, empty)
unsafe_call (CCall (CCallSpec _ _ safety)) = playSafe safety
unsafe_call (DNCall _) = False
\end{code} \end{code}
Foreign labels
\begin{code} %************************************************************************
dsFLabel :: Id -> Type -> ExtName -> DsM Binding %* *
dsFLabel nm ty ext_name = \subsection{Foreign export}
ASSERT(fromJust res_ty == addrPrimTy) -- typechecker ensures this %* *
returnDs (nm, fo_rhs (mkLit (MachLabel enm))) %************************************************************************
where
(res_ty, fo_rhs) = resultWrapper ty
enm = extNameStatic ext_name
\end{code}
The function that does most of the work for `@foreign export@' declarations. The function that does most of the work for `@foreign export@' declarations.
(see below for the boilerplate code a `@foreign export@' declaration expands (see below for the boilerplate code a `@foreign export@' declaration expands
...@@ -196,19 +197,21 @@ For each `@foreign export foo@' in a module M we generate: ...@@ -196,19 +197,21 @@ For each `@foreign export foo@' in a module M we generate:
the user-written Haskell function `@M.foo@'. the user-written Haskell function `@M.foo@'.
\begin{code} \begin{code}
dsFExport :: Id dsFExport :: Module
-> Type -- Type of foreign export. -> Id -- Either the exported Id,
-> Module -- or the foreign-export-dynamic constructor
-> ExtName -> Type -- The type of the thing callable from C
-> CLabelString -- The name to export to C land
-> CCallConv -> CCallConv
-> Bool -- True => invoke IO action that's hanging off -> Bool -- True => foreign export dynamic
-- the first argument's stable pointer -- so invoke IO action that's hanging off
-- the first argument's stable pointer
-> DsM ( Id -- The foreign-exported Id -> DsM ( Id -- The foreign-exported Id
, Binding , Binding
, SDoc , SDoc
, SDoc , SDoc
) )
dsFExport fn_id ty mod_name ext_name cconv isDyn dsFExport mod_name fn_id ty ext_name cconv isDyn
= -- BUILD THE returnIO WRAPPER, if necessary = -- BUILD THE returnIO WRAPPER, if necessary
-- Look at the result type of the exported function, orig_res_ty -- Look at the result type of the exported function, orig_res_ty
-- If it's IO t, return (\x.x, IO t, t) -- If it's IO t, return (\x.x, IO t, t)
...@@ -282,20 +285,19 @@ dsFExport fn_id ty mod_name ext_name cconv isDyn ...@@ -282,20 +285,19 @@ dsFExport fn_id ty mod_name ext_name cconv isDyn
the_app = getFun_wrapper (return_io_wrapper (mkVarApps (Var i) (tvs ++ fe_args))) the_app = getFun_wrapper (return_io_wrapper (mkVarApps (Var i) (tvs ++ fe_args)))
the_body = mkLams (tvs ++ wrapper_args) the_app the_body = mkLams (tvs ++ wrapper_args) the_app
c_nm = extNameStatic ext_name
(h_stub, c_stub) = fexportEntry (moduleUserString mod) (h_stub, c_stub) = fexportEntry (moduleUserString mod)
c_nm f_helper_glob ext_name f_helper_glob
wrapper_arg_tys res_ty cconv isDyn wrapper_arg_tys res_ty cconv isDyn
in in
returnDs (f_helper_glob, (f_helper_glob, the_body), h_stub, c_stub) returnDs (f_helper_glob, (f_helper_glob, the_body), h_stub, c_stub)
where where
(tvs,sans_foralls) = splitForAllTys ty (tvs,sans_foralls) = splitForAllTys ty
(fe_arg_tys', orig_res_ty) = splitFunTys sans_foralls (fe_arg_tys', orig_res_ty) = splitFunTys sans_foralls
(_, stbl_ptr_ty') = splitForAllTys stbl_ptr_ty (_, stbl_ptr_ty') = splitForAllTys stbl_ptr_ty
(_, stbl_ptr_to_ty) = splitAppTy stbl_ptr_ty' (_, stbl_ptr_to_ty) = splitAppTy stbl_ptr_ty'
fe_arg_tys | isDyn = tail fe_arg_tys' fe_arg_tys | isDyn = tail fe_arg_tys'
| otherwise = fe_arg_tys' | otherwise = fe_arg_tys'
...@@ -327,23 +329,19 @@ foreign export "f_helper" f_helper :: StablePtr (Addr -> Int -> IO Int) -> Addr ...@@ -327,23 +329,19 @@ foreign export "f_helper" f_helper :: StablePtr (Addr -> Int -> IO Int) -> Addr
\end{verbatim} \end{verbatim}
\begin{code} \begin{code}
dsFExportDynamic :: Id dsFExportDynamic :: Module
-> Type -- Type of foreign export. -> Id
-> Module
-> ExtName
-> CCallConv -> CCallConv
-> DsM (Id, [Binding], SDoc, SDoc) -> DsM ([Binding], SDoc, SDoc)
dsFExportDynamic i ty mod_name ext_name cconv = dsFExportDynamic mod_name id cconv
newSysLocalDs ty `thenDs` \ fe_id -> = newSysLocalDs ty `thenDs` \ fe_id ->
let let
-- hack: need to get at the name of the C stub we're about to generate. -- hack: need to get at the name of the C stub we're about to generate.
fe_nm = moduleUserString mod_name ++ "_" ++ toCName fe_id fe_nm = _PK_ (moduleUserString mod_name ++ "_" ++ toCName fe_id)
fe_ext_name = ExtName (_PK_ fe_nm) Nothing
in in
dsFExport i export_ty mod_name fe_ext_name cconv True dsFExport mod_name id export_ty fe_nm cconv True `thenDs` \ (feb, fe, h_code, c_code) ->
`thenDs` \ (feb, fe, h_code, c_code) -> newSysLocalDs arg_ty `thenDs` \ cback ->
newSysLocalDs arg_ty `thenDs` \ cback -> dsLookupGlobalValue newStablePtrName `thenDs` \ newStablePtrId ->
dsLookupGlobalValue newStablePtrName `thenDs` \ newStablePtrId ->
let let
mk_stbl_ptr_app = mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ] mk_stbl_ptr_app = mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
in in
...@@ -367,7 +365,7 @@ dsFExportDynamic i ty mod_name ext_name cconv = ...@@ -367,7 +365,7 @@ dsFExportDynamic i ty mod_name ext_name cconv =
-} -}
adj_args = [ mkIntLitInt (ccallConvToInt cconv) adj_args = [ mkIntLitInt (ccallConvToInt cconv)
, Var stbl_value , Var stbl_value
, mkLit (MachLabel (_PK_ fe_nm)) , mkLit (MachLabel fe_nm)
] ]
-- name of external entry point providing these services. -- name of external entry point providing these services.
-- (probably in the RTS.) -- (probably in the RTS.)
...@@ -382,13 +380,14 @@ dsFExportDynamic i ty mod_name ext_name cconv = ...@@ -382,13 +380,14 @@ dsFExportDynamic i ty mod_name ext_name cconv =
io_app = mkLams tvs $ io_app = mkLams tvs $
mkLams [cback] $ mkLams [cback] $
stbl_app ccall_io_adj res_ty stbl_app ccall_io_adj res_ty
fed = (i `setInlinePragma` neverInlinePrag, io_app) fed = (id `setInlinePragma` neverInlinePrag, io_app)
-- Never inline the f.e.d. function, because the litlit -- Never inline the f.e.d. function, because the litlit
-- might not be in scope in other modules. -- might not be in scope in other modules.
in in
returnDs (feb, [fed, fe], h_code, c_code) returnDs ([fed, fe], h_code, c_code)
where where
ty = idType id
(tvs,sans_foralls) = splitForAllTys ty (tvs,sans_foralls) = splitForAllTys ty
([arg_ty], io_res_ty) = splitFunTys sans_foralls ([arg_ty], io_res_ty) = splitFunTys sans_foralls
Just (ioTyCon, [res_ty]) = splitTyConApp_maybe io_res_ty Just (ioTyCon, [res_ty]) = splitTyConApp_maybe io_res_ty
......
...@@ -9,12 +9,13 @@ Definitions for: @TyDecl@ and @oCnDecl@, @ClassDecl@, ...@@ -9,12 +9,13 @@ Definitions for: @TyDecl@ and @oCnDecl@, @ClassDecl@,
\begin{code} \begin{code}
module HsDecls ( module HsDecls (
HsDecl(..), TyClDecl(..), InstDecl(..), RuleDecl(..), RuleBndr(..), HsDecl(..), TyClDecl(..), InstDecl(..), RuleDecl(..), RuleBndr(..),
DefaultDecl(..), ForeignDecl(..), ForKind(..), DefaultDecl(..),
ExtName(..), isDynamicExtName, extNameStatic, ForeignDecl(..), FoImport(..), FoExport(..), FoType(..),
ConDecl(..), ConDetails(..), ConDecl(..), ConDetails(..),
BangType(..), getBangType, getBangStrictness, unbangedType, BangType(..), getBangType, getBangStrictness, unbangedType,
DeprecDecl(..), DeprecTxt, DeprecDecl(..), DeprecTxt,
hsDeclName, instDeclName, tyClDeclName, tyClDeclNames, tyClDeclSysNames, hsDeclName, instDeclName,
tyClDeclName, tyClDeclNames, tyClDeclSysNames, tyClDeclTyVars,
isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, countTyClDecls, isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, countTyClDecls,
mkClassDeclSysNames, isIfaceRuleDecl, ifaceRuleDeclName, mkClassDeclSysNames, isIfaceRuleDecl, ifaceRuleDeclName,
getClassDeclSysNames, conDetailsTys getClassDeclSysNames, conDetailsTys
...@@ -33,14 +34,13 @@ import HsCore ( UfExpr, UfBinder, HsIdInfo, pprHsIdInfo, ...@@ -33,14 +34,13 @@ import HsCore ( UfExpr, UfBinder, HsIdInfo, pprHsIdInfo,
import CoreSyn ( CoreRule(..) ) import CoreSyn ( CoreRule(..) )
import BasicTypes ( NewOrData(..) ) import BasicTypes ( NewOrData(..) )
import Demand ( StrictnessMark(..) ) import Demand ( StrictnessMark(..) )
import ForeignCall ( CCallConv ) import ForeignCall ( CExportSpec, CCallSpec, DNCallSpec, CCallConv )
-- others: -- others:
import ForeignCall ( Safety )
import Name ( NamedThing ) import Name ( NamedThing )
import FunDeps ( pprFundeps ) import FunDeps ( pprFundeps )
import Class ( FunDep, DefMeth(..) ) import Class ( FunDep, DefMeth(..) )
import CStrings ( CLabelString, pprCLabelString ) import CStrings ( CLabelString )
import Outputable import Outputable
import SrcLoc ( SrcLoc ) import SrcLoc ( SrcLoc )
\end{code} \end{code}
...@@ -82,10 +82,10 @@ data HsDecl name pat ...@@ -82,10 +82,10 @@ data HsDecl name pat
hsDeclName :: (NamedThing name, Outputable name, Outputable pat) hsDeclName :: (NamedThing name, Outputable name, Outputable pat)
=> HsDecl name pat -> name => HsDecl name pat -> name
#endif #endif
hsDeclName (TyClD decl) = tyClDeclName decl hsDeclName (TyClD decl) = tyClDeclName decl
hsDeclName (InstD decl) = instDeclName decl hsDeclName (InstD decl) = instDeclName decl
hsDeclName (ForD (ForeignDecl name _ _ _ _ _)) = name hsDeclName (ForD decl) = forDeclName decl
hsDeclName (FixD (FixitySig name _ _)) = name