diff --git a/clr-host.cabal b/clr-host.cabal --- a/clr-host.cabal +++ b/clr-host.cabal @@ -1,16 +1,16 @@ name: clr-host -version: 0.1.0.0 +version: 0.2.0 synopsis: Hosting the Common Language Runtime description: clr-host is a library that provides the ability to host (also known as embed) the common language runtime within the current Haskell process. Generally you'll only interface directly to this library to start the CLR, and the other code here is for higher level abstractions to use. homepage: https://gitlab.com/tim-m89/clr-haskell/tree/master/libs/clr-host -bug-reports: https://gitlab.com/tim-m89/clr-haskell/issues +bug-reports: https://gitlab.com/tim-m89/clr-haskell/issues license: BSD3 license-file: LICENSE author: Tim Matthews -maintainer: tim.matthews7@gmail.com +maintainer: pepeiborra@gmail.com copyright: 2016-2017 Tim Matthews category: Language, FFI, CLR, .NET build-type: Custom @@ -20,7 +20,7 @@ source-repository head type: git - location: https://gitlab.com/tim-m89/clr-haskell/tree/master + location: https://gitlab.com/tim-m89/clr-haskell/tree/master/libs/clr-host flag enable_dotnet description: build with .Net support @@ -42,10 +42,19 @@ exposed-modules: Clr.Host , Clr.Host.Config , Clr.Host.BStr + , Clr.Host.Box + , Clr.Host.Delegate + , Clr.Host.DriverEntryPoints + , Clr.Host.GCHandle + , Clr.Host.Method other-modules: Clr.Host.Driver , Clr.Host.BStr.Type -- Common build deps - build-depends: base >= 4.7 && < 5, bytestring, file-embed + build-depends: base >= 4.7 && < 5 + , bytestring + , text + , file-embed + , clr-marshal -- Windows extra build deps if os(windows) build-depends: Win32 @@ -96,6 +105,3 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 -source-repository head - type: git - location: https://gitlab.com/tim-m89/clr-host diff --git a/src/Clr/Host.hs b/src/Clr/Host.hs --- a/src/Clr/Host.hs +++ b/src/Clr/Host.hs @@ -1,7 +1,9 @@ -{-# LANGUAGE CPP, RankNTypes #-} +{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} module Clr.Host where +import Clr.Marshal + import Clr.Host.Config #ifdef HAVE_MONO import Clr.Host.Mono @@ -10,15 +12,14 @@ import Clr.Host.DotNet #endif -import Foreign.Ptr +import Clr.Host.BStr +import Clr.Host.DriverEntryPoints + +import Data.Coerce import Data.Word +import Foreign.Ptr -type GetPtrToMethod a = Ptr Word16 -> IO (FunPtr a) -type GetPtrToMethodFunPtr a = FunPtr (GetPtrToMethod a) -foreign import ccall "clrHost.c getPointerToMethod_set" getPtrToMethod_set :: GetPtrToMethodFunPtr a -> IO () -foreign import ccall "clrHost.c getPointerToMethod_get" getPtrToMethod_get :: IO (GetPtrToMethodFunPtr a) - startClr :: IO () startClr = do ClrHostConfig hostType <- getClrHostConfig @@ -40,4 +41,8 @@ stopClr :: IO () stopClr = putStrLn "stopClr" + + + + diff --git a/src/Clr/Host/BStr.hs b/src/Clr/Host/BStr.hs --- a/src/Clr/Host/BStr.hs +++ b/src/Clr/Host/BStr.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, BangPatterns, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses #-} module Clr.Host.BStr ( BStr(..) @@ -8,6 +8,10 @@ ) where import Control.Exception (bracket) +import Data.Coerce +import Data.Word +import Foreign.Ptr +import Foreign.Storable import Clr.Host.Config import Clr.Host.BStr.Type @@ -20,9 +24,11 @@ import Clr.Host.BStr.DotNet(sysAllocStringLen, sysFreeString) #endif -import Data.Word -import Foreign.Ptr +import Clr.Marshal +import Data.Text +import Data.Text.Foreign + allocBStr :: (Integral len) => Ptr Word16 -> len -> IO BStr allocBStr p l = do ClrHostConfig hostType <- getClrHostConfig @@ -57,4 +63,55 @@ withBStr :: (Integral len) => Ptr Word16 -> len -> (BStr-> IO a) -> IO a withBStr p l = bracket (allocBStr p l) freeBStr +bstrToPtrData :: BStr -> Ptr Word16 +bstrToPtrData = coerce + +bstrToPtrLen :: BStr -> Ptr Word16 +bstrToPtrLen bstr = plusPtr (bstrToPtrData bstr) (-4) + +bstrLenBytes :: BStr -> IO Word16 +bstrLenBytes = peek . bstrToPtrLen + +bstrLenChars :: BStr -> IO Word16 +bstrLenChars bstr = do + let charSize = 2 + lenBytes <- bstrLenBytes bstr + return $ lenBytes `div` charSize + +bstrToText :: BStr -> IO Text +bstrToText bstr = do + let ptrData = bstrToPtrData bstr + lenChars <- bstrLenChars bstr + fromPtr ptrData $ fromIntegral lenChars + +instance {-# OVERLAPPING #-} Marshal Text BStr where + marshal x f = do + bstr <- useAsPtr x (\p-> \l-> allocBStr p l) + !res <- f bstr + freeBStr bstr + return res + +instance {-# OVERLAPPING #-} Marshal String BStr where + marshal x f = marshal (pack x) f + +instance {-# OVERLAPPING #-} Marshal BStr Text where + marshal x f = bstrToText x >>= f + +instance {-# OVERLAPPING #-} Marshal BStr String where + marshal x f = marshal x $ \t-> f (unpack t) + +instance {-# OVERLAPPING #-} Unmarshal BStr Text where + unmarshal x = do + !t <- bstrToText x + freeBStr x + return t + +instance {-# OVERLAPPING #-} Unmarshal BStr String where + unmarshal x = unpack <$> unmarshal x + +instance {-# OVERLAPPING #-} Unmarshal Text BStr where + unmarshal x = useAsPtr x (\p-> \l-> allocBStr p l) + +instance {-# OVERLAPPING #-} Unmarshal String BStr where + unmarshal x = unmarshal $ pack x diff --git a/src/Clr/Host/Box.hs b/src/Clr/Host/Box.hs new file mode 100644 --- /dev/null +++ b/src/Clr/Host/Box.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE TypeApplications, TypeSynonymInstances, MultiParamTypeClasses, FlexibleInstances #-} + +module Clr.Host.Box where + +import Clr.Marshal + +import Clr.Host.BStr +import Clr.Host.GCHandle +import Clr.Host.DriverEntryPoints + +import Data.Int +import Data.Text +import Data.Text.Foreign +import Data.Word +import Foreign.Marshal.Alloc +import Foreign.Ptr +import Foreign.Storable + + +-- | @'getBoxStub' t@ returns a function pointer to a function that, when +-- called, returns a boxed object reference to the given type. +getBoxStub :: String -> IO (FunPtr f) +getBoxStub typeName = marshal typeName $ \typeName'-> do + stub <- getBoxStubRaw + return $ stub typeName' + +getBoxStubRaw :: IO (GetBoxStubDelegate a) +getBoxStubRaw = unsafeGetPointerToMethod "GetBoxStub" >>= return . makeGetBoxStubDelegate + +type GetBoxStubDelegate a = BStr -> FunPtr a +foreign import ccall "dynamic" makeGetBoxStubDelegate :: FunPtr (GetBoxStubDelegate a) -> GetBoxStubDelegate a + +-- +-- Text +-- + +instance Marshal Text (GCHandle obj) where + marshal x f = marshal @Text @BStr x $ \ptr-> do + stub <- boxStringStub + obj <- stub ptr + f obj + +type BoxStringStub a = BStr -> IO (GCHandle a) +foreign import ccall "dynamic" makeBoxStringStub :: FunPtr (BoxStringStub a) -> (BoxStringStub a) + +boxStringStub :: IO (BoxStringStub a) +boxStringStub = getBoxStub "System.String" >>= return . makeBoxStringStub + +-- +-- String +-- + +instance Marshal String (GCHandle a) where + marshal x f = marshal (pack x) f + +-- +-- Int8 +-- + +instance Marshal Int8 (GCHandle obj) where + marshal x f = boxInt8Stub >>= \stub-> stub x >>= f + +type BoxInt8Stub a = Int8 -> IO (GCHandle a) +foreign import ccall "dynamic" makeBoxInt8Stub :: FunPtr (BoxInt8Stub a) -> (BoxInt8Stub a) + +boxInt8Stub :: IO (BoxInt8Stub a) +boxInt8Stub = getBoxStub "System.SByte" >>= return . makeBoxInt8Stub + +-- +-- Word8 +-- + +instance Marshal Word8 (GCHandle obj) where + marshal x f = boxWord8Stub >>= \stub-> stub x >>= f + +type BoxWord8Stub a = Word8 -> IO (GCHandle a) +foreign import ccall "dynamic" makeBoxWord8Stub :: FunPtr (BoxWord8Stub a) -> (BoxWord8Stub a) + +boxWord8Stub :: IO (BoxWord8Stub a) +boxWord8Stub = getBoxStub "System.Byte" >>= return . makeBoxWord8Stub + +-- +-- Int16 +-- + +instance Marshal Int16 (GCHandle obj) where + marshal x f = boxInt16Stub >>= \stub-> stub x >>= f + +type BoxInt16Stub a = Int16 -> IO (GCHandle a) +foreign import ccall "dynamic" makeBoxInt16Stub :: FunPtr (BoxInt16Stub a) -> (BoxInt16Stub a) + +boxInt16Stub :: IO (BoxInt16Stub a) +boxInt16Stub = getBoxStub "System.Int16" >>= return . makeBoxInt16Stub + +-- +-- Word16 +-- + +instance Marshal Word16 (GCHandle obj) where + marshal x f = boxWord16Stub >>= \stub-> stub x >>= f + +type BoxWord16Stub a = Word16 -> IO (GCHandle a) +foreign import ccall "dynamic" makeBoxWord16Stub :: FunPtr (BoxWord16Stub a) -> (BoxWord16Stub a) + +boxWord16Stub :: IO (BoxWord16Stub a) +boxWord16Stub = getBoxStub "System.UInt16" >>= return . makeBoxWord16Stub + +-- +-- Int32 +-- + +instance Marshal Int32 (GCHandle obj) where + marshal x f = boxInt32Stub >>= \stub-> stub x >>= f + +type BoxInt32Stub a = Int32 -> IO (GCHandle a) +foreign import ccall "dynamic" makeBoxInt32Stub :: FunPtr (BoxInt32Stub a) -> (BoxInt32Stub a) + +boxInt32Stub :: IO (BoxInt32Stub a) +boxInt32Stub = getBoxStub "System.Int32" >>= return . makeBoxInt32Stub + +-- +-- Word32 +-- + +instance Marshal Word32 (GCHandle obj) where + marshal x f = boxWord32Stub >>= \stub-> stub x >>= f + +type BoxWord32Stub a = Word32 -> IO (GCHandle a) +foreign import ccall "dynamic" makeBoxWord32Stub :: FunPtr (BoxWord32Stub a) -> (BoxWord32Stub a) + +boxWord32Stub :: IO (BoxWord32Stub a) +boxWord32Stub = getBoxStub "System.UInt32" >>= return . makeBoxWord32Stub + +-- +-- Int64 +-- + +instance Marshal Int64 (GCHandle obj) where + marshal x f = boxInt64Stub >>= \stub-> stub x >>= f + +type BoxInt64Stub a = Int64 -> IO (GCHandle a) +foreign import ccall "dynamic" makeBoxInt64Stub :: FunPtr (BoxInt64Stub a) -> (BoxInt64Stub a) + +boxInt64Stub :: IO (BoxInt64Stub a) +boxInt64Stub = getBoxStub "System.Int64" >>= return . makeBoxInt64Stub + +-- +-- Word64 +-- + +instance Marshal Word64 (GCHandle obj) where + marshal x f = boxWord64Stub >>= \stub-> stub x >>= f + +type BoxWord64Stub a = Word64 -> IO (GCHandle a) +foreign import ccall "dynamic" makeBoxWord64Stub :: FunPtr (BoxWord64Stub a) -> (BoxWord64Stub a) + +boxWord64Stub :: IO (BoxWord64Stub a) +boxWord64Stub = getBoxStub "System.UInt64" >>= return . makeBoxWord64Stub + diff --git a/src/Clr/Host/Delegate.hs b/src/Clr/Host/Delegate.hs new file mode 100644 --- /dev/null +++ b/src/Clr/Host/Delegate.hs @@ -0,0 +1,41 @@ + +module Clr.Host.Delegate where + +import Clr.Host.BStr +import Clr.Host.GCHandle +import Clr.Host.DriverEntryPoints + +import Clr.Marshal + +import Data.Kind +import Foreign.Ptr + +-- | @'getDelegateConstructorStub' dt wrapper@ returns an action that, given a +-- function, will return a reference to a .NET delegate object that calls the +-- provided function. The delegate constructed will be of the type @dt@. +-- The function @wrapper@ will be called in order to wrap the given function +-- as a function pointer for passing into .NET. +getDelegateConstructorStub :: String -> (f -> IO (FunPtr f)) -> IO (f -> IO (GCHandle t)) +getDelegateConstructorStub delegateTypeName wrapper = do + -- Obtain a function pointer to a function that, when called with a + -- function pointer compatible with the given wrapper function, returns + -- a reference to a .NET delegate object that calls the function. + delegateConstructor <- marshal delegateTypeName $ + \delegateTypeName' -> getDelegateConstructorStubRaw >>= \x-> x delegateTypeName' + + -- Returns a function that accepts a function, 'f' implementing the + -- delegate, converts 'f' to a function pointer, and then wraps it + -- up as a .NET delegate. + return $ \f -> do + fFunPtr <- wrapper f + (makeDelegateConstructor delegateConstructor) fFunPtr + +getDelegateConstructorStubRaw :: IO (GetDelegateConstructorStubDelegate f t) +getDelegateConstructorStubRaw = unsafeGetPointerToMethod "GetDelegateConstructorStub" >>= return . makeGetDelegateConstructorStubDelegate + +type GetDelegateConstructorStubDelegate f t = BStr -> IO (FunPtr (DelegateConstructor f t)) +foreign import ccall "dynamic" makeGetDelegateConstructorStubDelegate :: FunPtr (GetDelegateConstructorStubDelegate f t) -> (GetDelegateConstructorStubDelegate f t) + +type DelegateConstructor f t = FunPtr f -> IO (GCHandle t) +foreign import ccall "dynamic" makeDelegateConstructor :: FunPtr (DelegateConstructor f t) -> (DelegateConstructor f t) + diff --git a/src/Clr/Host/DotNet.hs b/src/Clr/Host/DotNet.hs --- a/src/Clr/Host/DotNet.hs +++ b/src/Clr/Host/DotNet.hs @@ -37,7 +37,19 @@ foreign import ccall "dotNetHost.c getICLRRuntimeHost" getICLRRuntimeHost :: IO ICLRRuntimeHost foreign import ccall "dotNetHost.c setHostRefs" setHostRefs :: ICorRuntimeHost -> ICLRRuntimeHost -> IO () +#if x86_64_HOST_ARCH +foreign import ccall __unregister_hs_exception_handler :: IO () +unregister_hs_exception_handler = __unregister_hs_exception_handler +#else +-- symbol has extra leading underscore on 32 bit apprently +--foreign import ccall ___unregister_hs_exception_handler :: IO () +--unregister_hs_exception_handler = ___unregister_hs_exception_handler +-- Infact just leave as NO-OP until a 32 bit dev want to investigate the further linker issues +unregister_hs_exception_handler :: IO () +unregister_hs_exception_handler = return () +#endif + -- | 'start_ICorRuntimeHost' calls the Start method of the given ICorRuntimeHost interface. start_ICorRuntimeHost :: ICorRuntimeHost -> IO () start_ICorRuntimeHost corHost = do @@ -64,6 +76,8 @@ startHostDotNet :: IO (FunPtr (Ptr Word16 -> IO (FunPtr a))) startHostDotNet = do + -- Disable the top level VEH. This can interfere with .NET exceptions. + unregister_hs_exception_handler -- Load the 'mscoree' dynamic library into the process. This is the -- 'stub' library for the .NET execution engine, and is used to load an -- appropriate version of the real runtime via a call to diff --git a/src/Clr/Host/DriverEntryPoints.hs b/src/Clr/Host/DriverEntryPoints.hs new file mode 100644 --- /dev/null +++ b/src/Clr/Host/DriverEntryPoints.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Clr.Host.DriverEntryPoints where + +import Clr.Host.BStr +import Clr.Marshal + +import Data.Coerce +import Data.Word +import Foreign.Ptr + +type GetPtrToMethod a = Ptr Word16 -> IO (FunPtr a) +type GetPtrToMethodFunPtr a = FunPtr (GetPtrToMethod a) + +foreign import ccall "clrHost.c getPointerToMethod_set" getPtrToMethod_set :: GetPtrToMethodFunPtr a -> IO () +foreign import ccall "clrHost.c getPointerToMethod_get" getPtrToMethod_get :: IO (GetPtrToMethodFunPtr a) + +-- | @'unsafeGetPointerToMethod' m@ returns a function pointer to the method @m@ +-- as implemented in the Salsa .NET driver assembly (Salsa.dll). It is safe only +-- if the type of the resulting function pointer matches that of the method given. +unsafeGetPointerToMethod :: String -> IO (FunPtr a) +unsafeGetPointerToMethod methodName = do + result <- marshal methodName $ \(methodName'::BStr) -> getPointerToMethodRaw >>= \f-> f $ coerce methodName' + if result == nullFunPtr + then error $ "Unable to execute Salsa.dll method '" ++ methodName ++ "'." + else return result + +getPointerToMethodRaw :: IO (GetPtrToMethod a) +getPointerToMethodRaw = getPtrToMethod_get >>= return . makeGetPtrToMethod + +foreign import ccall "dynamic" makeGetPtrToMethod :: GetPtrToMethodFunPtr a -> GetPtrToMethod a + +-- | 'saveDynamicAssembly' saves the assembly containing the dynamically-generated +-- wrapper stubs to disk (for debugging purposes). +saveDynamicAssembly :: IO () +saveDynamicAssembly = unsafeGetPointerToMethod "SaveDynamicAssembly" >>= makeSaveDynamicAssemblyDelegate + +type SaveDynamicAssemblyDelegate = IO () +foreign import ccall "dynamic" makeSaveDynamicAssemblyDelegate :: FunPtr SaveDynamicAssemblyDelegate -> SaveDynamicAssemblyDelegate + diff --git a/src/Clr/Host/GCHandle.hs b/src/Clr/Host/GCHandle.hs new file mode 100644 --- /dev/null +++ b/src/Clr/Host/GCHandle.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-} +{-# LANGUAGE GADTs, TypeInType #-} + + + +module Clr.Host.GCHandle where + +import Clr.Host.DriverEntryPoints + +import Data.Coerce +import Foreign.Ptr + +newtype GCHandle typ = GCHandle (Ptr Int) + +-- | Releases the .NET object indicated by the given object id. +releaseObject :: GCHandle t -> IO () +releaseObject handle = fmap makeReleaseObjectDelegate gcHandleFinalizer >>= \f-> f $ coerce handle + +type ReleaseObjectDelegate = Ptr Int -> IO () +foreign import ccall "dynamic" makeReleaseObjectDelegate :: FunPtr ReleaseObjectDelegate -> ReleaseObjectDelegate + +gcHandleFinalizer :: IO (FunPtr (Ptr Int -> IO ())) +gcHandleFinalizer = unsafeGetPointerToMethod "ReleaseObject" + +newHandle :: GCHandle t -> IO (GCHandle t) +newHandle x = do + f <- fmap makeNewHandleDelegate (unsafeGetPointerToMethod "NewHandle") + y <- f $ coerce x + return $ coerce y + +type NewHandleDelegate = Ptr Int -> IO (Ptr Int) +foreign import ccall "dynamic" makeNewHandleDelegate :: FunPtr NewHandleDelegate -> NewHandleDelegate + diff --git a/src/Clr/Host/Method.hs b/src/Clr/Host/Method.hs new file mode 100644 --- /dev/null +++ b/src/Clr/Host/Method.hs @@ -0,0 +1,26 @@ + +module Clr.Host.Method where + +import Clr.Marshal +import Clr.Host.BStr +import Clr.Host.DriverEntryPoints +import Foreign.Ptr + +-- | @'getMethodStub' c m s@ returns a function pointer to a function that, when +-- called, invokes the method with name @m@ and signature @s@ in class @c@. +-- +-- @s@ should be a semi-colon delimited list of parameter types indicating the +-- desired overload of the given method. +getMethodStub :: String -> String -> String -> IO (FunPtr f) +getMethodStub className methodName parameterTypeNames = do + marshal className $ \className' -> + marshal methodName $ \methodName' -> + marshal parameterTypeNames $ \parameterTypeNames' -> + getMethodStubRaw >>= \f-> return $ f className' methodName' parameterTypeNames' + +getMethodStubRaw :: IO (GetMethodStubDelegate a) +getMethodStubRaw = unsafeGetPointerToMethod "GetMethodStub" >>= return . makeGetMethodStubDelegate + +type GetMethodStubDelegate a = BStr -> BStr -> BStr -> FunPtr a +foreign import ccall "dynamic" makeGetMethodStubDelegate :: FunPtr (GetMethodStubDelegate a) -> GetMethodStubDelegate a + diff --git a/src/Driver.cs b/src/Driver.cs --- a/src/Driver.cs +++ b/src/Driver.cs @@ -45,9 +45,6 @@ new AssemblyName("DynamicAssembly"), AssemblyBuilderAccess.RunAndSave); _dynamicModuleBuilder = _assemblyBuilder.DefineDynamicModule("DynamicModule", "Dynamic.dll"); _stubsTypeBuilder = _dynamicModuleBuilder.DefineType("Stubs"); - - _inTable.Add(_nextId++, true); // ObjectId 1 - _inTable.Add(_nextId++, false); // ObjectId 2 } public static IntPtr Boot() @@ -132,15 +129,17 @@ if (methodName == ".ctor") { ConstructorInfo con = StringToType(className).GetConstructor( - StringToTypes(parameterTypeNames)); + StringToTypes(parameterTypeNames,';')); return GenerateConstructorStub(con); } else { Type typ = StringToType(className); MethodInfo meth; - if (parameterTypeNames != null) - meth = typ.GetMethod(methodName, StringToTypes(parameterTypeNames)); + if (methodName.Contains("`")) + meth = GetGenericMethod(typ, methodName); + else if (parameterTypeNames != null) + meth = typ.GetMethod(methodName, StringToTypes(parameterTypeNames,';')); else meth = typ.GetMethod(methodName); if(meth == null) { @@ -158,8 +157,13 @@ /// public static IntPtr GetDelegateConstructorStub(string delegateTypeName) { - Type delegateType = StringToType(delegateTypeName); - return GenerateDelegateConstructorStub(delegateType); + try { + Type delegateType = StringToType (delegateTypeName); + return GenerateDelegateConstructorStub (delegateType); + } + catch (Exception innerException) { + throw new ArgumentException ("Not a valid delegate type: " + delegateTypeName, innerException); + } } /// @@ -197,76 +201,51 @@ #region Foreign object references (object in-table) /// - /// Maps object identifiers to .NET references. Allows foreign object identifiers - /// to be dereferenced to .NET object references. Also ensures that .NET objects - /// referred to from Haskell are kept alive. - /// - static Dictionary _inTable = new Dictionary(); - - static long _nextId = 1; - - /// /// Registers the given object in the 'in table' and returns the object id /// that was assigned to it. /// - public static long RegisterObject(object o) + public static IntPtr RegisterObject(object o) { if (o == null) - return 0; + return IntPtr.Zero; - if (o is bool?) // HACK for Nullable - { - bool b = (bool)o; - return b ? 1 : 2; - } + GCHandle handle = GCHandle.Alloc(o); - lock (_inTable) - { - _inTable.Add(_nextId, o); - return _nextId++; - } + return GCHandle.ToIntPtr(handle); + } - public static object GetObject(long oId) + public static object GetObject(IntPtr oId) { - if (oId == 0) // 0 represents a null reference + if (oId == IntPtr.Zero) // 0 represents a null reference return null; - if (oId == 1) // 1 represents boxed true - return true; // TODO: Return pre-boxed instance? - if (oId == 2) // 0 represents boxed false - return false; + GCHandle handle = GCHandle.FromIntPtr(oId); - lock (_inTable) - { - object o; - if (_inTable.TryGetValue(oId, out o)) - return o; - else - { - throw new ArgumentException("No object exists with id: " + oId); - // FIXME: This exception will occur in the current implementation of the - // bridge if a Haskell garbage collection (and finalization) runs - // while a Haskell-implemented delegate is returning an object. - // Given that this condition tends not to occur with the current - // implementation of the GHC RTS, and that most delegates in .NET - // don't return a value at all, I'm leaving the fix for later. - } - } + return handle.Target; } [UnmanagedFunctionPointer(CallingConvention.Cdecl)] - public delegate void ReleaseObjectDelegate(long oId); + public delegate void ReleaseObjectDelegate(IntPtr oId); private static ReleaseObjectDelegate _ReleaseObjectDelegate = ReleaseObject; - public static void ReleaseObject(long oId) + public static void ReleaseObject(IntPtr oId) { - lock (_inTable) - { - _inTable.Remove(oId); - } + if (oId == IntPtr.Zero) // 0 represents a null reference + return; + + GCHandle handle = GCHandle.FromIntPtr(oId); + handle.Free(); + } + public static IntPtr NewHandle(IntPtr oId) + { + Object o = GetObject(oId); + return RegisterObject(o); + } + + #endregion #region Managed delegate references (function pointer in-table) @@ -360,7 +339,7 @@ // Generate a dynamic method that does the following: // - // Int64 [classType]New([args...]) + // IntPtr [classType]New([args...]) // { // [classType] o = new [classType]([args... using GetObject ... ]); // (box o if it is a value type) @@ -369,7 +348,7 @@ // Signature of the stub method returned (as a delegate) by this function DelegateSignature methodSignature = new DelegateSignature( - typeof(Int64), + typeof(IntPtr), con == null ? Type.EmptyTypes : ConvertToStubTypes(Util.MapParametersToTypes(con.GetParameters()))); @@ -473,7 +452,7 @@ // Generate a dynamic method that does the following: // - // Int64 [delegateType]New(IntPtr funPtr) + // IntPtr [delegateType]New(IntPtr funPtr) // { // [wrapperType] wrapper = new [wrapperType](funPtr); // Delegate d = new [delegateType](wrapper.Invoke); @@ -484,7 +463,7 @@ // method accepts an IntPtr to a Haskell function and returns an instantiated // .NET delegate for it) DelegateSignature methodSignature = new DelegateSignature( - typeof(Int64), new Type[] { typeof(IntPtr) }); + typeof(IntPtr), new Type[] { typeof(IntPtr) }); return GenerateDynamicMethod(delegateType.Name + "New", methodSignature, delegate(ILGenerator ilg) @@ -597,7 +576,7 @@ { // Signature of the stub method returned (as a delegate) by this function DelegateSignature methodSignature = new DelegateSignature( - typeof(Int64), new Type[] { ConvertToStubType(typeToBox) }); + typeof(IntPtr), new Type[] { ConvertToStubType(typeToBox) }); return GenerateDynamicMethod("box_" + typeToBox.Name, methodSignature, delegate(ILGenerator ilg) @@ -641,7 +620,7 @@ private static Type ConvertToStubType(Type type) { if (IsMarshaledByIndex(type)) - return typeof(Int64); + return typeof(IntPtr); else return type; } @@ -665,7 +644,7 @@ /// /// /// For example, when called for the 'Button' type, code is emitted to convert an - /// Int64 object identifier into a Button; but when called with the 'String' type + /// IntPtr object identifier into a Button; but when called with the 'String' type /// no code is emitted at all since the stub type matches the desired .NET type /// exactly. /// @@ -760,7 +739,7 @@ private static Type GetDelegateWrapperType(Type delegateType) { - string wrapperTypeName = delegateType.Name + "Wrapper"; + string wrapperTypeName = delegateType.FullName + "Wrapper"; lock (_delegateWrapperTypes) { Type type; @@ -888,6 +867,12 @@ MethodAttributes.Public, delegateSignature.ReturnType, delegateSignature.ParameterTypes); ILGenerator ilg = invokeMethod.GetILGenerator(); + if(IsMarshaledByIndex(delegateSignature.ReturnType)) + { + LocalBuilder lb0 = ilg.DeclareLocal(typeof(IntPtr)); + LocalBuilder lb1 = ilg.DeclareLocal(delegateSignature.ReturnType); + } + // Load _thunkDelegate (for calling it later) ilg.Emit(OpCodes.Ldarg_0); ilg.Emit(OpCodes.Ldfld, thunkDelegateField); @@ -899,8 +884,23 @@ EmitToStub(ilg, delegateSignature.ParameterTypes[i]); } + // Make the call ilg.Emit(OpCodes.Callvirt, thunkDelegateType.GetMethod("Invoke")); - EmitFromStub(ilg, delegateSignature.ReturnType); + + if(IsMarshaledByIndex(delegateSignature.ReturnType)) + { + // Get the actual object from the handle, then release the handle + ilg.Emit(OpCodes.Stloc_0); + ilg.Emit(OpCodes.Ldloc_0); + EmitFromStub(ilg, delegateSignature.ReturnType); + ilg.Emit(OpCodes.Stloc_1); + ilg.Emit(OpCodes.Ldloc_0); + ilg.Emit(OpCodes.Call, MemberInfos.Driver_ReleaseObject); + ilg.Emit(OpCodes.Ldloc_1); + } + else + EmitFromStub(ilg, delegateSignature.ReturnType); + ilg.Emit(OpCodes.Ret); } @@ -1042,6 +1042,29 @@ #endregion + public static RetT RunCatchHandlerRaw(TryDelegate tryDelegate, CatchDelegate catchDelegate) where ExT : System.Exception + { + RetT result; + try + { + result = tryDelegate(); + } + catch(ExT ex) + { + result = catchDelegate(ex); + } + return result; + } + + public static RetT RunCatchHandler(TryDelegate tryDelegate, CatchDelegate catchDelegate) where ExT : System.Exception + { + RetT result = default(RetT); + Thread thread = new Thread(() => result = RunCatchHandlerRaw(tryDelegate, catchDelegate)); + thread.Start(); + thread.Join(); + return result; + } + private static Dictionary LoadedAssemblies = new Dictionary(); /// Helper function to load an assembly from bytes @@ -1061,22 +1084,41 @@ System.Console.WriteLine("About to crash. Attach debugger or press Enter"); System.Console.ReadLine(); System.Diagnostics.Debugger.Break(); - throw new ArgumentException("GetLoadedAssembly: " + assName.FullName, "Known assemblies: " + String.Join(",", LoadedAssemblies.Select(kv => kv.Key))); + throw new ArgumentException("GetLoadedAssembly: " + assName.FullName, + "Known assemblies: " + String.Join(",", LoadedAssemblies.Select(kv => kv.Key)) + "\n"+ + "In GHC 8.2.1 the StaticPointers extension must be enabled in modules with clr inlined blocks and the module exports unrestricted"); } } public static Type StringToType(string s) { Type t = Type.GetType(s); - t = t ?? Type.GetType(s,(assName => GetLoadedAssembly(assName)), ((ass, tn, ci) => ass.GetType(tn,ci)), true); + t = t ?? Type.GetType(s,(assName => GetLoadedAssembly(assName)), ((ass, tn, ci) => ass==null ? null : ass.GetType(tn,ci)), true); + if(t == null) + throw new ArgumentException("Type not in scope: " + s); return t; } - public static Type[] StringToTypes(string s) + public static Type[] StringToTypes(string s, char seperator) { return Util.MapArray(delegate(string t) { return StringToType(t); }, - s.Split(new char[] { ';' }, StringSplitOptions.RemoveEmptyEntries)); + s.Split(new char[] { seperator }, StringSplitOptions.RemoveEmptyEntries)); } + + public static MethodInfo GetGenericMethod(Type typ, string s) + { + int i = s.IndexOf('`'); + string methodName = s.Substring(0, i); + + i = s.IndexOf('[', i); + string genParamsStr = s.Substring(i+1, s.Length -i -2); + Type[] genParams = StringToTypes(genParamsStr, ','); + + MethodInfo method = typ.GetMethod(methodName); + MethodInfo generic = method.MakeGenericMethod(genParams); + + return generic; + } } /// @@ -1090,6 +1132,10 @@ /// public delegate void ILWriterDelegate(ILGenerator ilg); + public delegate RetT TryDelegate(); + + public delegate RetT CatchDelegate(ExT ex); + /// /// Stores references to commonly used reflection object instances. /// @@ -1118,6 +1164,9 @@ public static readonly MethodInfo Driver_RegisterObject = typeof(Driver).GetMethod("RegisterObject", BindingFlags.Static | BindingFlags.Public); + + public static readonly MethodInfo Driver_ReleaseObject = + typeof(Driver).GetMethod("ReleaseObject", BindingFlags.Static | BindingFlags.Public); public static readonly MethodInfo Driver_GetObject = typeof(Driver).GetMethod("GetObject", BindingFlags.Static | BindingFlags.Public);