diff options
| author | sof <unknown> | 2003-05-29 14:39:31 +0000 |
|---|---|---|
| committer | sof <unknown> | 2003-05-29 14:39:31 +0000 |
| commit | a7d8f43718b167689c0a4a4c23b33a325e0239f1 (patch) | |
| tree | 5da294fb5b8f5ad147c498115df6a024887cdeea | |
| parent | c4282406d8cf94962f41ebd7eaa7abf4ee23ac7d (diff) | |
| download | haskell-a7d8f43718b167689c0a4a4c23b33a325e0239f1.tar.gz | |
[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.
26 files changed, 2701 insertions, 140 deletions
diff --git a/acconfig.h b/acconfig.h index 51979e0de2..c6a17ae4f1 100644 --- a/acconfig.h +++ b/acconfig.h @@ -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: diff --git a/configure.in b/configure.in index 9ab0b3e451..9d47366ada 100644 --- a/configure.in +++ b/configure.in @@ -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 -------------------------------------------------------------- diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index 0d700a895e..f0ae17779f 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -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} diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index 0fcfdd5b91..5ec8209d2a 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -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) diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index 9cefb05820..2d4eb35ef5 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -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 ]), + resWrap) + Just x -> (Just (mkTyConApp (tupleTyCon Unboxed 2) + [ x, addrPrimTy ]), + resWrap)) + | otherwise = returnDs id in - boxResult maybe_arg_ids io_res_ty `thenDs` \ (ccall_result_ty, res_wrapper) -> + augmentResultDs `thenDs` \ augment -> + topConDs `thenDs` \ topCon -> + boxResult maybe_arg_ids augment topCon io_res_ty `thenDs` \ (ccall_result_ty, res_wrapper) -> getUniqueDs `thenDs` \ ccall_uniq -> getUniqueDs `thenDs` \ work_uniq -> diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs index 287d730f7d..01d1ed8c40 100644 --- a/ghc/compiler/deSugar/MatchLit.lhs +++ b/ghc/compiler/deSugar/MatchLit.lhs @@ -65,11 +65,10 @@ dsLit (HsIntPrim i) = returnDs (mkIntLit i) dsLit (HsFloatPrim f) = returnDs (mkLit (MachFloat f)) dsLit (HsDoublePrim d) = returnDs (mkLit (MachDouble d)) dsLit (HsLitLit str ty) - = ASSERT( isJust maybe_ty ) - returnDs (wrap_fn (mkLit (MachLitLit str rep_ty))) - where - (maybe_ty, wrap_fn) = resultWrapper ty - Just rep_ty = maybe_ty + = resultWrapper ty `thenDs` \ (maybe_ty, wrap_fn) -> + ASSERT( isJust maybe_ty ) + let (Just rep_ty) = maybe_ty in + returnDs (wrap_fn (mkLit (MachLitLit str rep_ty))) dsLit (HsRat r ty) = mkIntegerExpr (numerator r) `thenDs` \ num -> diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index 1721e73344..7583e1cd27 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -114,6 +114,10 @@ foreignCallCode lhs call@(CCall (CCallSpec ctarget cconv safety)) rhs Int64Rep -> Int64Rep Word64Rep -> Word64Rep other -> IntRep + +-- a bit late to catch this here.. +foreignCallCode _ DNCall{} _ + = panic "foreignCallCode: .NET interop not supported via NCG; compile with -fvia-C" \end{code} %************************************************************************ diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 5624a2deca..f07c989e09 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -101,7 +101,7 @@ import Lex ( P, mapP, setSrcLocP, thenP, returnP, getSrcLocP, failMsgP ) import HscTypes ( RdrAvailInfo, GenAvailInfo(..) ) import TysWiredIn ( unitTyCon ) import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..), - DNCallSpec(..)) + DNCallSpec(..), DNKind(..)) import OccName ( srcDataName, varName, isDataOcc, isTcOcc, occNameUserString, mkDefaultMethodOcc, mkVarOcc ) import SrcLoc @@ -761,7 +761,8 @@ mkImport (CCall cconv) safety (entity, v, ty) loc = parseCImport entity cconv safety v `thenP` \importSpec -> returnP $ ForD (ForeignImport v ty importSpec False loc) mkImport (DNCall ) _ (entity, v, ty) loc = - returnP $ ForD (ForeignImport v ty (DNImport (DNCallSpec entity)) False loc) + parseDImport entity `thenP` \ spec -> + returnP $ ForD (ForeignImport v ty (DNImport spec) False loc) -- parse the entity string of a foreign import declaration for the `ccall' or -- `stdcall' calling convention' @@ -820,6 +821,42 @@ parseCImport entity cconv safety v build cid header True lib = returnP $ CImport cconv safety header lib (CLabel cid ) +-- +-- Unravel a dotnet spec string. +-- +parseDImport :: FastString -> P DNCallSpec +parseDImport entity = parse0 comps + where + comps = words (unpackFS entity) + + parse0 [] = d'oh + parse0 (x : xs) + | x == "static" = parse1 True xs + | otherwise = parse1 False (x:xs) + + parse1 _ [] = d'oh + parse1 isStatic (x:xs) + | x == "method" = parse2 isStatic DNMethod xs + | x == "field" = parse2 isStatic DNField xs + | x == "ctor" = parse2 isStatic DNConstructor xs + parse1 isStatic xs = parse2 isStatic DNMethod xs + + parse2 _ _ [] = d'oh + parse2 isStatic kind (('[':x):xs) = + case x of + [] -> d'oh + vs | last vs == ']' -> parse3 isStatic kind (init vs) xs + parse2 isStatic kind xs = parse3 isStatic kind "" xs + + parse3 isStatic kind assem [x] = + returnP (DNCallSpec isStatic kind assem x + -- these will be filled in once known. + (error "FFI-dotnet-args") + (error "FFI-dotnet-result")) + parse3 _ _ _ _ = d'oh + + d'oh = parseError "Malformed entity string" + -- construct a foreign export declaration -- mkExport :: CallConv diff --git a/ghc/compiler/prelude/ForeignCall.lhs b/ghc/compiler/prelude/ForeignCall.lhs index 81d57052e2..0197d64050 100644 --- a/ghc/compiler/prelude/ForeignCall.lhs +++ b/ghc/compiler/prelude/ForeignCall.lhs @@ -15,15 +15,16 @@ module ForeignCall ( CCallTarget(..), isDynamicTarget, isCasmTarget, CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute, - DNCallSpec(..), + DNCallSpec(..), DNKind(..), DNType(..), + withDNTypes, okToExposeFCall ) where #include "HsVersions.h" -import CStrings ( CLabelString, pprCLabelString ) -import FastString ( FastString ) +import CStrings ( CLabelString, pprCLabelString ) +import FastString ( FastString ) import Binary import Outputable \end{code} @@ -183,17 +184,62 @@ instance Outputable CCallSpec where %************************************************************************ %* * -\subsubsection{.NET stuff} +\subsubsection{.NET interop} %* * %************************************************************************ \begin{code} -data DNCallSpec = DNCallSpec FastString - deriving (Eq) +data DNCallSpec = + DNCallSpec Bool -- True => static method/field + DNKind -- what type of access + String -- assembly + String -- fully qualified method/field name. + [DNType] -- argument types. + DNType -- result type. + deriving ( Eq ) + {-! derive: Binary !-} + +data DNKind + = DNMethod + | DNField + | DNConstructor + deriving ( Eq ) {-! derive: Binary !-} +data DNType + = DNByte + | DNBool + | DNChar + | DNDouble + | DNFloat + | DNInt + | DNInt8 + | DNInt16 + | DNInt32 + | DNInt64 + | DNWord8 + | DNWord16 + | DNWord32 + | DNWord64 + | DNPtr + | DNUnit + | DNObject + | DNString + deriving ( Eq ) + {-! derive: Binary !-} + +withDNTypes :: DNCallSpec -> [DNType] -> DNType -> DNCallSpec +withDNTypes (DNCallSpec isStatic k assem nm _ _) argTys resTy + = DNCallSpec isStatic k assem nm argTys resTy + instance Outputable DNCallSpec where - ppr (DNCallSpec s) = char '"' <> ftext s <> char '"' + ppr (DNCallSpec isStatic kind ass nm _ _ ) + = char '"' <> + (if isStatic then text "static" else empty) <+> + (text (case kind of { DNMethod -> "method" ; DNField -> "field"; DNConstructor -> "ctor" })) <+> + (if null ass then char ' ' else char '[' <> text ass <> char ']') <> + text nm <> + char '"' \end{code} @@ -291,11 +337,91 @@ instance Binary CCallConv where _ -> do return StdCallConv instance Binary DNCallSpec where - put_ bh (DNCallSpec aa) = do - put_ bh aa + put_ bh (DNCallSpec isStatic kind ass nm _ _) = do + put_ bh isStatic + put_ bh kind + put_ bh ass + put_ bh nm get bh = do - aa <- get bh - return (DNCallSpec aa) + isStatic <- get bh + kind <- get bh + ass <- get bh + nm <- get bh + return (DNCallSpec isStatic kind ass nm [] undefined) + +instance Binary DNKind where + put_ bh DNMethod = do + putByte bh 0 + put_ bh DNField = do + putByte bh 1 + put_ bh DNConstructor = do + putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> do return DNMethod + 1 -> do return DNField + _ -> do return DNConstructor + +instance Binary DNType where + put_ bh DNByte = do + putByte bh 0 + put_ bh DNBool = do + putByte bh 1 + put_ bh DNChar = do + putByte bh 2 + put_ bh DNDouble = do + putByte bh 3 + put_ bh DNFloat = do + putByte bh 4 + put_ bh DNInt = do + putByte bh 5 + put_ bh DNInt8 = do + putByte bh 6 + put_ bh DNInt16 = do + putByte bh 7 + put_ bh DNInt32 = do + putByte bh 8 + put_ bh DNInt64 = do + putByte bh 9 + put_ bh DNWord8 = do + putByte bh 10 + put_ bh DNWord16 = do + putByte bh 11 + put_ bh DNWord32 = do + putByte bh 12 + put_ bh DNWord64 = do + putByte bh 13 + put_ bh DNPtr = do + putByte bh 14 + put_ bh DNUnit = do + putByte bh 15 + put_ bh DNObject = do + putByte bh 16 + put_ bh DNString = do + putByte bh 17 + + get bh = do + h <- getByte bh + case h of + 0 -> return DNByte + 1 -> return DNBool + 2 -> return DNChar + 3 -> return DNDouble + 4 -> return DNFloat + 5 -> return DNInt + 6 -> return DNInt8 + 7 -> return DNInt16 + 8 -> return DNInt32 + 9 -> return DNInt64 + 10 -> return DNWord8 + 11 -> return DNWord16 + 12 -> return DNWord32 + 13 -> return DNWord64 + 14 -> return DNPtr + 15 -> return DNUnit + 16 -> return DNObject + 17 -> return DNString -- Imported from other files :- diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index 01e98f7eb9..6ad498079e 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -215,6 +215,10 @@ basicKnownKeyNames -- Booleans andName, orName + + -- dotnet interop + , objectTyConName, marshalObjectName, unmarshalObjectName + , marshalStringName, unmarshalStringName, checkDotnetResName ] monadNames :: [Name] -- The monad ops need by a HsDo @@ -256,7 +260,9 @@ pREL_FLOAT_Name = mkModuleName "GHC.Float" pREL_TOP_HANDLER_Name = mkModuleName "GHC.TopHandler" sYSTEM_IO_Name = mkModuleName "System.IO" dYNAMIC_Name = mkModuleName "Data.Dynamic" +tRAVERSE_Name = mkModuleName "Data.Traverse" gENERICS_Name = mkModuleName "Data.Generics" +dOTNET_Name = mkModuleName "GHC.Dotnet" rEAD_PREC_Name = mkModuleName "Text.ParserCombinators.ReadPrec" lEX_Name = mkModuleName "Text.Read.Lex" @@ -696,6 +702,15 @@ splitName = varQual gLA_EXTS_Name FSLIT("split") splitIdKey -- Recursive-do notation mfixName = varQual mONAD_FIX_Name FSLIT("mfix") mfixIdKey + +-- dotnet interop +objectTyConName = wTcQual dOTNET_Name FSLIT("Object") objectTyConKey +unmarshalObjectName = varQual dOTNET_Name FSLIT("unmarshalObject") unmarshalObjectIdKey +marshalObjectName = varQual dOTNET_Name FSLIT("marshalObject") marshalObjectIdKey +marshalStringName = varQual dOTNET_Name FSLIT("marshalString") marshalStringIdKey +unmarshalStringName = varQual dOTNET_Name FSLIT("unmarshalString") unmarshalStringIdKey +checkDotnetResName = varQual dOTNET_Name FSLIT("checkResult") checkDotnetResNameIdKey + \end{code} %************************************************************************ @@ -837,6 +852,9 @@ genUnitTyConKey = mkPreludeTyConUnique 81 -- Parallel array type constructor parrTyConKey = mkPreludeTyConUnique 82 +-- dotnet interop +objectTyConKey = mkPreludeTyConUnique 83 + ---------------- Template Haskell ------------------- -- USES TyConUniques 100-119 ----------------------------------------------------- @@ -963,6 +981,14 @@ enumFromThenToPIdKey = mkPreludeMiscIdUnique 90 bpermutePIdKey = mkPreludeMiscIdUnique 91 bpermuteDftPIdKey = mkPreludeMiscIdUnique 92 indexOfPIdKey = mkPreludeMiscIdUnique 93 + +-- dotnet interop +unmarshalObjectIdKey = mkPreludeMiscIdUnique 94 +marshalObjectIdKey = mkPreludeMiscIdUnique 95 +marshalStringIdKey = mkPreludeMiscIdUnique 96 +unmarshalStringIdKey = mkPreludeMiscIdUnique 97 +checkDotnetResNameIdKey = mkPreludeMiscIdUnique 98 + \end{code} Certain class operations from Prelude classes. They get their own diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index d94ab3aabd..f74c71244e 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -47,7 +47,13 @@ import Name ( Name ) import NameSet import NameEnv import ErrUtils ( dumpIfSet ) -import PrelNames ( newStablePtrName, bindIOName, returnIOName ) +import PrelNames ( newStablePtrName, bindIOName, returnIOName + -- dotnet interop + , objectTyConName, + , unmarshalObjectName, marshalObjectName + , unmarshalStringName, marshalStringName + , checkDotnetResName + ) import List ( partition ) import Bag ( bagToList ) import Outputable @@ -314,8 +320,20 @@ rnHsForeignDecl (ForeignImport name ty spec isDeprec src_loc) returnM (ForeignImport name' ty' spec isDeprec src_loc, fvs `plusFV` extras spec) where - extras (CImport _ _ _ _ CWrapper) = mkFVs [newStablePtrName, - bindIOName, returnIOName] + extras (CImport _ _ _ _ CWrapper) + = mkFVs [ newStablePtrName + , bindIOName + , returnIOName + ] + extras (DNImport _) + = mkFVs [ bindIOName + , objectTyConName + , unmarshalObjectName + , marshalObjectName + , marshalStringName + , unmarshalStringName + , checkDotnetResName + ] extras _ = emptyFVs rnHsForeignDecl (ForeignExport name ty spec isDeprec src_loc) diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index 6fe8bdc9bd..ec2cffe89b 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -17,6 +17,7 @@ module TcForeign , tcForeignExports ) where +#include "config.h" #include "HsVersions.h" import HsSyn ( ForeignDecl(..), HsExpr(..), @@ -42,10 +43,11 @@ import TcType ( Type, tcSplitFunTys, tcSplitTyConApp_maybe, isFFIArgumentTy, isFFIImportResultTy, isFFIExportResultTy, isFFILabelTy, isFFIExternalTy, isFFIDynArgumentTy, - isFFIDynResultTy, + isFFIDynResultTy, isFFIDotnetTy, isFFIDotnetObjTy, + toDNType ) import ForeignCall ( CExportSpec(..), CCallTarget(..), CCallConv(..), - isDynamicTarget, isCasmTarget ) + isDynamicTarget, isCasmTarget, withDNTypes, DNKind(..), DNCallSpec(..) ) import CStrings ( CLabelString, isCLabelString ) import PrelNames ( hasKey, ioTyConKey ) import CmdLineOpts ( dopt_HscLang, HscLang(..) ) @@ -91,56 +93,75 @@ tcFImport fo@(ForeignImport nm hs_ty imp_decl isDeprec src_loc) -- things are LocalIds. However, it does not need zonking, -- (so TcHsSyn.zonkForeignExports ignores it). in - tcCheckFIType sig_ty arg_tys res_ty imp_decl `thenM_` + tcCheckFIType sig_ty arg_tys res_ty imp_decl `thenM` \ imp_decl' -> -- can't use sig_ty here because it :: Type and we need HsType Id -- hence the undefined - returnM (id, ForeignImport id undefined imp_decl isDeprec src_loc) + returnM (id, ForeignImport id undefined imp_decl' isDeprec src_loc) \end{code} ------------ Checking types for foreign import ---------------------- \begin{code} -tcCheckFIType _ _ _ (DNImport _) - = checkCg checkDotNet - -tcCheckFIType sig_ty arg_tys res_ty (CImport _ _ _ _ (CLabel _)) +tcCheckFIType _ arg_tys res_ty (DNImport spec) + = checkCg checkDotnet `thenM_` + getDOpts `thenM` \ dflags -> + checkForeignArgs (isFFIDotnetTy dflags) arg_tys `thenM_` + checkForeignRes True{-non IO ok-} (isFFIDotnetTy dflags) res_ty `thenM_` + let (DNCallSpec isStatic kind _ _ _ _) = spec in + (case kind of + DNMethod | not isStatic -> + case arg_tys of + [] -> addErrTc illegalDNMethodSig + _ + | not (isFFIDotnetObjTy (last arg_tys)) -> addErrTc illegalDNMethodSig + | otherwise -> returnM () + _ -> returnM ()) `thenM_` + returnM (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty))) + +tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ _ (CLabel _)) = checkCg checkCOrAsm `thenM_` - check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty) + check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty) `thenM_` + return idecl -tcCheckFIType sig_ty arg_tys res_ty (CImport cconv _ _ _ CWrapper) +tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper) = -- Foreign wrapper (former f.e.d.) -- The type must be of the form ft -> IO (FunPtr ft), where ft is a -- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well -- as ft -> IO Addr is accepted, too. The use of the latter two forms -- is DEPRECATED, though. checkCg checkCOrAsmOrInterp `thenM_` - case arg_tys of - [arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys `thenM_` - checkForeignRes nonIOok isFFIExportResultTy res1_ty `thenM_` - checkForeignRes mustBeIO isFFIDynResultTy res_ty `thenM_` + (case arg_tys of + [arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys `thenM_` + checkForeignRes nonIOok isFFIExportResultTy res1_ty `thenM_` + checkForeignRes mustBeIO isFFIDynResultTy res_ty `thenM_` checkFEDArgs arg1_tys where (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty - other -> addErrTc (illegalForeignTyErr empty sig_ty) + other -> addErrTc (illegalForeignTyErr empty sig_ty) ) `thenM_` + return idecl -tcCheckFIType sig_ty arg_tys res_ty (CImport _ safety _ _ (CFunction target)) +tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ _ (CFunction target)) | isDynamicTarget target -- Foreign import dynamic = checkCg checkCOrAsmOrInterp `thenM_` case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr - [] -> check False (illegalForeignTyErr empty sig_ty) - (arg1_ty:arg_tys) -> getDOpts `thenM` \ dflags -> - check (isFFIDynArgumentTy arg1_ty) - (illegalForeignTyErr argument arg1_ty) `thenM_` - checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenM_` - checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty - + [] -> + check False (illegalForeignTyErr empty sig_ty) `thenM_` + return idecl + (arg1_ty:arg_tys) -> + getDOpts `thenM` \ dflags -> + check (isFFIDynArgumentTy arg1_ty) + (illegalForeignTyErr argument arg1_ty) `thenM_` + checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenM_` + checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty `thenM_` + return idecl | otherwise -- Normal foreign import = checkCg (if isCasmTarget target then checkC else checkCOrAsmOrDotNetOrInterp) `thenM_` checkCTarget target `thenM_` getDOpts `thenM` \ dflags -> checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenM_` - checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty + checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty `thenM_` + return idecl -- This makes a convenient place to check -- that the C identifier is valid for C @@ -267,8 +288,13 @@ checkForeignRes non_io_result_ok pred_res_ty ty \end{code} \begin{code} -checkDotNet HscILX = Nothing -checkDotNet other = Just (text "requires .NET code generation (-filx)") +checkDotnet HscILX = Nothing +#if defined(mingw32_TARGET_OS) +checkDotnet HscC = Nothing +checkDotnet _ = Just (text "requires C code generation (-fvia-C)") +#else +checkDotnet other = Just (text "requires .NET support (-filx or win32)") +#endif checkC HscC = Nothing checkC other = Just (text "requires C code generation (-fvia-C)") @@ -331,5 +357,9 @@ badCName target foreignDeclCtxt fo = hang (ptext SLIT("When checking declaration:")) 4 (ppr fo) + +illegalDNMethodSig + = ptext SLIT("'This pointer' expected as last argument") + \end{code} diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index e2ec116311..cd4fe1447b 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -75,6 +75,10 @@ module TcType ( isFFIDynArgumentTy, -- :: Type -> Bool isFFIDynResultTy, -- :: Type -> Bool isFFILabelTy, -- :: Type -> Bool + isFFIDotnetTy, -- :: DynFlags -> Type -> Bool + isFFIDotnetObjTy, -- :: Type -> Bool + + toDNType, -- :: Type -> DNType --------------------------------- -- Unifier and matcher @@ -139,7 +143,9 @@ import DataCon ( DataCon ) import TyCon ( TyCon, isUnLiftedTyCon ) import Class ( classHasFDs, Class ) import Var ( TyVar, Id, tyVarKind, isMutTyVar, mutTyVarDetails ) -import ForeignCall ( Safety, playSafe ) +import ForeignCall ( Safety, playSafe + , DNType(..) + ) import VarEnv import VarSet @@ -149,7 +155,8 @@ import Name ( Name, NamedThing(..), mkInternalName, getSrcLoc ) import OccName ( OccName, mkDictOcc ) import NameSet import PrelNames -- Lots (e.g. in isFFIArgumentTy) -import TysWiredIn ( ptrTyCon, funPtrTyCon, addrTyCon, unitTyCon ) +import TysWiredIn ( ptrTyCon, funPtrTyCon, addrTyCon, unitTyCon, + charTyCon, listTyCon ) import BasicTypes ( IPName(..), ipNameName ) import Unique ( Unique, Uniquable(..) ) import SrcLoc ( SrcLoc ) @@ -836,6 +843,63 @@ isFFILabelTy :: Type -> Bool -- or a newtype of either. isFFILabelTy = checkRepTyCon (\tc -> tc == ptrTyCon || tc == funPtrTyCon || tc == addrTyCon) +isFFIDotnetTy :: DynFlags -> Type -> Bool +isFFIDotnetTy dflags ty + = checkRepTyCon (\ tc -> not (isByteArrayLikeTyCon tc) && + (legalFIResultTyCon dflags tc || + isFFIDotnetObjTy ty || isStringTy ty)) ty + +-- Support String as an argument or result from a .NET FFI call. +isStringTy ty = + case tcSplitTyConApp_maybe (repType ty) of + Just (tc, [arg_ty]) + | tc == listTyCon -> + case tcSplitTyConApp_maybe (repType arg_ty) of + Just (cc,[]) -> cc == charTyCon + _ -> False + _ -> False + +-- Support String as an argument or result from a .NET FFI call. +isFFIDotnetObjTy ty = + let + (_, t_ty) = tcSplitForAllTys ty + in + case tcSplitTyConApp_maybe (repType t_ty) of + Just (tc, [arg_ty]) | getName tc == objectTyConName -> True + _ -> False + +toDNType :: Type -> DNType +toDNType ty + | isStringTy ty = DNString + | isFFIDotnetObjTy ty = DNObject + | Just (tc,argTys) <- tcSplitTyConApp_maybe ty = + case lookup (getUnique tc) dn_assoc of + Just x -> x + Nothing + | tc `hasKey` ioTyConKey -> toDNType (head argTys) + | otherwise -> pprPanic ("toDNType: unsupported .NET type") (pprType ty <+> parens (hcat (map pprType argTys)) <+> ppr tc) + where + dn_assoc :: [ (Unique, DNType) ] + dn_assoc = [ (unitTyConKey, DNUnit) + , (intTyConKey, DNInt) + , (int8TyConKey, DNInt8) + , (int16TyConKey, DNInt16) + , (int32TyConKey, DNInt32) + , (int64TyConKey, DNInt64) + , (wordTyConKey, DNInt) + , (word8TyConKey, DNWord8) + , (word16TyConKey, DNWord16) + , (word32TyConKey, DNWord32) + , (word64TyConKey, DNWord64) + , (floatTyConKey, DNFloat) + , (doubleTyConKey, DNDouble) + , (addrTyConKey, DNPtr) + , (ptrTyConKey, DNPtr) + , (funPtrTyConKey, DNPtr) + , (charTyConKey, DNChar) + , (boolTyConKey, DNBool) + ] + checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool -- Look through newtypes -- Non-recursive ones are transparent to splitTyConApp, @@ -855,7 +919,7 @@ legalFEArgTyCon :: TyCon -> Bool -- bytearrays from a _ccall_ / foreign declaration -- (or be passed them as arguments in foreign exported functions). legalFEArgTyCon tc - | getUnique tc `elem` [ byteArrayTyConKey, mutableByteArrayTyConKey ] + | isByteArrayLikeTyCon tc = False -- It's also illegal to make foreign exports that take unboxed -- arguments. The RTS API currently can't invoke such things. --SDM 7/2000 @@ -864,22 +928,20 @@ legalFEArgTyCon tc legalFIResultTyCon :: DynFlags -> TyCon -> Bool legalFIResultTyCon dflags tc - | getUnique tc `elem` - [ byteArrayTyConKey, mutableByteArrayTyConKey ] = False - | tc == unitTyCon = True - | otherwise = marshalableTyCon dflags tc + | isByteArrayLikeTyCon tc = False + | tc == unitTyCon = True + | otherwise = marshalableTyCon dflags tc legalFEResultTyCon :: TyCon -> Bool legalFEResultTyCon tc - | getUnique tc `elem` - [ byteArrayTyConKey, mutableByteArrayTyConKey ] = False - | tc == unitTyCon = True - | otherwise = boxedMarshalableTyCon tc + | isByteArrayLikeTyCon tc = False + | tc == unitTyCon = True + | otherwise = boxedMarshalableTyCon tc legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Bool -- Checks validity of types going from Haskell -> external world legalOutgoingTyCon dflags safety tc - | playSafe safety && getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey] + | playSafe safety && isByteArrayLikeTyCon tc = False | otherwise = marshalableTyCon dflags tc @@ -900,6 +962,10 @@ boxedMarshalableTyCon tc , byteArrayTyConKey, mutableByteArrayTyConKey , boolTyConKey ] + +isByteArrayLikeTyCon :: TyCon -> Bool +isByteArrayLikeTyCon tc = + getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey] \end{code} diff --git a/ghc/includes/DNInvoke.h b/ghc/includes/DNInvoke.h new file mode 100644 index 0000000000..410bd640e1 --- /dev/null +++ b/ghc/includes/DNInvoke.h @@ -0,0 +1,55 @@ +/* + * C callable bridge to the .NET object model + * + * (c) 2003, sof. + * + */ +#ifndef __DNINVOKE_H__ +#define __DNINVOKE_H__ +#include "Dotnet.h" + +extern char* DN_invokeStatic ( char *assemName, + char *methName, + DotnetArg *args, + int n_args, + DotnetType resultTy, + void *res); +extern char* DN_getStatic ( char *assemName, + char *fieldClsName, + DotnetArg *args, + int n_args, + DotnetType resultTy, + void *res); +extern char* DN_setStatic ( char *assemName, + char *fieldClsName, + DotnetArg *args, + int n_args, + DotnetType resultTy, + void *res); +extern char* DN_createObject ( char *assemName, + char *methName, + DotnetArg *args, + int n_args, + DotnetType resultTy, + void *res); + +extern char* DN_invokeMethod ( char *methName, + DotnetArg *args, + int n_args, + DotnetType resultTy, + void *res); + +extern char* DN_getField ( char *methName, + DotnetArg *args, + int n_args, + DotnetType resultTy, + void *res); +extern char* DN_setField ( char *clsAndMethName, + DotnetArg *args, + int n_args, + DotnetType resultTy, + void *res); + +extern void stopDotnetBridge(void); + +#endif /* __DNINVOKE_H__ */ diff --git a/ghc/includes/Dotnet.h b/ghc/includes/Dotnet.h new file mode 100644 index 0000000000..89dace2ced --- /dev/null +++ b/ghc/includes/Dotnet.h @@ -0,0 +1,64 @@ +/* + * Types and definitions to support GHC .NET interop. + * + * (c) 2003, sof. + * + */ +#ifndef __DOTNET_H__ +#define __DOTNET_H__ + +typedef enum { + Dotnet_Byte = 0, + Dotnet_Boolean, + Dotnet_Char, + Dotnet_Double, + Dotnet_Float, + Dotnet_Int, + Dotnet_Int8, + Dotnet_Int16, + Dotnet_Int32, + Dotnet_Int64, + Dotnet_Word8, + Dotnet_Word16, + Dotnet_Word32, + Dotnet_Word64, + Dotnet_Ptr, + Dotnet_Unit, + Dotnet_Object, + Dotnet_String +} DotnetType; + +typedef union { + unsigned char arg_byte; + unsigned int arg_bool; + unsigned char arg_char; + int arg_int; + signed char arg_int8; + signed short arg_int16; + signed int arg_int32; +#if defined(_MSC_VER) + signed __int64 arg_int64; +#else + signed long long arg_int64; +#endif + float arg_float; + double arg_double; + unsigned char arg_word8; + unsigned short arg_word16; + unsigned int arg_word32; +#if defined(_MSC_VER) + unsigned __int64 arg_word64; +#else + unsigned long long arg_word64; +#endif + void* arg_ptr; + void* arg_obj; + void* arg_str; +} DotnetArgVal; + +typedef struct { + DotnetArgVal arg; + DotnetType arg_type; +} DotnetArg; + +#endif /* __DOTNET_H__ */ diff --git a/ghc/includes/Stg.h b/ghc/includes/Stg.h index a877e2f162..17568b594f 100644 --- a/ghc/includes/Stg.h +++ b/ghc/includes/Stg.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Stg.h,v 1.51 2003/05/23 08:28:48 simonmar Exp $ + * $Id: Stg.h,v 1.52 2003/05/29 14:39:30 sof Exp $ * * (c) The GHC Team, 1998-1999 * @@ -225,6 +225,10 @@ DLL_IMPORT_RTS extern int prog_argc; extern void stackOverflow(void); +#if defined(WANT_DOTNET_SUPPORT) +#include "DNInvoke.h" +#endif + /* Creating and destroying an adjustor thunk. I cannot make myself create a separate .h file for these two (sof.) diff --git a/ghc/rts/Makefile b/ghc/rts/Makefile index 19163ee8d7..0a0fa9dfe6 100644 --- a/ghc/rts/Makefile +++ b/ghc/rts/Makefile @@ -133,6 +133,21 @@ ifeq "$(HaveLibMingwEx)" "YES" PACKAGE_CPP_OPTS += -DHAVE_LIBMINGWEX endif +ifeq "$(DotnetSupport)" "YES" + +# +# Would like to just use SUBDIRS here, but need to +# descend into dotnet/ earlier than that. +# +all :: + $(MAKE) -C dotnet all + +# But use SUBDIRS for other recursive targets. +SUBDIRS += dotnet + +LIBOBJS += dotnet/Invoke.o +endif + #----------------------------------------------------------------------------- # Include the Front panel code? diff --git a/ghc/rts/dotnet/Invoke.c b/ghc/rts/dotnet/Invoke.c new file mode 100644 index 0000000000..585dcacaad --- /dev/null +++ b/ghc/rts/dotnet/Invoke.c @@ -0,0 +1,1081 @@ +/* + * C callable bridge to the .NET object model + * + * Managed C++ is used to access the .NET object model via + * System.Reflection. Here we provide C callable functions + * to that functionality, which we then export via a COM + * component. + * + * Note: the _only_ reason why we're going via COM and not simply + * exposing the required via some DLL entry points, is that COM + * gives us location independence (i.e., the RTS doesn't need + * be told where this interop layer resides in order to hoik + * it in, the CLSID suffices (provided the component has been + * registered, of course.)) It is a bit tiresome to have play + * by the .NET COM Interop's rules as regards argument arrays, + * so we may want to revisit this issue at some point. + * + * [ But why not simply use MC++ and provide C-callable entry + * points to the relevant functionality, and avoid COM interop + * alltogether? Because we have to be able to (statically) + * link with gcc-compiled code, and linking MC++ and gcc-compiled + * object files doesn't work.] + * + * Note: you need something never than gcc-2.95 to compile this + * code (I'm using gcc-3.2, which comes with mingw-2). + */ +#define _WIN32_DCOM +#define COBJMACROS +#include <stdio.h> +#include <stdlib.h> +#include <wtypes.h> +#ifndef _MSC_VER +#include <oaidl.h> +#include <objbase.h> +#include <oleauto.h> +# if defined(COBJMACROS) && !defined(_MSC_VER) +#define IErrorInfo_QueryInterface(T,r,O) (T)->lpVtbl->QueryInterface(T,r,O) +#define IErrorInfo_AddRef(T) (T)->lpVtbl->AddRef(T) +#define IErrorInfo_Release(T) (T)->lpVtbl->Release(T) +#define IErrorInfo_GetSource(T,pbstr) (T)->lpVtbl->GetSource(T,pbstr) +#define IErrorInfo_GetDescription(T,pbstr) (T)->lpVtbl->GetDescription(T,pbstr) + +#define ISupportErrorInfo_QueryInterface(T,r,O) (T)->lpVtbl->QueryInterface(T,r,O) +#define ISupportErrorInfo_AddRef(T) (T)->lpVtbl->AddRef(T) +#define ISupportErrorInfo_Release(T) (T)->lpVtbl->Release(T) +#define ISupportErrorInfo_InterfaceSupportsErrorInfo(T,iid) (T)->lpVtbl->InterfaceSupportsErrorInfo(T,iid) +# endif +#endif +#include "DNInvoke.h" +#define WANT_UUID_DECLS +#include "InvokerClient.h" +#include "Dotnet.h" + +/* Local prototypes */ +static void genError( IUnknown* pUnk, + HRESULT hr, + char* loc, + char** pErrMsg); +static int startBridge(char**); +static int fromVariant + ( DotnetType resTy, + VARIANT* pVar, + void* res, + char** pErrMsg); +static VARIANT* toVariant ( DotnetArg* p ); + +/* Pointer to .NET COM component instance; instantiated on demand. */ +static InvokeBridge* pBridge = NULL; + +/* convert a char* to a BSTR, copied from the HDirect comlib/ sources */ +static +HRESULT +stringToBSTR( /*[in,ptr]*/const char* pstrz + , /*[out]*/ BSTR* pbstr + ) +{ + int i; + + if (!pbstr) { + return E_FAIL; + } else { + *pbstr = NULL; + } + if (!pstrz) { + return S_OK; + } + + i = MultiByteToWideChar(CP_ACP, 0, pstrz, -1, NULL, 0); + if ( i < 0 ) { + return E_FAIL; + } + *pbstr = SysAllocStringLen(NULL,i-1); + if (*pbstr != NULL) { + MultiByteToWideChar(CP_ACP, 0, pstrz, -1, *pbstr, i-1); + // (*pbstr)[i]=0; + return S_OK; + } else { + return E_FAIL; + } +} + +static +char* +bstrToString( BSTR bstr ) +{ + int i,len; + char *res; + int blen; + + if (!bstr) { + return NULL; + } + + blen = SysStringLen(bstr); + + /* pass in NULL for the multi-byte arg in order to compute length first */ + len = WideCharToMultiByte(CP_ACP, 0, bstr, blen, + NULL, 0, NULL, NULL); + if (len == 0) return NULL; + + /* Allocate string of required length. */ + res = (char*)malloc(sizeof(char) * (len + 1)); + if (!res) return NULL; + + i = WideCharToMultiByte(CP_ACP, 0, bstr, blen, + res, (len+1), NULL, NULL); + + /* Poor error handling to map this to NULL. */ + if ( i == 0 ) return NULL; + + /* Terminate and return */ + res[i] = '\0'; + return res; +} + +static +void +freeArgs ( SAFEARRAY* psa ) +{ + /* The argument SAFEARRAYs contain dynamically allocated + * VARIANTs. Release the VARIANT contents and its memory here. + */ + long lb,ub; + int i; + HRESULT hr; + VARIANT *pv = NULL; + + hr = SafeArrayGetLBound(psa, 1, &lb); + if (FAILED(hr)) { + fprintf(stderr, "freeArgs: failed fetching lower bound\n"); + SafeArrayDestroy(psa); + return; + } + hr = SafeArrayGetUBound(psa, 1, &ub); + if (FAILED(hr)) { + fprintf(stderr, "freeArgs: failed fetching upper bound\n"); + SafeArrayDestroy(psa); + return; + } + for ( i = 0; i < (ub - lb); i++ ) { + hr = SafeArrayGetElement(psa,(long*)&i,(void*)pv); + if (FAILED(hr)) { + fprintf(stderr, "freeArgs: unable to fetch element %d\n", i); + SafeArrayDestroy(psa); + return; + } + VariantClear(pv); + free(pv); + } + SafeArrayDestroy(psa); +} + +static +SAFEARRAY* +marshalArgs ( DotnetArg* args, + unsigned int n_args ) +{ + SAFEARRAY *psa; + SAFEARRAYBOUND rgsabound[1]; + int i; + long idxArr[1]; + HRESULT hr; + VARIANT* var; + + rgsabound[0].lLbound = 0; + rgsabound[0].cElements = n_args; + psa = SafeArrayCreate(VT_VARIANT, 1, rgsabound); + + for(i=0;i < n_args; i++) { + idxArr[0] = i; + var = toVariant(&args[i]); + hr = SafeArrayPutElement(psa, idxArr, (void*)var); + } + return psa; +} + +/* + * ***** Accessing the .NET object model ***** + * + * General remarks: + * + * - the functions report error conditions via their return value; a char*. + * If NULL, the call was successful. If not, the returned string + * contains the (dynamically allocated) error message. + * + * This unorthodox calling convetion is used to simplify the task + * of interfacing to these funs from GHC-generated code. + */ + +/* + * Function: DN_invokeStatic() + * + * Given assembly and fully-qualified name of a static .NET method, + * invoke it using the supplied arguments. + * + * Returns NULL on success, pointer to error message if an error. + * + */ +char* +DN_invokeStatic ( char *assemName, + char *methName, + DotnetArg *args, + int n_args, + DotnetType resultTy, + void *res) +{ + SAFEARRAY* psa; + VARIANT result; + HRESULT hr; + BSTR b_assemName; + BSTR b_methName; + char* errMsg = NULL; + + if (!pBridge && !startBridge(&errMsg)) { + return errMsg; + } + + /* Package up arguments */ + psa = marshalArgs(args, n_args); + VariantInit(&result); + + hr = stringToBSTR(assemName, &b_assemName); + hr = stringToBSTR(methName, &b_methName); + + hr = InvokeBridge_InvokeStaticMethod(pBridge, + b_assemName, + b_methName, + psa, + &result); + SysFreeString(b_assemName); + SysFreeString(b_methName); + if (FAILED(hr)) { + genError((IUnknown*)pBridge, hr, "DInvoke.invokeStatic", &errMsg); + return errMsg; + } + + fromVariant(resultTy, &result, res, &errMsg); + freeArgs(psa); + + return errMsg; +} + +/* + * Function: DN_invokeMethod() + * + * Given method name and arguments, invoke .NET method on an object. + * The object ref / this-pointer is passed in as the last argument. + * + * Returns NULL on success, pointer to error message if an error. + * + */ +char* +DN_invokeMethod ( char *clsAndMethName, + DotnetArg *args, + int n_args, + DotnetType resultTy, + void *res) +{ + SAFEARRAY* psa; + VARIANT result; + HRESULT hr; + char* methName; + BSTR b_methName; + char* errMsg = NULL; + VARIANT *thisPtr; + + if (!pBridge && !startBridge(&errMsg)) { + return errMsg; + } + + if (n_args <= 0) { + genError(NULL, 0x0, "Invoke.invokeMethod - missing this pointer", &errMsg); + return errMsg; + } + + /* The this-pointer is last */ + thisPtr = toVariant(&args[n_args-1]); + + /* Package up arguments */ + psa = marshalArgs(args, n_args-1); + VariantInit(&result); + + /* If the user has qualified method with class, ignore the class bit. */ + if ( (methName = strrchr(clsAndMethName, '.')) == NULL) { + methName = clsAndMethName; + } else { + /* Skip past '.' */ + methName++; + } + + hr = stringToBSTR(methName, &b_methName); + hr = InvokeBridge_InvokeMethod(pBridge, + *thisPtr, + b_methName, + psa, + &result); + SysFreeString(b_methName); + if (FAILED(hr)) { + genError((IUnknown*)pBridge, hr, "Invoke.invokeMethod", &errMsg); + return errMsg; + } + + fromVariant(resultTy, &result, res, &errMsg); + freeArgs(psa); + + return errMsg; +} + +/* + * Function: DN_getField() + * + * Given a field name and an object pointer, read a field value. + * The object ref / this-pointer is passed in as the last argument. + * + * Returns NULL on success, pointer to error message if an error. + * + */ +char* +DN_getField ( char *clsAndMethName, + DotnetArg *args, + int n_args, + DotnetType resultTy, + void *res) +{ + VARIANT result; + HRESULT hr; + char* methName; + BSTR b_methName; + char* errMsg = NULL; + VARIANT *thisPtr; + + if (!pBridge && !startBridge(&errMsg)) { + return errMsg; + } + + if (n_args <= 0) { + genError(NULL, 0x0, "Invoke.getField - missing this pointer", &errMsg); + return errMsg; + } + + /* The this-pointer is last */ + thisPtr = toVariant(&args[n_args-1]); + VariantInit(&result); + + /* If the user has qualified method with class, ignore the class bit. */ + if ( (methName = strrchr(clsAndMethName, '.')) == NULL) { + methName = clsAndMethName; + } else { + /* Skip past '.' */ + methName++; + } + + hr = stringToBSTR(methName, &b_methName); + hr = InvokeBridge_GetField(pBridge, + *thisPtr, + b_methName, + &result); + SysFreeString(b_methName); + if (FAILED(hr)) { + genError((IUnknown*)pBridge, hr, "Invoke.getField", &errMsg); + return errMsg; + } + + fromVariant(resultTy, &result, res, &errMsg); + return errMsg; +} + +/* + * Function: DN_setField() + * + * Given field name, a value and an object reference, set the field value of + * an object. + * The object ref / this-pointer is passed in as the last argument. + * + * Returns NULL on success, pointer to error message if an error. + * + */ +char* +DN_setField ( char *clsAndMethName, + DotnetArg *args, + int n_args, + /* next two args are ignored */ + DotnetType resultTy, + void *res) +{ + HRESULT hr; + char* methName; + BSTR b_methName; + char* errMsg = NULL; + VARIANT *thisPtr; + VARIANT *pVal; + + if (!pBridge && !startBridge(&errMsg)) { + return errMsg; + } + + if (n_args != 2) { + genError(NULL, 0x0, "Invoke.setField - missing this pointer", &errMsg); + return errMsg; + } + + /* The this-pointer is last */ + thisPtr = toVariant(&args[1]); + + /* Package up arguments */ + pVal = toVariant(&args[0]); + + /* If the user has qualified method with class, ignore the class bit. */ + if ( (methName = strrchr(clsAndMethName, '.')) == NULL) { + methName = clsAndMethName; + } else { + /* Skip past '.' */ + methName++; + } + + hr = stringToBSTR(methName, &b_methName); + hr = InvokeBridge_SetField(pBridge, + *thisPtr, + b_methName, + *pVal); + SysFreeString(b_methName); + VariantClear(pVal); + free(pVal); + free(thisPtr); + + if (FAILED(hr)) { + genError((IUnknown*)pBridge, hr, "Invoke.setField", &errMsg); + return errMsg; + } + return errMsg; +} + + +/* + * Function: DN_createObject() + * + * Given assembly and fully-qualified name of a type, + * invoke its (possibly parameterised) constructor. + * + * Returns NULL on success, pointer to error message if an error. + * + */ +char* +DN_createObject ( char *assemName, + char *methName, + DotnetArg *args, + int n_args, + DotnetType resultTy, + void *res) +{ + SAFEARRAY* psa; + VARIANT result; + HRESULT hr; + BSTR b_assemName; + BSTR b_methName; + char* errMsg = NULL; + + if (!pBridge && !startBridge(&errMsg)) { + return errMsg; + } + + /* Package up arguments */ + psa = marshalArgs(args, n_args); + VariantInit(&result); + + hr = stringToBSTR(assemName, &b_assemName); + hr = stringToBSTR(methName, &b_methName); + + hr = InvokeBridge_CreateObject(pBridge, + b_assemName, + b_methName, + psa, + &result); + SysFreeString(b_assemName); + SysFreeString(b_methName); + if (FAILED(hr)) { + genError((IUnknown*)pBridge, hr, "DN_createObject", &errMsg); + return errMsg; + } + + fromVariant(resultTy, &result, res, &errMsg); + freeArgs(psa); + + return errMsg; +} + +/* + * Function: DN_getStatic() + * + * Given assembly and fully-qualified field name, fetch value of static + * field. + * + * Returns NULL on success, pointer to error message if an error. + * + */ +char* +DN_getStatic ( char *assemName, + char *fieldClsName, + /* the next two args are ignored */ + DotnetArg *args, + int n_args, + DotnetType resultTy, + void *res) +{ + VARIANT result; + HRESULT hr; + BSTR b_assemName; + BSTR b_clsName; + BSTR b_fieldName; + char* errMsg = NULL; + char* fieldName; + char* clsName = fieldName; + + if (!pBridge && !startBridge(&errMsg)) { + return errMsg; + } + + fieldName = (char*)malloc(sizeof(char) * (strlen(fieldClsName) + 1)); + strcpy(fieldName, fieldClsName); + clsName = fieldName; + + if (( fieldName = strrchr(fieldName, '.')) == NULL ) { + genError((IUnknown*)pBridge, 0x0, "Invoke.getStatic - malformed field spec", &errMsg); + return errMsg; + } + *fieldName = '\0'; + fieldName++; + + VariantInit(&result); + + hr = stringToBSTR(assemName, &b_assemName); + hr = stringToBSTR(fieldName, &b_fieldName); + hr = stringToBSTR(clsName, &b_clsName); + /* ToDo: honour assembly spec */ + hr = InvokeBridge_GetStaticField(pBridge, + b_clsName, + b_fieldName, + &result); + SysFreeString(b_assemName); + SysFreeString(b_clsName); + SysFreeString(b_fieldName); + if (FAILED(hr)) { + genError((IUnknown*)pBridge, hr, "Invoke.getStatic", &errMsg); + return errMsg; + } + fromVariant(resultTy, &result, res, &errMsg); + + return errMsg; +} + +/* + * Function: DN_setStatic() + * + * Given assembly and fully-qualified field name, set value of static + * field. + * + * Returns NULL on success, pointer to error message if an error. + * + */ +char* +DN_setStatic ( char *assemName, + char *fieldClsName, + DotnetArg *args, + int n_args, + /* the next two args are ignored */ + DotnetType resultTy, + void *res) +{ + VARIANT result; + VARIANT *pVal; + HRESULT hr; + BSTR b_assemName; + BSTR b_clsName; + BSTR b_fieldName; + char* errMsg = NULL; + char* fieldName; + char* clsName = fieldName; + + if (!pBridge && !startBridge(&errMsg)) { + return errMsg; + } + + fieldName = (char*)malloc(sizeof(char) * (strlen(fieldClsName) + 1)); + strcpy(fieldName, fieldClsName); + clsName = fieldName; + + if (( fieldName = strrchr(fieldName, '.')) == NULL ) { + genError((IUnknown*)pBridge, 0x0, "Invoke.setStatic - malformed field spec", &errMsg); + return errMsg; + } + *fieldName = '\0'; + fieldName++; + + pVal = toVariant(&args[0]); + VariantInit(&result); + + hr = stringToBSTR(assemName, &b_assemName); + hr = stringToBSTR(fieldName, &b_fieldName); + hr = stringToBSTR(clsName, &b_clsName); + /* ToDo: honour assembly spec */ + hr = InvokeBridge_SetStaticField(pBridge, + b_clsName, + b_fieldName, + *pVal); + SysFreeString(b_assemName); + SysFreeString(b_clsName); + SysFreeString(b_fieldName); + VariantClear(pVal); + free(pVal); + if (FAILED(hr)) { + genError((IUnknown*)pBridge, hr, "Invoke.setStatic", &errMsg); + return errMsg; + } + fromVariant(resultTy, &result, res, &errMsg); + + return errMsg; +} + + + + +/* + * Function: startBridge(pErrMsg) + * + * Instantiates an InvokeBridge component, which is then + * used to interact with the .NET world. + * + * If the component isn't available locally, zero is returned. + * Otherwise, 1. + */ +static +int +startBridge(char** pErrMsg) +{ + HRESULT hr; + IUnknown *pUnk; + + hr = CoInitializeEx(NULL, COINIT_APARTMENTTHREADED); + if (FAILED(hr)) { + genError(NULL, hr, "DInvoke.createBridge.CoInitializeEx", pErrMsg); + return FALSE; + } + + hr = CoCreateInstance( &CLSID_InvokeBridge, + NULL, + CLSCTX_INPROC_SERVER, + &IID_IUnknown, + (void**)&pUnk); + if (FAILED(hr)) { + genError(NULL, hr, "DInvoke.createBridge.CoCreateInstance", pErrMsg); + return 0; + } + + hr = IUnknown_QueryInterface(pUnk, &IID_InvokeBridge, (void**)&pBridge); + IUnknown_Release(pUnk); + if (FAILED(hr)) { + genError(pUnk, hr, "DInvoke.createBridge.QueryInterface.InvokeBridge", pErrMsg); + return 0; + } + + return 1; +} + +/* + * Function: stopBridge() + * + * Releases the InvokeBridge object and closes the COM library. + * + */ +void +stopDotnetBridge() +{ + if (pBridge) { + InvokeBridge_Release(pBridge); + pBridge = NULL; + CoUninitialize(); + } + /* Match up the call to CoInitializeEx() in startBridge(). */ +} + +/* + * Function: genError() + * + * Construct a string describing an error condition given + * an HRESULT and a location. + * + * If an interface pointer is passed in via the first arg, + * attempts are made to get at richer error information through + * the IErrorInfo interface. (Note: we don't currently look for + * the _Exception interface for even more detailed info.) + * + */ +#define LOCATION_HDR "Location: " +#define HRESULT_HDR "HRESULT: " +#define SOURCE_HDR "Source: " +#define DESCR_HDR "Description: " +#define NEWLINE_EXTRA 3 + +static +void +genError(IUnknown* pUnk, + HRESULT err, + char* loc, + char** pErrMsg) +{ + HRESULT hr; + HRESULT invoke_hr = err; + char* invoke_src = NULL; + char* invoke_descr = NULL; + char* buf; + int bufLen; + + /* If an interface pointer has been supplied, look for + * IErrorInfo in order to get more detailed information + * on the failure. + * + * The CLR's .NET COM Interop implementation does provide + * IErrorInfo, so we're not really clutching at straws here.. + * + * Note: CLR also reflects .NET exceptions via the _Exception* + * interface.. + * + */ + if (pUnk) { + ISupportErrorInfo *pSupp; + IErrorInfo *pErrInfo; + BSTR src = NULL; + BSTR descr = NULL; + + hr = IUnknown_QueryInterface(pUnk, + &IID_ISupportErrorInfo, + (void**)&pSupp); + if ( SUCCEEDED(hr) ) { + hr = ISupportErrorInfo_InterfaceSupportsErrorInfo(pSupp, + &IID_InvokeBridge); + if ( SUCCEEDED(hr) ) { + hr = GetErrorInfo(0,&pErrInfo); + if ( SUCCEEDED(hr) ) { + IErrorInfo_GetSource(pErrInfo,&src); + IErrorInfo_GetDescription(pErrInfo,&descr); + invoke_src = bstrToString(src); + invoke_descr = bstrToString(descr); + + IErrorInfo_Release(pErrInfo); + if (src) { SysFreeString(src); src = NULL; } + if (descr) { SysFreeString(descr); descr = NULL; } + } + ISupportErrorInfo_Release(pSupp); + } + } + } + /* Putting it all together.. */ + bufLen = sizeof(LOCATION_HDR) + strlen(loc) + NEWLINE_EXTRA + + sizeof(HRESULT_HDR) + 16 + NEWLINE_EXTRA + + sizeof(SOURCE_HDR) + (invoke_src ? strlen(invoke_src) : 16) + NEWLINE_EXTRA + + sizeof(DESCR_HDR) + (invoke_descr ? strlen(invoke_descr) : 16) + NEWLINE_EXTRA; + buf = (char*) malloc(sizeof(char) * (bufLen + 1)); + if (!buf) { + fprintf(stderr, "Unable to allocate %d for error message", (bufLen + 1)); + *pErrMsg = NULL; + return; + } + + _snprintf(buf, bufLen, "%s%s\n%s0x%08x\n%s%s\n%s%s", + LOCATION_HDR, loc, + HRESULT_HDR, invoke_hr, + SOURCE_HDR, invoke_src, + DESCR_HDR, invoke_descr); + + /* Done with these chaps */ + if (invoke_src) free(invoke_src); + if (invoke_descr) free(invoke_descr); + + if (pErrMsg) *pErrMsg = buf; + fprintf(stderr, "**InvokeBridge Error:\n%s", buf); fflush(stderr); +} + +/* Converting to/from VARIANTs */ + +/* + * Function: fromVariant() + * + * Unmarshal the contents of a VARIANT, converting its embedded value + * into the desired DotnetType (if possible.) + * + * Returns 1 if successful, 0 otherwise. If the conversion fails, + * *pErrMsg holds the error message string. + */ +static +int +fromVariant (DotnetType resTy, + VARIANT* pVar, + void* res, + char** pErrMsg) +{ + VARIANT vNew; + HRESULT hr; + + VariantInit(&vNew); + switch(resTy) { + case Dotnet_Byte: + case Dotnet_Char: + hr = VariantChangeType (&vNew, pVar, 0, VT_UI1); + if (FAILED(hr)) { + genError(NULL, hr, "DInvoke.fromVariant{VT_UI1}", pErrMsg); + return FALSE; + } + *((unsigned char*)res) = vNew.bVal; + return 1; + case Dotnet_Boolean: + hr = VariantChangeType (&vNew, pVar, 0, VT_BOOL); + if (FAILED(hr)) { + genError(NULL, hr, "DInvoke.fromVariant{VT_BOOL}", pErrMsg); + return 0; + } + *((unsigned char*)res) = vNew.bVal; + return 1; + case Dotnet_Int: + hr = VariantChangeType (&vNew, pVar, 0, VT_INT); + if (FAILED(hr)) { + genError(NULL, hr, "DInvoke.fromVariant{VT_INT}", pErrMsg); + return 0; + } + *((int*)res) = vNew.intVal; + return 1; + case Dotnet_Int8: + hr = VariantChangeType (&vNew, pVar, 0, VT_I1); + if (FAILED(hr)) { + genError(NULL, hr, "DInvoke.fromVariant{VT_I1}", pErrMsg); + return 0; + } + *((signed char*)res) = vNew.bVal; + return 1; + case Dotnet_Int16: + hr = VariantChangeType (&vNew, pVar, 0, VT_I2); + if (FAILED(hr)) { + genError(NULL, hr, "DInvoke.fromVariant{VT_I2}", pErrMsg); + return 0; + } + *((signed short*)res) = vNew.iVal; + return 1; + case Dotnet_Int32: + hr = VariantChangeType (&vNew, pVar, 0, VT_I4); + if (FAILED(hr)) { + genError(NULL, hr, "DInvoke.fromVariant{VT_I4}", pErrMsg); + return 0; + } + *((signed int*)res) = vNew.lVal; + return 1; + case Dotnet_Int64: + hr = VariantChangeType (&vNew, pVar, 0, VT_I8); + if (FAILED(hr)) { + genError(NULL, hr, "DInvoke.fromVariant{VT_I8}", pErrMsg); + return 0; + } +#ifdef _MSC_VER + *((__int64*)res) = vNew.llVal; +#else + *((long long*)res) = vNew.lVal; +#endif + return 1; + case Dotnet_Float: + hr = VariantChangeType (&vNew, pVar, 0, VT_R4); + if (FAILED(hr)) { + genError(NULL, hr, "DInvoke.fromVariant{VT_R4}", pErrMsg); + return 0; + } + *((float*)res) = vNew.fltVal; + return 1; + case Dotnet_Double: + hr = VariantChangeType (&vNew, pVar, 0, VT_R8); + if (FAILED(hr)) { + genError(NULL, hr, "DInvoke.fromVariant{VT_R4}", pErrMsg); + return 0; + } + *((double*)res) = vNew.dblVal; + return 1; + case Dotnet_Word8: + hr = VariantChangeType (&vNew, pVar, 0, VT_UI1); + if (FAILED(hr)) { + genError(NULL, hr, "DInvoke.fromVariant{VT_UI1}", pErrMsg); + return 0; + } + *((unsigned char*)res) = vNew.bVal; + return 1; + case Dotnet_Word16: + hr = VariantChangeType (&vNew, pVar, 0, VT_UI2); + if (FAILED(hr)) { + genError(NULL, hr, "DInvoke.fromVariant{VT_UI2}", pErrMsg); + return 0; + } + *((unsigned short*)res) = vNew.uiVal; + return 1; + case Dotnet_Word32: + hr = VariantChangeType (&vNew, pVar, 0, VT_UI4); + if (FAILED(hr)) { + genError(NULL, hr, "DInvoke.fromVariant{VT_UI4}", pErrMsg); + return 0; + } + *((unsigned int*)res) = vNew.ulVal; + return 1; + case Dotnet_Word64: + hr = VariantChangeType (&vNew, pVar, 0, VT_UI8); + if (FAILED(hr)) { + genError(NULL, hr, "DInvoke.fromVariant{VT_UI8}", pErrMsg); + return 0; + } +#ifdef _MSC_VER + *((unsigned __int64*)res) = vNew.ullVal; +#else + *((unsigned long long*)res) = vNew.lVal; +#endif + return 1; + case Dotnet_Ptr: + hr = VariantChangeType (&vNew, pVar, 0, VT_BYREF); + if (FAILED(hr)) { + genError(NULL, hr, "DInvoke.fromVariant{VT_BYREF}", pErrMsg); + return 0; + } + *((void**)res) = vNew.byref; + return 1; + case Dotnet_Unit: + return 0; + case Dotnet_Object: + if ( pVar->vt == VT_BSTR ) { + /* Special handling for strings. If the user has asked for + * the string in object form, give him/her that. + */ + VARIANT res; + + VariantInit(&res); + hr = InvokeBridge_NewString(pBridge, + pVar->bstrVal, + &res); + if (SUCCEEDED(hr)) { + pVar = &res; + } + } + hr = VariantChangeType (&vNew, pVar, 0, VT_UNKNOWN); + if (FAILED(hr)) { + genError(NULL, hr, "DInvoke.fromVariant{VT_UNKNOWN}", pErrMsg); + return 0; + } + *((IUnknown**)res) = vNew.punkVal; + return 1; + case Dotnet_String: + hr = VariantChangeType (&vNew, pVar, 0, VT_BSTR); + if (FAILED(hr)) { + genError(NULL, hr, "DInvoke.fromVariant{VT_BSTR}", pErrMsg); + return 0; + } + /* Storage is allocated by malloc(), caller is resp for freeing. */ + *((char**)res) = bstrToString(vNew.bstrVal); + return 1; + } + return 0; +} + +/* + * Function: toVariant() + * + * Convert a DotnetArg into a VARIANT. The VARIANT + * is dynamically allocated. + * + * The result is the pointer to the filled-in VARIANT structure; + * NULL if allocation failed. + * + */ +static +VARIANT* +toVariant ( DotnetArg* p ) +{ + VARIANT* v = (VARIANT*)malloc(sizeof(VARIANT)); + if (!v) return NULL; + VariantInit(v); + switch (p->arg_type) { + case Dotnet_Byte: + v->vt = VT_UI1; + v->bVal = p->arg.arg_byte; + break; + case Dotnet_Char: + v->vt = VT_UI1; + v->bVal = p->arg.arg_char; + break; + case Dotnet_Boolean: + v->vt = VT_BOOL; + v->boolVal = p->arg.arg_bool; + break; + case Dotnet_Int: + v->vt = VT_INT; + v->intVal = p->arg.arg_int; + break; + case Dotnet_Int8: + v->vt = VT_I1; + v->bVal = p->arg.arg_int8; + break; + case Dotnet_Int16: + v->vt = VT_I2; + v->iVal = p->arg.arg_int16; + break; + case Dotnet_Int32: + v->vt = VT_I4; + v->lVal = p->arg.arg_int32; + break; + case Dotnet_Int64: + v->vt = VT_I8; +#ifdef _MSC_VER + v->llVal = p->arg.arg_int64; +#else + (long long*)(v->lVal) = p->arg.arg_int64; +#endif + break; + case Dotnet_Float: + v->vt = VT_R4; + v->fltVal = p->arg.arg_float; + break; + case Dotnet_Double: + v->vt = VT_R8; + v->dblVal = p->arg.arg_double; + break; + case Dotnet_Word8: + v->vt = VT_UI1; + v->bVal = p->arg.arg_word8; + break; + case Dotnet_Word16: + v->vt = VT_UI2; + v->uiVal = p->arg.arg_word16; + break; + case Dotnet_Word32: + v->vt = VT_UI4; + v->ulVal = p->arg.arg_word32; + break; + case Dotnet_Word64: + v->vt = VT_UI8; +#ifdef _MSC_VER + v->ullVal = p->arg.arg_word64; +#else + (unsigned long long*)(v->lVal) = p->arg.arg_word64; +#endif + break; + case Dotnet_Ptr: + v->vt = VT_BYREF; + v->byref = p->arg.arg_ptr; + break; + case Dotnet_Unit: + v->vt = VT_EMPTY; + break; + case Dotnet_Object: + v->vt = VT_UNKNOWN; + v->punkVal = (IUnknown*)p->arg.arg_obj; + break; + case Dotnet_String: { + BSTR b; + HRESULT hr; + v->vt = VT_BSTR; + hr = stringToBSTR((const char*)p->arg.arg_str,&b); + v->bstrVal = b; + break; } + } + return v; +} diff --git a/ghc/rts/dotnet/Invoker.cpp b/ghc/rts/dotnet/Invoker.cpp new file mode 100644 index 0000000000..d8ad87212d --- /dev/null +++ b/ghc/rts/dotnet/Invoker.cpp @@ -0,0 +1,338 @@ +// +// (c) 2002-2003, sof. +// +// Dynamic invocation helper classes. The details of how +// to access the .NET object model via the Reflection API +// is taken care of by Invoker.{h,cpp} +// +#include "Invoker.h" + +namespace DynInvoke { + +static TypeName* ParseType(String* str) { + int curPos = 0; + int endPos; + + // Console::WriteLine("x{0}y", str); + TypeName* typeName = new TypeName(); + + if ( str->get_Chars(0) == '[' ) { + endPos = str->IndexOf(']'); + curPos = endPos + 1; + typeName->m_assembly = str->Substring(1,endPos-1); + typeName->m_length = endPos+1; + } + String* delimStr = " ,()"; + Char delims __gc [] = delimStr->ToCharArray(); + + endPos = str->IndexOfAny(delims,curPos); + // Console::WriteLine("{0} {1} x{2}x", __box(endPos), __box(curPos), str); + if ( endPos == -1 ) { + typeName->m_class = str->Substring(curPos); + } else { + typeName->m_class = str->Substring(curPos,endPos-curPos); + } + + // typeName->m_class = str->Substring(curPos,endPos-curPos); + typeName->m_length += endPos-curPos; + + return typeName; +} + +// Method: GetType(String* typeName); +// +// Purpose: Assembly-savvy version of Type::GetType() +// +Type* InvokeBridge::GetType(String* typeName) { + + try { + Type* t = Type::GetType(typeName); + if (t) return t; + } catch (Exception*) { + ; + } + + for (int i=0;i < InvokeBridge::m_assemblies->Count; i++) { + try { + String* stuff = String::Format("{0},{1}",typeName,InvokeBridge::m_assemblies->get_Item(i)->ToString()); + // Console::WriteLine(stuff); + Type* t = Type::GetType(stuff); + if (t) { + return t; + } + } catch (Exception*) { + continue; + } + } + return 0; +} + +// +// Method: CreateInstance(String* typeName, Object* []) +// +// Purpose: Assembly-savvy invocation of Activator::CreateInstance +Object* InvokeBridge::CreateInstance(TypeName* typeName, + Object* args[]) { + + Object* instance = 0; + Type* t = InvokeBridge::GetType(typeName->toStdString()); + + // Console::WriteLine("x{0} y{1}", typeName->toStdString(), t); + if (!t) { + try { + Assembly* localA = Assembly::LoadFrom(typeName->m_assembly); + t = localA->GetType(typeName->m_class); + } catch (Exception* e) { + ; + } + } + + if (!t) { + try { + AppDomain* currentDomain = AppDomain::CurrentDomain; + + // Assembly* stuff[] = currentDomain->GetAssemblies(); + // for (int i=0;i < stuff.Length; i++) { + // Console::WriteLine("x{0} y{1}", stuff[i]->ToString(), stuff[i]->FullName); + // } + // Console::WriteLine("x{0} y{1}", typeName->toStdString(), t); + Assembly* localA = Assembly::LoadWithPartialName("HugsAssembly"); + t = localA->GetType(typeName->m_class); + // Console::WriteLine("x{0} y{1}", typeName->toStdString(), t); + } catch (Exception*) { + ; + } + } + + if (t) { + try { + Object* o =Activator::CreateInstance(t,(Object* [])args); + return o; + } catch (Exception* e) { + Console::WriteLine("Failure: {0}", e); + return 0; + } + } +} + +// +// Method: CreateObject(String* objSpec, Object* args[]) +// +// Purpose: Given a fully qualified name of a class/type, try +// to create an instance of it. +// +Object* InvokeBridge::CreateObject(String* assemName, + String* objSpec, + Object* args[]) { + + Object* instance = 0; + + // Unravel the name of the class/type. + TypeName* typeName = ParseType(objSpec); + + if (assemName != 0 && assemName->Length > 0) { + typeName->m_assembly = assemName; + } + + // Try creating the instance.. + try { + instance = InvokeBridge::CreateInstance(typeName,(Object* [])args); + } catch (Exception* e) { + Console::WriteLine("Unable to create instance \"{0}\" {1}", objSpec, e); + throw(e); + } + if (!instance) { + Console::WriteLine("Unable to create instance \"{0}\"", objSpec); + } + return instance; +} + +// +// Method: InvokeMethod +// +// Purpose: Given a pointer to an already created object, look up +// one of its method. If found, invoke the method passing it +// 'args' as arguments. +// +Object* +InvokeBridge::InvokeMethod(Object* obj, + String* methName, + Object* args[]) { + // Get the methods from the type + MethodInfo* methods __gc[] = obj->GetType()->GetMethods(); + MethodInfo* mInfo; + + if (!methods) { + Console::WriteLine("InvokeMethod: No matching types found"); + return 0; + } + + System::Reflection::BindingFlags flgs + = (System::Reflection::BindingFlags) // why do I need to cast? + (System::Reflection::BindingFlags::Public | + System::Reflection::BindingFlags::NonPublic | + System::Reflection::BindingFlags::Instance | + System::Reflection::BindingFlags::Static | + System::Reflection::BindingFlags::InvokeMethod); + + /* Caller is assumed to catch any exceptions raised. */ + return obj->GetType()->InvokeMember(methName, + flgs, + 0, + obj, + (Object __gc* [])args); +} + +// +// Method: InvokeStaticMethod +// +// Purpose: Invoke a static method, given the fully qualified name +// of the method (and its arguments). If found, invoke the +// method passing it 'args' as arguments. +// +Object* InvokeBridge::InvokeStaticMethod(String* assemName, + String* typeAndMethName, + Object* args[]) { + + // Get the methods from the type + MethodInfo* methods __gc[]; + MethodInfo* mInfo; + + int lastDot = typeAndMethName->LastIndexOf('.'); + String* className = typeAndMethName->Substring(0,lastDot); + String* methName = typeAndMethName->Substring(lastDot+1); + + // Unravel the name of the class/type. + TypeName* typeName = ParseType(className); + Type* t; + + if (assemName != 0 && assemName->Length > 0) { + typeName->m_assembly = assemName; + } + + try { + t = InvokeBridge::GetType(typeName->toStdString()); + + if (!t) { + try { + Assembly* localA = Assembly::LoadFrom(typeName->m_assembly); + t = localA->GetType(typeName->m_class); + // Console::WriteLine("InvokeStaticMethod: Type {0} found", t); + } catch (Exception* e) { + ; + } + } + + if (t) { + methods = t->GetMethods(); + } else { + Console::WriteLine("InvokeStaticMethod: Type {0} not found", className); + return 0; + } + } catch (Exception *e) { + Console::WriteLine("InvokeStaticMethod: Type {0} not found", className); + throw(e); + } + + System::Reflection::BindingFlags flgs + = (System::Reflection::BindingFlags) // why do I need to cast? + (System::Reflection::BindingFlags::DeclaredOnly | + System::Reflection::BindingFlags::Public | + System::Reflection::BindingFlags::NonPublic | + System::Reflection::BindingFlags::Static | + System::Reflection::BindingFlags::InvokeMethod); + + return t->InvokeMember(methName, + flgs, + 0, + 0, + (Object __gc* [])args); +} + +// +// Method: GetField +// +// Purpose: Fetch the (boxed) value of named field of a given object. +// +Object* InvokeBridge::GetField(Object* obj, System::String* fieldName) { + + FieldInfo* fInfo = obj->GetType()->GetField(fieldName); + return fInfo->GetValue(obj); +} + +// +// Method: GetStaticField +// +// Purpose: Fetch the (boxed) value of named static field. +// +Object* InvokeBridge::GetStaticField(System::String* clsName, + System::String* fieldName) { + + Type* ty = InvokeBridge::GetType(clsName); + System::Reflection::BindingFlags static_field_flgs + = (System::Reflection::BindingFlags) + (System::Reflection::BindingFlags::Public | + System::Reflection::BindingFlags::NonPublic | + System::Reflection::BindingFlags::FlattenHierarchy | + System::Reflection::BindingFlags::Static); + + FieldInfo* fInfo = ty->GetField(fieldName, static_field_flgs); + return fInfo->GetValue(0); // according to doc, ok to pass any val here. +} + +// +// Method: SetField +// +// Purpose: Replace the (boxed) value of named field of a given object. +// +void InvokeBridge::SetField(Object* obj, System::String* fieldName, Object* val) { + + FieldInfo* fInfo = obj->GetType()->GetField(fieldName); + fInfo->SetValue(obj,val); + return; +} + +// +// Method: SetStaticField +// +// Purpose: Replace the (boxed) value of named static field. +// +void InvokeBridge::SetStaticField(System::String* clsName, + System::String* fieldName, + Object* val) { + + Type* ty = InvokeBridge::GetType(clsName); + System::Reflection::BindingFlags static_field_flgs + = (System::Reflection::BindingFlags) + (System::Reflection::BindingFlags::Public | + System::Reflection::BindingFlags::NonPublic | + System::Reflection::BindingFlags::FlattenHierarchy | + System::Reflection::BindingFlags::Static); + + FieldInfo* fInfo = ty->GetField(fieldName,static_field_flgs); + fInfo->SetValue(0,val); + return; +} + +Object* InvokeBridge::NewString(System::String* s) +{ + System::String* c = System::String::Copy(s); + return dynamic_cast<Object*>(c); +} + +Array* InvokeBridge::NewArgArray(int sz) +{ + return Array::CreateInstance(__typeof(Object), sz); +} + +void InvokeBridge::SetArg(Object* arr[], Object* val, int idx) +{ + arr->SetValue(val,idx); +} + +Object* InvokeBridge::GetArg(Object* arr[], int idx) +{ + return arr->GetValue(idx); +} + +} /* namespace */ diff --git a/ghc/rts/dotnet/Invoker.h b/ghc/rts/dotnet/Invoker.h new file mode 100644 index 0000000000..d649a4c716 --- /dev/null +++ b/ghc/rts/dotnet/Invoker.h @@ -0,0 +1,197 @@ +// +// (c) 2003, sof. +// +// Dynamic invocation helper classes. The details of how +// to access the .NET object model via the Reflection API +// is taken care of by Invoker.{h,cpp} +// +#pragma once +#using <mscorlib.dll> + +using namespace System; +using namespace System::Reflection; +using namespace System::Text; +using namespace System::Runtime::InteropServices; + +[assembly:AssemblyKeyFileAttribute(S"invoker.snk")]; + +namespace DynInvoke { + +// +// Class: TypeName +// +// Purpose: pairing up an assembly name and the type/class name. +// +[ComVisible(false)] +public __gc class TypeName { + +public: + System::String* m_assembly; + System::String* m_class; + int m_length; + + TypeName() { + m_assembly = String::Empty; + m_class = String::Empty; + m_length = 0; + } + + void Print() { + if (m_assembly && m_assembly != String::Empty ) { + Console::Write("["); + Console::Write(m_assembly); + Console::Write("]"); + } + Console::WriteLine(m_class); + } + + int Length() { return m_length; } + + System::String* toStdString() { + System::String* res = new System::String(m_class->ToCharArray()); + + if (m_assembly && m_assembly != String::Empty ){ + res = String::Concat(res, S","); + res = String::Concat(res, m_assembly); + } + return res; + } +}; + +// +// Class: InvokeBridge +// +// Purpose: Collection of (static) methods for dynamically creating +// objects and accessing methods/fields on them. +// +[ClassInterface(ClassInterfaceType::AutoDual), +GuidAttribute("39D497D9-60E0-3525-B7F2-7BC096D3A2A3"), +ComVisible(true) +] +public __gc class InvokeBridge { +public: + InvokeBridge() { + Assembly* corAss = Assembly::Load("mscorlib.dll"); + System::String* dir = System::IO::Path::GetDirectoryName(corAss->Location); + + m_assemblies = new System::Collections::ArrayList(); + + System::String* fs[] = System::IO::Directory::GetFiles(dir, "*.dll"); + for (int i=0;i < fs->Length; i++) { + try { + Assembly* tAss = Assembly::LoadFrom(fs[i]); + m_assemblies->Add(tAss->FullName); + } catch (Exception* e) { + continue; + } + } + } + + // + // Method: CreateObject(String* assemName, String* objSpec, Object* args[]) + // + // Purpose: Given a fully qualified name of a class/type, try + // to create an instance of it. + // + Object* CreateObject(System::String* assemName, + System::String* objSpec, + Object* args[]); + + // + // Method: InvokeMethod + // + // Purpose: Given a pointer to an already created object, look up + // one of its method. If found, invoke the method passing it + // 'args' as arguments. + // + // Comments: the format of the method-spec is "methodName(type1,..,typeN)" [N>=0] + // + Object* InvokeMethod(Object* obj, + System::String* methSpec, + Object* args[]); + + // + // Method: InvokeStaticMethod + // + // Purpose: Invoke a static method, given the fully qualified name + // of the method (and its arguments). If found, invoke the + // method passing it 'args' as arguments. + // + // Comments: the format of the method-spec is + // "T1.T2.<..>.Tn.methodName(type1,..,typeN)" [N>=0] + // + Object* InvokeStaticMethod(System::String* assemName, + System::String* methSpec, + Object* args[]); + + // + // Method: GetField + // + // Purpose: Fetch the (boxed) value of named field of a given object. + // + Object* GetField(Object* obj, System::String* fieldSpec); + + // + // Method: GetField + // + // Purpose: Fetch the (boxed) value of named static field. + // + Object* GetStaticField(System::String* clsName, + System::String* fieldSpec); + + // + // Method: SetField + // + // Purpose: Replace the (boxed) value of named field of a given object. + // + void SetField(Object* obj, System::String* fieldSpec, Object* val); + + // + // Method: SetStaticField + // + // Purpose: Replace the (boxed) value of named field of a given object. + // + void SetStaticField(System::String* clsName, + System::String* fieldSpec, + Object* val); + + + // + // Method: NewString + // + // Purpose: construct a System.String object copy in a manner that avoids + // COM Interop from deconstructing it to a BSTR. + // + System::Object* NewString( System::String* s); + + // + // Method: NewArgArray + // + // Purpose: create a new array for holding (boxed) arguments to constructors/ + // methods. + // + Array* NewArgArray(int sz); + + // + // Method: SetArg + // + // Purpose: set an entry in the argument vector. + // + void SetArg(Object* arr[], Object* val, int idx); + + // + // Method: GetArg + // + // Purpose: get an entry in the argument vector. + // + Object* GetArg(Object* arr[], int idx); + + System::Type* InvokeBridge::GetType(System::String* typeName); + +protected: + System::Collections::ArrayList __gc* m_assemblies; + Object* InvokeBridge::CreateInstance(TypeName* typeName, + Object* args[]); +}; + +} /* namespace */ diff --git a/ghc/rts/dotnet/InvokerClient.h b/ghc/rts/dotnet/InvokerClient.h new file mode 100644 index 0000000000..122f455c01 --- /dev/null +++ b/ghc/rts/dotnet/InvokerClient.h @@ -0,0 +1,180 @@ +/* + * InvokerClient interface defns for use with gcc. + * + * Note: These declarations mirror those of the InvokeBridge + * class declaration. + * + */ + +#include <windows.h> +#include <wtypes.h> +#include <oaidl.h> + +#ifdef __cplusplus +extern "C"{ +#endif + +#ifndef STDCALL +#define STDCALL __stdcall +#endif + +extern const CLSID CLSID_InvokeBridge; +extern const IID IID_IUnknown; +extern const IID IID_NULL; +extern const IID IID_InvokeBridge; + +#ifdef WANT_UUID_DECLS +const CLSID CLSID_InvokeBridge = { 0x39D497D9,0x60E0,0x3525,{0xB7,0xF2,0x7B,0xC0,0x96,0xD3,0xA2,0xA3}}; +//const IID IID_NULL = {0x00000000L, 0x0000, 0x0000, {0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}}; +//const IID IID_IUnknown = {0x00000000L, 0x0000, 0x0000, {0xC0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x46}}; +const IID IID_InvokeBridge = { 0xAFF5FFCA, 0xC5C2, 0x3D5B, {0xAF, 0xD5, 0xED, 0x8E, 0x4B, 0x38, 0xDB, 0x7B}}; + //0x3A85D703, 0xFAE4,0x3C5E, {0x9F,0x7E,0x20,0x98,0x31,0xCD,0x61,0x7A}}; +#endif + +#ifndef __InvokeBridge_INTERFACE_DEFINED__ +#define __InvokeBridge_INTERFACE_DEFINED__ +#undef INTERFACE +#define INTERFACE InvokeBridge +DECLARE_INTERFACE(InvokeBridge) +{ + STDMETHOD(QueryInterface)(THIS_ REFIID,PVOID*) PURE; + STDMETHOD_(ULONG,AddRef)(THIS) PURE; + STDMETHOD_(ULONG,Release)(THIS) PURE; + STDMETHOD(GetTypeInfoCount)(THIS_ UINT*) PURE; + STDMETHOD(GetTypeInfo)(THIS_ UINT,LCID,LPTYPEINFO*) PURE; + STDMETHOD(GetIDsOfNames)(THIS_ REFIID,LPOLESTR*,UINT,LCID,DISPID*) PURE; + STDMETHOD(Invoke)(THIS_ DISPID,REFIID,LCID,WORD,DISPPARAMS*,VARIANT*,EXCEPINFO*,UINT*) PURE; + + STDMETHOD(ToString)(THIS_ BSTR*) PURE; + STDMETHOD(Equals)(THIS_ BSTR*) PURE; + STDMETHOD(GetHashCode)(THIS_ long*) PURE; + STDMETHOD(GetType)(THIS_ IUnknown**); + STDMETHOD(CreateObject)(THIS_ BSTR,BSTR,SAFEARRAY*, VARIANT*) PURE; + STDMETHOD(InvokeMethod)(THIS_ VARIANT,BSTR,SAFEARRAY*,VARIANT*) PURE; + STDMETHOD(InvokeStaticMethod)(THIS_ BSTR,BSTR,SAFEARRAY*,VARIANT*) PURE; + + HRESULT ( STDCALL *GetField )( + InvokeBridge * This, + /* [in] */ VARIANT obj, + /* [in] */ BSTR fieldSpec, + /* [retval][out] */ VARIANT *pRetVal); + + HRESULT ( STDCALL *GetStaticField )( + InvokeBridge * This, + /* [in] */ BSTR clsName, + /* [in] */ BSTR fieldSpec, + /* [retval][out] */ VARIANT *pRetVal); + + HRESULT ( STDCALL *SetField )( + InvokeBridge * This, + /* [in] */ VARIANT obj, + /* [in] */ BSTR fieldSpec, + /* [in] */ VARIANT val); + + HRESULT ( STDCALL *SetStaticField )( + InvokeBridge * This, + /* [in] */ BSTR clsName, + /* [in] */ BSTR fieldSpec, + /* [in] */ VARIANT val); + + HRESULT ( STDCALL *NewString )( + InvokeBridge * This, + /* [in] */ BSTR s, + /* [retval][out] */VARIANT* pRetVal); + + HRESULT ( STDCALL *NewArgArray )( + InvokeBridge * This, + /* [in] */ long sz, + /* [retval][out] */IUnknown **pRetVal); + + HRESULT ( STDCALL *SetArg )( + InvokeBridge * This, + /* [in] */ SAFEARRAY * arr, + /* [in] */ VARIANT val, + /* [in] */ long idx); + + HRESULT ( STDCALL *GetArg )( + InvokeBridge * This, + /* [in] */ SAFEARRAY * arr, + /* [in] */ long idx, + /* [retval][out] */ VARIANT *pRetVal); + + HRESULT ( STDCALL *GetType_2 )( + InvokeBridge * This, + /* [in] */ BSTR typeName, + /* [retval][out] */ IUnknown **pRetVal); +}; +#endif + +#define InvokeBridge_QueryInterface(This,riid,ppvObject) \ + (This)->lpVtbl->QueryInterface(This,riid,ppvObject) + +#define InvokeBridge_AddRef(This) \ + (This)->lpVtbl->AddRef(This) + +#define InvokeBridge_Release(This) \ + (This)->lpVtbl->Release(This) + +#define InvokeBridge_GetTypeInfoCount(This,pctinfo) \ + (This)->lpVtbl->GetTypeInfoCount(This,pctinfo) + +#define InvokeBridge_GetTypeInfo(This,iTInfo,lcid,ppTInfo) \ + (This)->lpVtbl->GetTypeInfo(This,iTInfo,lcid,ppTInfo) + +#define InvokeBridge_GetIDsOfNames(This,riid,rgszNames,cNames,lcid,rgDispId) \ + (This)->lpVtbl->GetIDsOfNames(This,riid,rgszNames,cNames,lcid,rgDispId) + +#define InvokeBridge_Invoke(This,dispIdMember,riid,lcid,wFlags,pDispParams,pVarResult,pExcepInfo,puArgErr) \ + (This)->lpVtbl->Invoke(This,dispIdMember,riid,lcid,wFlags,pDispParams,pVarResult,pExcepInfo,puArgErr) + +#define InvokeBridge_get_ToString(This,pRetVal) \ + (This)->lpVtbl->get_ToString(This,pRetVal) + +#define InvokeBridge_Equals(This,obj,pRetVal) \ + (This)->lpVtbl->Equals(This,obj,pRetVal) + +#define InvokeBridge_GetHashCode(This,pRetVal) \ + (This)->lpVtbl->GetHashCode(This,pRetVal) + +#define InvokeBridge_GetType(This,pRetVal) \ + (This)->lpVtbl->GetType(This,pRetVal) + +#define InvokeBridge_CreateObject(This,assemName,objSpec,args,pRetVal) \ + (This)->lpVtbl->CreateObject(This,assemName,objSpec,args,pRetVal) + +#define InvokeBridge_InvokeMethod(This,obj,methSpec,args,pRetVal) \ + (This)->lpVtbl->InvokeMethod(This,obj,methSpec,args,pRetVal) + +#define InvokeBridge_InvokeStaticMethod(This,assemName,methSpec,args,pRetVal) \ + (This)->lpVtbl->InvokeStaticMethod(This,assemName,methSpec,args,pRetVal) + +#define InvokeBridge_GetField(This,obj,fieldSpec,pRetVal) \ + (This)->lpVtbl->GetField(This,obj,fieldSpec,pRetVal) + +#define InvokeBridge_GetStaticField(This,clsName,fieldSpec,pRetVal) \ + (This)->lpVtbl->GetStaticField(This,clsName,fieldSpec,pRetVal) + +#define InvokeBridge_SetField(This,obj,fieldSpec,val) \ + (This)->lpVtbl->SetField(This,obj,fieldSpec,val) + +#define InvokeBridge_SetStaticField(This,clsName,fieldSpec,val) \ + (This)->lpVtbl->SetStaticField(This,clsName,fieldSpec,val) + +#define InvokeBridge_NewString(This,s,pRetVal) \ + (This)->lpVtbl->NewString(This,s,pRetVal) + +#define InvokeBridge_NewArgArray(This,sz,pRetVal) \ + (This)->lpVtbl->NewArgArray(This,sz,pRetVal) + +#define InvokeBridge_SetArg(This,arr,val,idx) \ + (This)->lpVtbl->SetArg(This,arr,val,idx) + +#define InvokeBridge_GetArg(This,arr,idx,pRetVal) \ + (This)->lpVtbl->GetArg(This,arr,idx,pRetVal) + +#define InvokeBridge_GetType_2(This,typeName,pRetVal) \ + (This)->lpVtbl->GetType_2(This,typeName,pRetVal) + +#ifdef __cplusplus +} +#endif diff --git a/ghc/rts/dotnet/Makefile b/ghc/rts/dotnet/Makefile new file mode 100644 index 0000000000..95b6c38890 --- /dev/null +++ b/ghc/rts/dotnet/Makefile @@ -0,0 +1,53 @@ +# +# .NET interop for GHC. +# +# (c) 2003, sof. +# +TOP=../.. +include $(TOP)/mk/boilerplate.mk + +all :: Invoker.dll Invoke.o + +# +# To compile the dotnet interop bits, you need to have the +# .NET Framework SDK or VS.NET installed. The following +# apps are used: +# +MCPP=cl +TLBEXP=tlbexp +REGASM=regasm +GACUTIL=gacutil + +Invoker.dll : Invoker.obj + $(MCPP) /LD /clr /o Invoker.dll Invoker.obj + $(TLBEXP) Invoker.dll + $(REGASM) Invoker.dll + $(GACUTIL) /i Invoker.dll + +Invoker.obj : Invoker.cpp Invoker.h + $(MCPP) /LD /clr /c Invoker.cpp + +CLEAN_FILES += $(wildcard *.obj *.dll *.tlb) + +# ToDo: +# - switch to /ir (i.e., copy it into the GAC.) +# - sort out installation story. + +# drop the assembly +remove : + $(GACUTIL) /u Invoker + +# +# NOTE: For DotnetCc a version of gcc later than gcc-2.95 is +# required (I'm using the gcc-3.2 snapshot that comes with mingw-2) +# +ifeq "$(DotnetCc)" "" +DotnetCc=$(CC) +endif +DotnetCcOpts=$(CC_OPTS) $(DOTNET_EXTRA_CC_OPTS) +SRC_CC_OPTS += -I$(TOP)/includes + +Invoke.o : Invoke.c + $(DotnetCc) $(DotnetCcOpts) -c $< -o $@ + +include $(TOP)/mk/target.mk diff --git a/ghc/rts/dotnet/invoker.snk b/ghc/rts/dotnet/invoker.snk Binary files differnew file mode 100644 index 0000000000..05a222178a --- /dev/null +++ b/ghc/rts/dotnet/invoker.snk diff --git a/ghc/rts/package.conf.in b/ghc/rts/package.conf.in index 298fbc286b..3a31625529 100644 --- a/ghc/rts/package.conf.in +++ b/ghc/rts/package.conf.in @@ -32,6 +32,9 @@ Package { #ifdef mingw32_TARGET_OS ,"wsock32" /* for the linker */ #endif +#ifdef WANT_DOTNET_SUPPORT + , "oleaut32", "ole32", "uuid" +#endif #if defined(DEBUG) && defined(HAVE_LIBBFD) ,"bfd", "iberty" /* for debugging */ #endif diff --git a/mk/config.h.in b/mk/config.h.in index b3beb40384..91e53740bd 100644 --- a/mk/config.h.in +++ b/mk/config.h.in @@ -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: diff --git a/mk/config.mk.in b/mk/config.mk.in index 91344c12cd..6bfc6282ad 100644 --- a/mk/config.mk.in +++ b/mk/config.mk.in @@ -353,6 +353,12 @@ GL_LIBS=@GL_LIBS@ X_CFLAGS=@X_CFLAGS@ X_LIBS=@X_LIBS@ + +# +# .NET interop support? +# +DotnetSupport=@DotnetSupport@ + ################################################################################ # # happy project |