Commit a7d8f437 authored by sof's avatar sof
Browse files

[project @ 2003-05-29 14:39:26 by sof]

Support for interop'ing with .NET via FFI declarations along the
lines of what Hugs98.NET offers, see

 http://haskell.org/pipermail/cvs-hugs/2003-March/001723.html

for FFI decl details.

To enable, configure with --enable-dotnet + have a look
in ghc/rts/dotnet/Makefile for details of what tools are needed to
build the .NET interop layer (tools from VS.NET / Framework SDK.)

The commit doesn't include some library additions + wider-scale
testing is required before this extension can be regarded as available
for general use. 'foreign import dotnet' is currently only supported
by the C backend.
parent c4282406
......@@ -590,6 +590,9 @@
*/
#undef VOID_INT_SIGNALS
/* Define if you want to include .NET interop support. */
#undef WANT_DOTNET_SUPPORT
/* Leave that blank line there!! Autoheader needs it.
If you're adding to this file, keep in mind:
......
......@@ -539,6 +539,18 @@ AC_ARG_ENABLE(hopengl,
)
AC_SUBST(GhcLibsWithHOpenGL)
dnl ** .NET interop support?
dnl --------------------------------------------------------------
AC_ARG_ENABLE(dotnet,
[ --enable-dotnet
Build .NET interop layer.
],
[DotnetSupport=YES],
[DotnetSupport=NO]
)
AC_DEFINE(WANT_DOTNET_SUPPORT)
AC_SUBST(DotnetSupport)
dnl --------------------------------------------------------------
dnl End of configure script option section
dnl --------------------------------------------------------------
......
......@@ -27,7 +27,9 @@ import AbsCUtils ( getAmodeRep, nonemptyAbsC,
)
import ForeignCall ( CCallSpec(..), CCallTarget(..), playSafe,
playThreadSafe, ccallConvAttribute )
playThreadSafe, ccallConvAttribute,
ForeignCall(..), Safety(..), DNCallSpec(..),
DNType(..), DNKind(..) )
import CLabel ( externallyVisibleCLabel,
needsCDecl, pprCLabel, mkClosureLabel,
mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel,
......@@ -46,7 +48,6 @@ import Name ( NamedThing(..) )
import Maybes ( catMaybes )
import PrimOp ( primOpNeedsWrapper )
import MachOp ( MachOp(..) )
import ForeignCall ( ForeignCall(..) )
import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize )
import Unique ( pprUnique, Unique{-instance NamedThing-} )
import UniqSet ( emptyUniqSet, elementOfUniqSet,
......@@ -832,30 +833,95 @@ Amendment to the above: if we can GC, we have to:
that the runtime check that PerformGC is being used sensibly will work.
\begin{code}
pprFCall call@(CCall (CCallSpec target cconv safety)) uniq args results vol_regs
= vcat [
char '{',
declare_local_vars, -- local var for *result*
vcat local_arg_decls,
pp_save_context,
process_casm local_vars pp_non_void_args call_str,
pp_restore_context,
assign_results,
char '}'
]
pprFCall call uniq args results vol_regs
= case call of
CCall (CCallSpec target _cconv safety) ->
vcat [ char '{',
declare_local_vars, -- local var for *result*
vcat local_arg_decls,
makeCall target safety
(process_casm local_vars pp_non_void_args (call_str target)),
assign_results,
char '}'
]
DNCall (DNCallSpec isStatic kind assem nm argTys resTy) ->
let
target = StaticTarget (mkFastString nm)
resultVar = "_ccall_result"
hasAssemArg = isStatic || kind == DNConstructor
invokeOp =
case kind of
DNMethod
| isStatic -> "DN_invokeStatic"
| otherwise -> "DN_invokeMethod"
DNField
| isStatic ->
if resTy == DNUnit
then "DN_setStatic"
else "DN_getStatic"
| otherwise ->
if resTy == DNUnit
then "DN_setField"
else "DN_getField"
DNConstructor -> "DN_createObject"
(methArrDecl, methArrInit, methArrName, methArrLen)
| null argTys = (empty, empty, text "NULL", text "0")
| otherwise =
( text "DotnetArg __meth_args[" <> int (length argTys) <> text "];"
, vcat (zipWith3 (\ idx arg argTy ->
text "__meth_args[" <> int idx <> text "].arg." <> text (toDotnetArgField argTy) <> equals <> ppr_amode arg <> semi $$
text "__meth_args[" <> int idx <> text "].arg_type=" <> text (toDotnetTy argTy) <> semi)
[0..]
non_void_args
argTys)
, text "__meth_args"
, int (length non_void_args)
)
in
vcat [ char '{',
declare_local_vars,
vcat local_arg_decls,
vcat [ methArrDecl
, methArrInit
, text "_ccall_result1 =" <+> text invokeOp <> parens (
hcat (punctuate comma $
(if hasAssemArg then
((if null assem then
text "NULL"
else
doubleQuotes (text assem)):)
else
id) $
[ doubleQuotes $ text nm
, methArrName
, methArrLen
, text (toDotnetTy resTy)
, text "(void*)&" <> text resultVar
])) <> semi
],
assign_results,
char '}'
]
where
(pp_saves, pp_restores) = ppr_vol_regs vol_regs
thread_macro_args = ppr_uniq_token <> comma <+>
text "rts" <> ppr (playThreadSafe safety)
ppr_uniq_token = text "tok_" <> ppr uniq
(pp_save_context, pp_restore_context)
makeCall target safety theCall =
vcat [ pp_save_context, theCall, pp_restore_context ]
where
(pp_save_context, pp_restore_context)
| playSafe safety = ( text "{ I_" <+> ppr_uniq_token <>
text "; SUSPEND_THREAD" <> parens thread_macro_args <> semi
, text "RESUME_THREAD" <> parens thread_macro_args <> text ";}"
)
| otherwise = ( pp_basic_saves $$ pp_saves,
pp_basic_restores $$ pp_restores)
where
thread_macro_args = ppr_uniq_token <> comma <+>
text "rts" <> ppr (playThreadSafe safety)
ppr_uniq_token = text "tok_" <> ppr uniq
non_void_args =
let nvas = init args
......@@ -866,7 +932,7 @@ pprFCall call@(CCall (CCallSpec target cconv safety)) uniq args results vol_regs
non_void_results =
let nvrs = grab_non_void_amodes results
in ASSERT (listLengthCmp nvrs 1 /= GT) nvrs
in ASSERT (forDotnet || listLengthCmp nvrs 1 /= GT) nvrs
-- there will usually be two results: a (void) state which we
-- should ignore and a (possibly void) result.
......@@ -874,12 +940,18 @@ pprFCall call@(CCall (CCallSpec target cconv safety)) uniq args results vol_regs
= unzip [ ppr_casm_arg a i | (a,i) <- non_void_args `zip` [1..] ]
(declare_local_vars, local_vars, assign_results)
= ppr_casm_results non_void_results
= ppr_casm_results non_void_results forDotnet
forDotnet
= case call of
DNCall{} -> True
_ -> False
call_str = case target of
CasmTarget str -> unpackFS str
StaticTarget fn -> mk_ccall_str (pprCLabelString fn) ccall_args
DynamicTarget -> mk_ccall_str dyn_fun (tail ccall_args)
call_str tgt
= case tgt of
CasmTarget str -> unpackFS str
StaticTarget fn -> mk_ccall_str (pprCLabelString fn) ccall_args
DynamicTarget -> mk_ccall_str dyn_fun (tail ccall_args)
ccall_args = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..]
dyn_fun = parens (parens (ptext SLIT("_ccall_fun_ty") <> ppr uniq) <> text "%0")
......@@ -896,6 +968,49 @@ pprFCall call@(CCall (CCallSpec target cconv safety)) uniq args results vol_regs
text "));"
])
toDotnetTy :: DNType -> String
toDotnetTy x =
case x of
DNByte -> "Dotnet_Byte"
DNBool -> "Dotnet_Bool"
DNChar -> "Dotnet_Char"
DNDouble -> "Dotnet_Double"
DNFloat -> "Dotnet_Float"
DNInt -> "Dotnet_Int"
DNInt8 -> "Dotnet_Int8"
DNInt16 -> "Dotnet_Int16"
DNInt32 -> "Dotnet_Int32"
DNInt64 -> "Dotnet_Int64"
DNWord8 -> "Dotnet_Word8"
DNWord16 -> "Dotnet_Word16"
DNWord32 -> "Dotnet_Word32"
DNWord64 -> "Dotnet_Word64"
DNPtr -> "Dotnet_Ptr"
DNUnit -> "Dotnet_Unit"
DNObject -> "Dotnet_Object"
DNString -> "Dotnet_String"
toDotnetArgField :: DNType -> String
toDotnetArgField x =
case x of
DNByte -> "arg_byte"
DNBool -> "arg_bool"
DNChar -> "arg_char"
DNDouble -> "arg_double"
DNFloat -> "arg_float"
DNInt -> "arg_int"
DNInt8 -> "arg_int8"
DNInt16 -> "arg_int16"
DNInt32 -> "arg_int32"
DNInt64 -> "arg_int64"
DNWord8 -> "arg_word8"
DNWord16 -> "arg_word16"
DNWord32 -> "arg_word32"
DNWord64 -> "arg_word64"
DNPtr -> "arg_ptr"
DNUnit -> "arg_ptr" -- can't happen
DNObject -> "arg_obj"
DNString -> "arg_str"
ppr_casm_arg :: CAddrMode -> Int -> (SDoc, SDoc)
-- (a) decl and assignment, (b) local var to be used later
......@@ -923,31 +1038,35 @@ For l-values, the critical questions are:
\begin{code}
ppr_casm_results
:: [CAddrMode] -- list of results (length <= 1)
-> Bool -- True => multiple results OK.
->
( SDoc, -- declaration of any local vars
[SDoc], -- list of result vars (same length as results)
SDoc ) -- assignment (if any) of results in local var to registers
ppr_casm_results []
ppr_casm_results [] _
= (empty, [], empty) -- no results
ppr_casm_results [r]
= let
ppr_casm_results (r:rs) multiResultsOK
| not multiResultsOK && not (null rs) = panic "ppr_casm_results: ccall/casm with many results"
| otherwise
= foldr (\ (a,b,c) (as,bs,cs) -> (a $$ as, b ++ bs, c $$ cs))
(empty,[],empty)
(zipWith pprRes (r:rs) ("" : map show [(1::Int)..]))
where
pprRes r suf = (declare_local_var, [local_var], assign_result)
where
result_reg = ppr_amode r
r_kind = getAmodeRep r
local_var = ptext SLIT("_ccall_result")
local_var = ptext SLIT("_ccall_result") <> text suf
(result_type, assign_result)
= (pprPrimKind r_kind,
hcat [ result_reg, equals, local_var, semi ])
declare_local_var = hcat [ result_type, space, local_var, semi ]
in
(declare_local_var, [local_var], assign_result)
ppr_casm_results rs
= panic "ppr_casm_results: ccall/casm with many results"
\end{code}
......
......@@ -31,24 +31,34 @@ import Type ( Type, isUnLiftedType, mkFunTys, mkFunTy,
tyVarsOfType, mkForAllTys, mkTyConApp,
isPrimitiveType, splitTyConApp_maybe,
splitNewType_maybe, splitForAllTy_maybe,
splitTyConApp,
isUnboxedTupleType
)
import PrimOp ( PrimOp(..) )
import TysPrim ( realWorldStatePrimTy, intPrimTy,
byteArrayPrimTyCon, mutableByteArrayPrimTyCon
byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
addrPrimTy
)
import TyCon ( TyCon, tyConDataCons )
import TyCon ( TyCon, tyConDataCons, tyConName )
import TysWiredIn ( unitDataConId,
unboxedSingletonDataCon, unboxedPairDataCon,
unboxedSingletonTyCon, unboxedPairTyCon,
trueDataCon, falseDataCon,
trueDataConId, falseDataConId
trueDataConId, falseDataConId,
listTyCon, charTyCon, stringTy,
tupleTyCon, tupleCon
)
import BasicTypes ( Boxity(..) )
import Literal ( mkMachInt )
import CStrings ( CLabelString )
import PrelNames ( Unique, hasKey, ioTyConKey, boolTyConKey, unitTyConKey,
int8TyConKey, int16TyConKey, int32TyConKey,
word8TyConKey, word16TyConKey, word32TyConKey
-- dotnet interop
, marshalStringName, unmarshalStringName
, marshalObjectName, unmarshalObjectName
, objectTyConName
)
import VarSet ( varSetElems )
import Constants ( wORD_SIZE)
......@@ -99,9 +109,9 @@ dsCCall :: CLabelString -- C routine to invoke
-> DsM CoreExpr
dsCCall lbl args may_gc is_asm result_ty
= mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) ->
boxResult [] result_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
getUniqueDs `thenDs` \ uniq ->
= mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) ->
boxResult [] id Nothing result_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
getUniqueDs `thenDs` \ uniq ->
let
target | is_asm = CasmTarget lbl
| otherwise = StaticTarget lbl
......@@ -188,6 +198,41 @@ unboxArg arg
\ body -> Case arg case_bndr [(DataAlt data_con,vars,body)]
)
| Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty,
tc == listTyCon,
Just (cc,[]) <- splitTyConApp_maybe arg_ty,
cc == charTyCon
-- String; dotnet only
= dsLookupGlobalId marshalStringName `thenDs` \ unpack_id ->
newSysLocalDs addrPrimTy `thenDs` \ prim_string ->
returnDs (Var prim_string,
\ body ->
let
io_ty = exprType body
(Just (_,[io_arg])) = tcSplitTyConApp_maybe io_ty
in
mkApps (Var unpack_id)
[ Type io_arg
, arg
, Lam prim_string body
])
| Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty,
tyConName tc == objectTyConName
-- Object; dotnet only
= dsLookupGlobalId marshalObjectName `thenDs` \ unpack_id ->
newSysLocalDs addrPrimTy `thenDs` \ prim_obj ->
returnDs (Var prim_obj,
\ body ->
let
io_ty = exprType body
(Just (_,[io_arg])) = tcSplitTyConApp_maybe io_ty
in
mkApps (Var unpack_id)
[ Type io_arg
, arg
, Lam prim_obj body
])
| otherwise
= getSrcLocDs `thenDs` \ l ->
pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
......@@ -206,7 +251,11 @@ unboxArg arg
\begin{code}
boxResult :: [Id] -> Type -> DsM (Type, CoreExpr -> CoreExpr)
boxResult :: [Id]
-> ((Maybe Type, CoreExpr -> CoreExpr) -> (Maybe Type, CoreExpr -> CoreExpr))
-> Maybe Id
-> Type
-> DsM (Type, CoreExpr -> CoreExpr)
-- Takes the result of the user-level ccall:
-- either (IO t),
......@@ -219,20 +268,33 @@ boxResult :: [Id] -> Type -> DsM (Type, CoreExpr -> CoreExpr)
-- the result type will be
-- State# RealWorld -> (# State# RealWorld #)
boxResult arg_ids result_ty
boxResult arg_ids augment mbTopCon result_ty
= case tcSplitTyConApp_maybe result_ty of
-- This split absolutely has to be a tcSplit, because we must
-- see the IO type; and it's a newtype which is transparent to splitTyConApp.
-- The result is IO t, so wrap the result in an IO constructor
Just (io_tycon, [io_res_ty]) | io_tycon `hasKey` ioTyConKey
-> mk_alt return_result
(resultWrapper io_res_ty) `thenDs` \ (ccall_res_ty, the_alt) ->
newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
-> resultWrapper io_res_ty `thenDs` \ res ->
let aug_res = augment res
extra_result_tys =
case aug_res of
(Just ty,_)
| isUnboxedTupleType ty ->
let (Just (_, ls)) = splitTyConApp_maybe ty in tail ls
_ -> []
in
mk_alt (return_result extra_result_tys) aug_res
`thenDs` \ (ccall_res_ty, the_alt) ->
newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
let
io_data_con = head (tyConDataCons io_tycon)
toIOCon =
case mbTopCon of
Nothing -> dataConWrapId io_data_con
Just x -> x
wrap = \ the_call ->
mkApps (Var (dataConWrapId io_data_con))
mkApps (Var toIOCon)
[ Type io_res_ty,
Lam state_id $
Case (App the_call (Var state_id))
......@@ -242,14 +304,14 @@ boxResult arg_ids result_ty
in
returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
where
return_result state ans = mkConApp unboxedPairDataCon
[Type realWorldStatePrimTy, Type io_res_ty,
state, ans]
return_result ts state anss
= mkConApp (tupleCon Unboxed (2 + length ts))
(Type realWorldStatePrimTy : Type io_res_ty : map Type ts ++
state : anss)
-- It isn't, so do unsafePerformIO
-- It's not conveniently available, so we inline it
other -> mk_alt return_result
(resultWrapper result_ty) `thenDs` \ (ccall_res_ty, the_alt) ->
other -> resultWrapper result_ty `thenDs` \ res ->
mk_alt return_result (augment res) `thenDs` \ (ccall_res_ty, the_alt) ->
let
wrap = \ the_call -> Case (App the_call (Var realWorldPrimId))
(mkWildId ccall_res_ty)
......@@ -257,14 +319,15 @@ boxResult arg_ids result_ty
in
returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
where
return_result state ans = ans
return_result state [ans] = ans
return_result _ _ = panic "return_result: expected single result"
where
mk_alt return_result (Nothing, wrap_result)
= -- The ccall returns ()
newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
let
the_rhs = return_result (Var state_id)
(wrap_result (panic "boxResult"))
[wrap_result (panic "boxResult")]
ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy]
the_alt = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs)
......@@ -272,12 +335,32 @@ boxResult arg_ids result_ty
returnDs (ccall_res_ty, the_alt)
mk_alt return_result (Just prim_res_ty, wrap_result)
= -- The ccall returns a non-() value
-- The ccall returns a non-() value
| isUnboxedTupleType prim_res_ty
= let
(Just (_, ls@(prim_res_ty1:extras))) = splitTyConApp_maybe prim_res_ty
arity = 1 + length ls
in
mapDs newSysLocalDs ls `thenDs` \ args_ids@(result_id:as) ->
newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
let
the_rhs = return_result (Var state_id)
(wrap_result (Var result_id) : map Var as)
ccall_res_ty = mkTyConApp (tupleTyCon Unboxed arity)
(realWorldStatePrimTy : ls)
the_alt = ( DataAlt (tupleCon Unboxed arity)
, (state_id : args_ids)
, the_rhs
)
in
returnDs (ccall_res_ty, the_alt)
| otherwise
=
newSysLocalDs prim_res_ty `thenDs` \ result_id ->
newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
let
the_rhs = return_result (Var state_id)
(wrap_result (Var result_id))
[wrap_result (Var result_id)]
ccall_res_ty = mkTyConApp unboxedPairTyCon [realWorldStatePrimTy, prim_res_ty]
the_alt = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs)
......@@ -286,48 +369,60 @@ boxResult arg_ids result_ty
resultWrapper :: Type
-> (Maybe Type, -- Type of the expected result, if any
CoreExpr -> CoreExpr) -- Wrapper for the result
-> DsM (Maybe Type, -- Type of the expected result, if any
CoreExpr -> CoreExpr) -- Wrapper for the result
resultWrapper result_ty
-- Base case 1: primitive types
| isPrimitiveType result_ty
= (Just result_ty, \e -> e)
= returnDs (Just result_ty, \e -> e)
-- Base case 2: the unit type ()
| Just (tc,_) <- maybe_tc_app, tc `hasKey` unitTyConKey
= (Nothing, \e -> Var unitDataConId)
= returnDs (Nothing, \e -> Var unitDataConId)
-- Base case 3: the boolean type
| Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey
= (Just intPrimTy, \e -> Case e (mkWildId intPrimTy)
[(DEFAULT ,[],Var trueDataConId ),
(LitAlt (mkMachInt 0),[],Var falseDataConId)])
= returnDs
(Just intPrimTy, \e -> Case e (mkWildId intPrimTy)
[(DEFAULT ,[],Var trueDataConId ),
(LitAlt (mkMachInt 0),[],Var falseDataConId)])
-- Recursive newtypes
| Just rep_ty <- splitNewType_maybe result_ty
= let
(maybe_ty, wrapper) = resultWrapper rep_ty
in
(maybe_ty, \e -> mkCoerce2 result_ty rep_ty (wrapper e))
= resultWrapper rep_ty `thenDs` \ (maybe_ty, wrapper) ->
returnDs (maybe_ty, \e -> mkCoerce2 result_ty rep_ty (wrapper e))
-- The type might contain foralls (eg. for dummy type arguments,
-- referring to 'Ptr a' is legal).
| Just (tyvar, rest) <- splitForAllTy_maybe result_ty
= let
(maybe_ty, wrapper) = resultWrapper rest
in
(maybe_ty, \e -> Lam tyvar (wrapper e))
= resultWrapper rest `thenDs` \ (maybe_ty, wrapper) ->
returnDs (maybe_ty, \e -> Lam tyvar (wrapper e))
-- Data types with a single constructor, which has a single arg
| Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitProductType_maybe result_ty,
dataConSourceArity data_con == 1
= let
(maybe_ty, wrapper) = resultWrapper unwrapped_res_ty
(unwrapped_res_ty : _) = data_con_arg_tys
narrow_wrapper = maybeNarrow tycon
in
(maybe_ty, \e -> mkApps (Var (dataConWrapId data_con))
(map Type tycon_arg_tys ++ [wrapper (narrow_wrapper e)]))
resultWrapper unwrapped_res_ty `thenDs` \ (maybe_ty, wrapper) ->
returnDs
(maybe_ty, \e -> mkApps (Var (dataConWrapId data_con))
(map Type tycon_arg_tys ++ [wrapper (narrow_wrapper e)]))
-- Strings; 'dotnet' only.
| Just (tc, [arg_ty]) <- maybe_tc_app, tc == listTyCon,
Just (cc,[]) <- splitTyConApp_maybe arg_ty, cc == charTyCon
= dsLookupGlobalId unmarshalStringName `thenDs` \ pack_id ->
returnDs (Just addrPrimTy,
\ e -> App (Var pack_id) e)
-- Objects; 'dotnet' only.
| Just (tc, [arg_ty]) <- maybe_tc_app,
tyConName tc == objectTyConName
= dsLookupGlobalId unmarshalObjectName `thenDs` \ pack_id ->
returnDs (Just addrPrimTy,
\ e -> App (Var pack_id) e)
| otherwise
= pprPanic "resultWrapper" (ppr result_ty)
......
......@@ -30,6 +30,7 @@ import TcType ( Type, mkFunTys, mkForAllTys, mkTyConApp,
tcSplitForAllTys, tcSplitFunTys, tcTyConAppArgs,
)
import BasicTypes ( Boxity(..) )
import HscTypes ( ForeignStubs(..) )
import ForeignCall ( ForeignCall(..), CCallSpec(..),
Safety(..), playSafe,
......@@ -38,10 +39,11 @@ import ForeignCall ( ForeignCall(..), CCallSpec(..),
ccallConvAttribute
)
import CStrings ( CLabelString )
import TysWiredIn ( unitTy, stablePtrTyCon )
import TysWiredIn ( unitTy, stablePtrTyCon, tupleTyCon )
import TysPrim ( addrPrimTy, mkStablePtrPrimTy, alphaTy )
import PrimRep ( getPrimRepSizeInBytes )
import PrelNames ( hasKey, ioTyConKey, newStablePtrName, bindIOName )
import PrelNames ( hasKey, ioTyConKey, newStablePtrName, bindIOName,
checkDotnetResName )
import BasicTypes ( Activation( NeverActive ) )
import Outputable
import Maybe ( fromJust )
......@@ -150,11 +152,10 @@ dsCImport :: Id
-> Bool -- True <=> no headers in the f.i decl
-> DsM ([Binding], SDoc, SDoc)
dsCImport id (CLabel cid) _ _ no_hdrs
= ASSERT(fromJust resTy `eqType` addrPrimTy) -- typechecker ensures this
returnDs ([(setImpInline no_hdrs id, rhs)], empty, empty)
where
(resTy, foRhs) = resultWrapper (idType id)
rhs = foRhs (mkLit (MachLabel cid Nothing))
= resultWrapper (idType id) `thenDs` \ (resTy, foRhs) ->
ASSERT(fromJust resTy `eqType` addrPrimTy) -- typechecker ensures this
let rhs = foRhs (mkLit (MachLabel cid Nothing)) in
returnDs ([(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 _ _
......@@ -204,8 +205,34 @@ dsFCall fn_id fcall no_hdrs
-- ForeignObj#s live across a 'safe' foreign import).
maybe_arg_ids | unsafe_call fcall = work_arg_ids
| otherwise = []
forDotnet =
case fcall of
DNCall{} -> True
_ -> False
topConDs
| forDotnet =
dsLookupGlobalId checkDotnetResName `thenDs` \ check_id ->
return (Just check_id)
| otherwise = return Nothing
augmentResultDs
| forDotnet =
newSysLocalDs addrPrimTy `thenDs` \ err_res ->
returnDs (\ (mb_res_ty, resWrap) ->
case mb_res_ty of
Nothing -> (Just (mkTyConApp (tupleTyCon Unboxed 1)
[ addrPrimTy ]),