diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2016-2017, Tim Matthews +Includes code from 'Salsa' Copyright (c) 2007-2008, Andrew Appleyard + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Tim Matthews nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,44 @@ +import Distribution.PackageDescription +import Distribution.Simple +import Distribution.Simple.Configure(configure) +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Setup +import Distribution.Simple.Program +import Distribution.Verbosity as Verbosity + +import Control.Applicative +import Control.Monad.Trans.Maybe +import Data.Maybe +import System.Directory +import System.FilePath + +main = defaultMainWithHooks simpleUserHooks { confHook = configureClrHost + , buildHook = buildClrHost } + +buildClrHost :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO () +buildClrHost pd lbi hooks bflags = do + let verbosity = fromFlagOrDefault Verbosity.normal (buildVerbosity bflags) + let progDb = withPrograms lbi + currentDir <- getCurrentDirectory + let src = currentDir "src" "Driver.cs" + let out = currentDir "src" "Driver.dll" + runDbProgram verbosity csharpCompiler progDb ["-filealign:512", "-optimize+", "-out:" ++ out, "-target:library", src] + buildHook simpleUserHooks pd lbi hooks bflags + +configureClrHost :: (GenericPackageDescription, HookedBuildInfo) -> ConfigFlags -> IO LocalBuildInfo +configureClrHost (gpd,hbi) cf = do + lbi <- confHook simpleUserHooks (gpd, hbi) cf + let verbosity = fromFlagOrDefault Verbosity.normal (configVerbosity (configFlags lbi)) + (cfgdProg, progDb) <- requireProgram verbosity csharpCompiler (withPrograms lbi) + let lbi' = lbi { withPrograms = progDb } :: LocalBuildInfo + return lbi' + +cscFindLocation :: Verbosity -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath])) +cscFindLocation verb path = runMaybeT $ findExec "mcs" + <|> findExec "csc" + <|> findExec "C:\\Windows\\Microsoft.NET\\Framework64\\v4.0.30319\\csc" + where findExec name = MaybeT $ findProgramOnSearchPath verb path name + +csharpCompiler :: Program +csharpCompiler = (simpleProgram "csc") { programFindLocation = cscFindLocation } + diff --git a/clr-host.cabal b/clr-host.cabal new file mode 100644 --- /dev/null +++ b/clr-host.cabal @@ -0,0 +1,101 @@ +name: clr-host +version: 0.1.0.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 +license: BSD3 +license-file: LICENSE +author: Tim Matthews +maintainer: tim.matthews7@gmail.com +copyright: 2016-2017 Tim Matthews +category: Language, FFI, CLR, .NET +build-type: Custom +extra-source-files: src/Driver.cs +extra-tmp-files: src/Driver.dll +cabal-version: >=1.24 + +source-repository head + type: git + location: https://gitlab.com/tim-m89/clr-haskell/tree/master + +flag enable_dotnet + description: build with .Net support + default: False + +flag enable_mono + description: build with mono support + default: False + +-- Deps for running the setup itself (compilation of the C# code). +custom-setup + setup-depends: base, directory, filepath, Cabal, transformers + +library + hs-source-dirs: src + c-sources: src/clrHost.c, src/dotNetHost.c + default-language: Haskell2010 + -- Common modules + exposed-modules: Clr.Host + , Clr.Host.Config + , Clr.Host.BStr + other-modules: Clr.Host.Driver + , Clr.Host.BStr.Type + -- Common build deps + build-depends: base >= 4.7 && < 5, bytestring, file-embed + -- Windows extra build deps + if os(windows) + build-depends: Win32 + -- .Net specific options + if flag(enable_dotnet) + Cpp-options: -DHAVE_DOTNET + cc-options: -DHAVE_DOTNET + other-modules: Clr.Host.BStr.DotNet + , Clr.Host.DotNet + , Clr.Host.DotNet.Common + , Clr.Host.DotNet.Guid + , Clr.Host.DotNet.SafeArray + , Clr.Host.DotNet.Variant + Extra-Libraries: oleaut32, ole32 + -- Mono specific options + if flag(enable_mono) + Cpp-options: -DHAVE_MONO + cc-options: -DHAVE_MONO + other-modules: Clr.Host.BStr.Mono + , Clr.Host.Mono + Extra-Libraries: glib-2.0, mono-2.0 + -- If neither .Net / Mono chosen, default to .Net on Windows and Mono otherwise. + if !flag(enable_dotnet) && !flag(enable_mono) + if os(windows) + Cpp-options: -DHAVE_DOTNET + cc-options: -DHAVE_DOTNET + other-modules: Clr.Host.BStr.DotNet + , Clr.Host.DotNet + , Clr.Host.DotNet.Common + , Clr.Host.DotNet.Guid + , Clr.Host.DotNet.SafeArray + , Clr.Host.DotNet.Variant + Extra-Libraries: oleaut32, ole32 + else + Cpp-options: -DHAVE_MONO + cc-options: -DHAVE_MONO + other-modules: Clr.Host.BStr.Mono + , Clr.Host.Mono + Extra-Libraries: glib-2.0, mono-2.0 + + +test-suite clr-host-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , clr-host + 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 new file mode 100644 --- /dev/null +++ b/src/Clr/Host.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE CPP, RankNTypes #-} + +module Clr.Host where + +import Clr.Host.Config +#ifdef HAVE_MONO +import Clr.Host.Mono +#endif +#ifdef HAVE_DOTNET +import Clr.Host.DotNet +#endif + +import Foreign.Ptr +import Data.Word + +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 + getPtrToMethod <- case hostType of +#ifdef HAVE_MONO + ClrHostMono -> startHostMono +#else + ClrHostMono -> error "not built with Mono support enabled" +#endif +#ifdef HAVE_DOTNET + ClrHostDotNet -> startHostDotNet +#else + ClrHostDotNet -> error "not built with .Net support enabled" +#endif + if getPtrToMethod == nullFunPtr then + error "Failed to boot the driver" + else + getPtrToMethod_set getPtrToMethod + +stopClr :: IO () +stopClr = putStrLn "stopClr" + diff --git a/src/Clr/Host/BStr.hs b/src/Clr/Host/BStr.hs new file mode 100644 --- /dev/null +++ b/src/Clr/Host/BStr.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE CPP #-} + +module Clr.Host.BStr + ( BStr(..) + , allocBStr + , freeBStr + , withBStr + ) where + +import Control.Exception (bracket) + +import Clr.Host.Config +import Clr.Host.BStr.Type + +#ifdef HAVE_MONO +import Clr.Host.BStr.Mono(mono_ptr_to_bstr_hask, mono_free_bstr) +#endif + +#ifdef HAVE_DOTNET +import Clr.Host.BStr.DotNet(sysAllocStringLen, sysFreeString) +#endif + +import Data.Word +import Foreign.Ptr + +allocBStr :: (Integral len) => Ptr Word16 -> len -> IO BStr +allocBStr p l = do + ClrHostConfig hostType <- getClrHostConfig + case hostType of +#ifdef HAVE_MONO + ClrHostMono -> mono_ptr_to_bstr_hask p (fromIntegral l) +#else + ClrHostMono -> error "not built with Mono support enabled" +#endif +#ifdef HAVE_DOTNET + ClrHostDotNet -> sysAllocStringLen p (fromIntegral l) +#else + ClrHostDotNet -> error "not built with .Net support enabled" +#endif + + +freeBStr :: BStr -> IO () +freeBStr x = do + ClrHostConfig hostType <- getClrHostConfig + case hostType of +#ifdef HAVE_MONO + ClrHostMono -> mono_free_bstr x +#else + ClrHostMono -> error "not built with Mono support enabled" +#endif +#ifdef HAVE_DOTNET + ClrHostDotNet -> sysFreeString x +#else + ClrHostDotNet -> error "not built with .Net support enabled" +#endif + +withBStr :: (Integral len) => Ptr Word16 -> len -> (BStr-> IO a) -> IO a +withBStr p l = bracket (allocBStr p l) freeBStr + + diff --git a/src/Clr/Host/BStr/DotNet.hs b/src/Clr/Host/BStr/DotNet.hs new file mode 100644 --- /dev/null +++ b/src/Clr/Host/BStr/DotNet.hs @@ -0,0 +1,23 @@ +module Clr.Host.BStr.DotNet where + +import Clr.Host.BStr.Type +import Control.Exception (bracket) +import Data.Word +import Foreign.C +import Foreign.Ptr + +sysAllocString :: String -> IO BStr +sysAllocString s = withCWString s prim_SysAllocString +foreign import stdcall "oleauto.h SysAllocString" prim_SysAllocString :: CWString -> IO BStr + +sysAllocStringLen :: Ptr Word16 -> CUInt -> IO BStr +sysAllocStringLen s l = prim_SysAllocStringLen (castPtr s) l +foreign import stdcall "oleauto.h SysAllocStringLen" prim_SysAllocStringLen :: CWString -> CUInt -> IO BStr + +sysFreeString :: BStr -> IO () +sysFreeString = prim_SysFreeString +foreign import stdcall "oleauto.h SysFreeString" prim_SysFreeString :: BStr -> IO () + +withBStr :: String -> (BStr -> IO a) -> IO a +withBStr s = bracket (sysAllocString s) (sysFreeString) + diff --git a/src/Clr/Host/BStr/Mono.hs b/src/Clr/Host/BStr/Mono.hs new file mode 100644 --- /dev/null +++ b/src/Clr/Host/BStr/Mono.hs @@ -0,0 +1,32 @@ +module Clr.Host.BStr.Mono where + +import Clr.Host.BStr.Type +import Data.Coerce +import Data.Word +import Foreign.C +import Foreign.Marshal.Utils +import Foreign.Ptr +import Foreign.Storable + +-- +-- This function is not exported so a reimplemention of it is below +-- foreign import ccall mono_ptr_to_bstr :: Ptr Word16 -> CUInt -> IO BStr +-- + +type GSize = CULong + +foreign import ccall g_malloc :: GSize -> IO (Ptr a) + +mono_ptr_to_bstr_hask :: Ptr Word16 -> CUInt -> IO BStr +mono_ptr_to_bstr_hask p l = do + let charSize = 2 + ptrLen <- g_malloc (fromIntegral ((l + 1) * charSize + 4)) :: IO (Ptr Word32) + poke ptrLen (fromIntegral (l * charSize)) + let ptrData = plusPtr ptrLen 4 :: Ptr Word16 + copyBytes ptrData p (fromIntegral (l * charSize)) + let ptrTerm = plusPtr ptrData (fromIntegral (l * charSize)) :: Ptr Word16 + poke ptrTerm 0 + return $ coerce ptrData + +foreign import ccall mono_free_bstr :: BStr -> IO () + diff --git a/src/Clr/Host/BStr/Type.hs b/src/Clr/Host/BStr/Type.hs new file mode 100644 --- /dev/null +++ b/src/Clr/Host/BStr/Type.hs @@ -0,0 +1,7 @@ +module Clr.Host.BStr.Type where + +import Data.Word +import Foreign.Ptr + +newtype BStr = BStr (Ptr Word16) deriving (Show) + diff --git a/src/Clr/Host/Config.hs b/src/Clr/Host/Config.hs new file mode 100644 --- /dev/null +++ b/src/Clr/Host/Config.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE CPP #-} + +module Clr.Host.Config where + +data ClrHostType = ClrHostMono | ClrHostDotNet + +data ClrHostConfig = ClrHostConfig ClrHostType + +#if defined (HAVE_MONO) +defaultHostConfig = ClrHostConfig ClrHostMono +#elif defined (HAVE_DOTNET) +defaultHostConfig = ClrHostConfig ClrHostDotNet +#endif + +getClrHostConfig :: IO ClrHostConfig +getClrHostConfig = return defaultHostConfig + diff --git a/src/Clr/Host/DotNet.hs b/src/Clr/Host/DotNet.hs new file mode 100644 --- /dev/null +++ b/src/Clr/Host/DotNet.hs @@ -0,0 +1,366 @@ +{-# LANGUAGE CPP, LambdaCase #-} + +module Clr.Host.DotNet ( + startHostDotNet, + stopHostDotNet + ) where + +import Data.Word +import Data.Int +import Foreign.Ptr +import Foreign.Marshal +import Foreign.C.String +import Foreign.Storable +import System.Win32 +import System.IO +import Control.Exception (bracket) +import Unsafe.Coerce (unsafeCoerce) +import System.IO.Unsafe (unsafePerformIO) +import qualified Data.ByteString as S +import Text.Printf + +import Clr.Host.BStr.DotNet +import Clr.Host.BStr.Type +import Clr.Host.DotNet.Common +import Clr.Host.DotNet.Guid +import Clr.Host.DotNet.SafeArray +import Clr.Host.DotNet.Variant +import Clr.Host.Driver + +type ICorRuntimeHost = InterfacePtr +type ICLRRuntimeHost = InterfacePtr +type ICLRMetaHost = InterfacePtr +type ICLRRuntimeInfo = InterfacePtr +type IEnumUnknown = InterfacePtr + +foreign import ccall "dotNetHost.c getICorRuntimeHost" getICorRuntimeHost :: IO ICorRuntimeHost +foreign import ccall "dotNetHost.c getICLRRuntimeHost" getICLRRuntimeHost :: IO ICLRRuntimeHost +foreign import ccall "dotNetHost.c setHostRefs" setHostRefs :: ICorRuntimeHost -> ICLRRuntimeHost -> IO () + + +-- | 'start_ICorRuntimeHost' calls the Start method of the given ICorRuntimeHost interface. +start_ICorRuntimeHost :: ICorRuntimeHost -> IO () +start_ICorRuntimeHost corHost = do + -- Initialise COM (and the threading model) + coInitializeEx nullPtr coInit_ApartmentThreaded + -- TODO: Allow the library user to select their desired threading model + -- (we use an STA for the time being so we can use GUI libraries). + f <- getInterfaceFunction 10 makeStartCor corHost + f corHost >>= checkHR "ICorRuntimeHost.Start" + return () + +type Start_ICorRuntimeHost = ICorRuntimeHost -> IO HResult +foreign import stdcall "dynamic" makeStartCor :: FunPtr Start_ICorRuntimeHost -> Start_ICorRuntimeHost + +-- | 'start_ICLRRuntimeHost' calls the Start method of the given ICLRRuntimeHost interface. +start_ICLRRuntimeHost :: ICLRRuntimeHost -> IO () +start_ICLRRuntimeHost clrHost = do + f <- getInterfaceFunction 3 makeStartCLR clrHost + f clrHost >>= checkHR "ICLRRuntimeHost.Start" + return () + +type Start_ICLRRuntimeHost = ICLRRuntimeHost -> IO HResult +foreign import stdcall "dynamic" makeStartCLR :: FunPtr Start_ICLRRuntimeHost -> Start_ICLRRuntimeHost + +startHostDotNet :: IO (FunPtr (Ptr Word16 -> IO (FunPtr a))) +startHostDotNet = do + -- 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 + -- 'CorBindToRuntimeEx'. + hMscoree <- loadLibrary "mscoree.dll" + -- Attempt .Net 4.0 binding by first obtaining a pointer to 'CLRCreateInstance' + -- If this fails, fall back to corBindToRuntimeEx which only allows + -- binding to MS .Net versions < 4.0 + metaHost <- createMetaHost hMscoree + if metaHost == nullPtr then do + corHost <- corBindToRuntimeEx hMscoree + start_ICorRuntimeHost corHost + setHostRefs corHost nullPtr + else getRuntimes_ICLRMetaHost metaHost >>= \case + [] -> error "No runtime versions found" + (runtime:xs) -> do + version <- getVersionString_ICLRRuntimeInfo runtime + --putStrLn $ "attempting to bind to runtime version " ++ version + clrHost <- getCLRHost_ICLRRuntimeInfo runtime + start_ICLRRuntimeHost clrHost + corHost <- getCorHost_ICLRRuntimeInfo runtime + setHostRefs corHost clrHost + corHost <- getICorRuntimeHost + loadDriverAndBoot corHost + +-- | 'stop_ICorRuntimeHost' calls the Stop method of the given ICorRuntimeHost interface. +stop_ICorRuntimeHost :: ICorRuntimeHost -> IO () +stop_ICorRuntimeHost corHost = do + f <- getInterfaceFunction 11 makeStop_ICorRuntimeHost corHost + f corHost >>= checkHR "ICorRuntimeHost.Stop" + return () + +type Stop_ICorRuntimeHost = ICorRuntimeHost -> IO HResult +foreign import stdcall "dynamic" makeStop_ICorRuntimeHost :: FunPtr Stop_ICorRuntimeHost -> Stop_ICorRuntimeHost + +-- | 'stop_ICLRRuntimeHost' calls the Stop method of the given ICLRRuntimeHost interface. +stop_ICLRRuntimeHost :: ICLRRuntimeHost -> IO () +stop_ICLRRuntimeHost clrHost = do + f <- getInterfaceFunction 4 makeStop_ICLRRuntimeHost clrHost + f clrHost >>= checkHR "ICLRRuntimeHost.Stop" + return () + +type Stop_ICLRRuntimeHost = ICLRRuntimeHost -> IO HResult +foreign import stdcall "dynamic" makeStop_ICLRRuntimeHost :: FunPtr Stop_ICLRRuntimeHost -> Stop_ICLRRuntimeHost + +stopHostDotNet :: IO () +stopHostDotNet = do + clrHost <- getICLRRuntimeHost + corHost <- getICorRuntimeHost + if clrHost == nullPtr then + if corHost == nullPtr then + return () + else + stop_ICorRuntimeHost corHost + else + stop_ICLRRuntimeHost clrHost + return () + +clsid_CorRuntimeHost = Guid 0xCB2F6723 0xAB3A 0x11D2 0x9C 0x40 0x00 0xC0 0x4F 0xA3 0x0A 0x3E +iid_ICorRuntimeHost = Guid 0xCB2F6722 0xAB3A 0x11D2 0x9C 0x40 0x00 0xC0 0x4F 0xA3 0x0A 0x3E + +clsid_CLRRuntimeHost = Guid 0x90F1A06E 0x7712 0x4762 0x86 0xB5 0x7A 0x5E 0xBA 0x6B 0xDB 0x02 +iid_ICLRRuntimeHost = Guid 0x90F1A06C 0x7712 0x4762 0x86 0xB5 0x7A 0x5E 0xBA 0x6B 0xDB 0x02 + +-- | 'corBindToRunTimeEx' loads the CLR execution engine into the process and returns +-- a COM interface for it. +corBindToRuntimeEx :: HINSTANCE -> IO ICorRuntimeHost +corBindToRuntimeEx hMscoree = do + -- Obtain a pointer to the 'CorBindToRuntimeEx' function from mscoree.dll + corBindToRuntimeExAddr <- getProcAddress hMscoree "CorBindToRuntimeEx" + let corBindToRuntimeEx = makeCorBindToRuntimeEx $ castPtrToFunPtr corBindToRuntimeExAddr + + -- Request the shim (mscoree.dll) to load a version of the runtime into the + -- process, returning a pointer to an implementation of the ICorRuntimeHost + -- for controlling the runtime. + with (nullPtr :: ICorRuntimeHost) $ \clrHostPtr -> do + -- Call 'corBindToRuntimeEx' to obtain an ICorRuntimeHost + with clsid_CorRuntimeHost $ \refCLSID_CorRuntimeHost -> + with iid_ICorRuntimeHost $ \refIID_ICorRuntimeHost -> + corBindToRuntimeEx nullPtr nullPtr 0 refCLSID_CorRuntimeHost + refIID_ICorRuntimeHost clrHostPtr >>= checkHR "CorBindToRuntimeEx" + peek clrHostPtr + +type CorBindToRuntimeEx = LPCWSTR -> LPCWSTR -> DWORD -> Ptr CLSID -> Ptr IID -> Ptr ICorRuntimeHost -> IO HResult +foreign import stdcall "dynamic" makeCorBindToRuntimeEx :: FunPtr CorBindToRuntimeEx -> CorBindToRuntimeEx + +clrCreateInstance :: HINSTANCE -> CLSID -> IID -> IO InterfacePtr +clrCreateInstance hMscoree clsid iid = do + clrCreateInstanceAddr <- getProcAddress hMscoree "CLRCreateInstance" + if clrCreateInstanceAddr == nullPtr then + return nullPtr + else do + let clrCreateInstanceRaw = makeCLRCreateInstance $ castPtrToFunPtr clrCreateInstanceAddr + with (nullPtr :: InterfacePtr) $ \interfacePtr -> + with clsid $ \refCLSID -> with iid $ \refIID -> do + hr <- clrCreateInstanceRaw refCLSID refIID interfacePtr + if hr == 0 then + peek interfacePtr + else + return nullPtr + +type CLRCreateInstance = Ptr CLSID -> Ptr IID -> Ptr InterfacePtr -> IO HResult +foreign import stdcall "dynamic" makeCLRCreateInstance :: FunPtr CLRCreateInstance -> CLRCreateInstance + +-- | 'createMetaHost' +createMetaHost :: HINSTANCE -> IO ICLRMetaHost +createMetaHost hMscoree = clrCreateInstance hMscoree clsid_CLRMetaHost iid_ICLRMetaHost + where clsid_CLRMetaHost = Guid 0X9280188D 0X0E8E 0X4867 0XB3 0X0C 0X7F 0XA8 0X38 0X84 0XE8 0XDE + iid_ICLRMetaHost = Guid 0XD332DB9E 0XB9B3 0X4125 0X82 0X07 0XA1 0X48 0X84 0XF5 0X32 0X16 + +-- | 'enumInstalledRuntimes_ICLRMetaHost' +enumInstalledRuntimes_ICLRMetaHost :: ICLRMetaHost -> IO IEnumUnknown +enumInstalledRuntimes_ICLRMetaHost this = do + f <- getInterfaceFunction 5 makeEnumInstalledRuntimes_ICLRMetaHost this + with (nullPtr :: IEnumUnknown) $ \enumUnknownPtr -> do + f this enumUnknownPtr >>= checkHR "EnumerateInstalledRuntimes_ICLRMetaHost" + peek enumUnknownPtr + +type EnumInstalledRuntimes_ICLRMetaHost = ICLRMetaHost -> Ptr IEnumUnknown -> IO HResult +foreign import stdcall "dynamic" makeEnumInstalledRuntimes_ICLRMetaHost :: FunPtr EnumInstalledRuntimes_ICLRMetaHost -> EnumInstalledRuntimes_ICLRMetaHost + +-- | 'next_IEnumUnknown' +next_IEnumUnknown :: IEnumUnknown -> IO InterfacePtr +next_IEnumUnknown this = do + f <- getInterfaceFunction 3 makeNext_IEnumUnknown this + with (0 :: Word32) $ \fetched -> + with (nullPtr :: InterfacePtr) $ \interfacePtr -> do + hr <- f this 1 interfacePtr fetched + if hr == 0 then + peek interfacePtr + else + return nullPtr + +type Next_IEnumUnknown = IEnumUnknown -> Word32 -> Ptr InterfacePtr -> Ptr Word32 -> IO HResult +foreign import stdcall "dynamic" makeNext_IEnumUnknown :: FunPtr Next_IEnumUnknown -> Next_IEnumUnknown + +-- | 'all_IEnumUnknown' +all_IEnumUnknown :: IEnumUnknown -> [InterfacePtr] -> IO [InterfacePtr] +all_IEnumUnknown this xs = do + next <- next_IEnumUnknown this + if next == nullPtr then + return xs + else + all_IEnumUnknown this (next : xs) + +-- | 'getRuntimes_ICLRMetaHost' +getRuntimes_ICLRMetaHost :: ICLRMetaHost -> IO [ICLRRuntimeInfo] +getRuntimes_ICLRMetaHost this = do + enum <- enumInstalledRuntimes_ICLRMetaHost this + all_IEnumUnknown enum [] + +-- | 'getVersionString_ICLRRuntimeInfo' +getVersionString_ICLRRuntimeInfo :: ICLRRuntimeInfo -> IO String +getVersionString_ICLRRuntimeInfo this = do + f <- getInterfaceFunction 3 makeGetVersionString_ICLRRuntimeInfo this + with 512 $ \sizePtr -> + allocaArray 512 $ \stringPtr -> do + f this stringPtr sizePtr + peekCWString stringPtr + +type GetVersionString_ICLRRuntimeInfo = ICLRRuntimeInfo -> LPCWSTR -> Ptr DWORD -> IO HResult +foreign import stdcall "dynamic" makeGetVersionString_ICLRRuntimeInfo :: FunPtr GetVersionString_ICLRRuntimeInfo -> GetVersionString_ICLRRuntimeInfo + +-- | 'getCorHost_ICLRRuntimeInfo' +getCorHost_ICLRRuntimeInfo :: ICLRRuntimeInfo -> IO ICorRuntimeHost +getCorHost_ICLRRuntimeInfo this = getInterface_ICLRRuntimeInfo this clsid_CorRuntimeHost iid_ICorRuntimeHost + +-- | 'getCLRHost_ICLRRuntimeInfo' +getCLRHost_ICLRRuntimeInfo :: ICLRRuntimeInfo -> IO ICLRRuntimeHost +getCLRHost_ICLRRuntimeInfo this = getInterface_ICLRRuntimeInfo this clsid_CLRRuntimeHost iid_ICLRRuntimeHost + +-- | 'getInterface_ICLRRuntimeInfo' +getInterface_ICLRRuntimeInfo :: ICLRRuntimeInfo -> Guid -> Guid -> IO InterfacePtr +getInterface_ICLRRuntimeInfo this clsid iid = do + f <- getInterfaceFunction 9 makeGetInterface_ICLRRuntimeInfo this + with (nullPtr :: InterfacePtr) $ \interfacePtr -> do + with clsid $ \refCLSID -> + with iid $ \refIID -> + f this refCLSID refIID interfacePtr >>= checkHR "GetInterface_ICLRRuntimeInfo" + peek interfacePtr + +type GetInterface_ICLRRuntimeInfo = ICLRRuntimeInfo -> Ptr CLSID -> Ptr IID -> Ptr ICorRuntimeHost -> IO HResult +foreign import stdcall "dynamic" makeGetInterface_ICLRRuntimeInfo :: FunPtr GetInterface_ICLRRuntimeInfo -> GetInterface_ICLRRuntimeInfo + +-- | 'getDefaultDomain_ICorRuntimeHost' calls the GetDefaultDOmain method of the given +-- ICorRuntimeHost interface. +getDefaultDomain_ICorRuntimeHost this = do + f <- getInterfaceFunction 13 makeGetDefaultDomain this + with (nullPtr :: InterfacePtr) $ \appDomainPtr -> do + f this appDomainPtr >>= checkHR "ICorRuntimeHost.GetDefaultDomain" + peek appDomainPtr + +type GetDefaultDomain = ICorRuntimeHost -> Ptr InterfacePtr -> IO HResult +foreign import stdcall "dynamic" makeGetDefaultDomain :: FunPtr GetDefaultDomain -> GetDefaultDomain + +type AppDomain = InterfacePtr -- mscorlib::_AppDomain + +-- | 'load_AppDomain' calls mscorlib::_AppDomain.Load_3(SafeArray* rawAssembly, _Assembly** result). +load_AppDomain this rawAssembly = do + f <- getInterfaceFunction 45 makeLoad_AppDomain this + with (nullPtr :: Assembly) $ \assemblyPtr -> do + f this rawAssembly assemblyPtr >>= checkHR "AppDomain.Load" + peek assemblyPtr + +type Load_AppDomain = AppDomain -> SafeArray -> Ptr Assembly -> IO HResult +foreign import stdcall "dynamic" makeLoad_AppDomain :: FunPtr Load_AppDomain -> Load_AppDomain + +-- | 'load_AppDomain_2' calls mscorlib::_AppDomain.Load_2(BStr assemblyString, _Assembly** result). +load_AppDomain_2 this assemblyString = do + f <- getInterfaceFunction 44 makeLoad_AppDomain_2 this + withBStr assemblyString $ \assemblyString' -> do + with (nullPtr :: InterfacePtr) $ \assemblyPtr -> do + f this assemblyString' assemblyPtr >>= checkHR "AppDomain.Load" + peek assemblyPtr + +type Load_AppDomain_2 = AppDomain -> BStr -> Ptr InterfacePtr -> IO HResult +foreign import stdcall "dynamic" makeLoad_AppDomain_2 :: FunPtr Load_AppDomain_2 -> Load_AppDomain_2 + +type Assembly = InterfacePtr -- mscorlib::_Assembly + +-- | 'getType_Assembly' calls mscorlib::_Assembly.GetType_2(BStr name, _Type** result). +getType_Assembly this name = do + f <- getInterfaceFunction 17 makeGetType_Assembly this + withBStr name $ \name' -> + with (nullPtr :: CorLibType) $ \typePtr -> do + f this name' typePtr >>= checkHR "Assembly.GetType" + t <- peek typePtr + if t == nullPtr then error "Assembly.GetType failed" + else return t + +type GetType_Assembly = Assembly -> BStr -> Ptr CorLibType -> IO HResult +foreign import stdcall "dynamic" makeGetType_Assembly :: FunPtr GetType_Assembly -> GetType_Assembly + +type CorLibType = InterfacePtr -- mscorlib::_Type + +-- | 'invokeMember_Type' calls mscorlib::_Type.InvokeMember_3(BStr name, +-- BindingFlags invokeAttr, _Binder* binder, Variant target, SafeArray* args, +-- Variant* result) to invoke a method without a binder, target or any arguments. +invokeMember_Type this memberName = do + f <- getInterfaceFunction 57 {- _Type.InvokeMember_3 -} makeInvokeMember_Type this + withBStr memberName $ \memberName' -> + with emptyVariant $ \resultPtr -> do +#if x86_64_HOST_ARCH + with emptyVariant $ \target -> + f this memberName' 256 nullPtr target nullPtr resultPtr >>= checkHR "Type.InvokeMember" +#else + f this memberName' 256 nullPtr 0 0 nullPtr resultPtr >>= checkHR "Type.InvokeMember" +#endif + peek resultPtr + +-- Portability note: Type.InvokeMember accepts a by-value variant argument (as its fourth +-- argument). GHC doesn't let us use that as an argument however, so +-- there's a calling convention dependent hack in the declarations below. +-- For Stdcall, this is encoded as two Word64 arguments. +-- For Win64, it would expect an argument of this size to be passed by reference. +#if x86_64_HOST_ARCH +type InvokeMember_Type = CorLibType -> BStr -> Word32 -> Ptr () -> Ptr Variant -> Ptr () -> Ptr Variant -> IO HResult +#else +type InvokeMember_Type = CorLibType -> BStr -> Word32 -> Ptr () -> Word64 -> Word64 -> Ptr () -> Ptr Variant -> IO HResult +#endif +foreign import stdcall "dynamic" makeInvokeMember_Type :: FunPtr InvokeMember_Type -> InvokeMember_Type + + +-- | 'loadDriverAndBoot' loads the Salsa driver assembly into the application domain from +-- memory (the binary data is originally stored in 'driverData'), and then invokes the +-- Boot method (from the Salsa.Driver class) to obtain a function pointer for invoking +-- the 'GetPointerToMethod' method. +loadDriverAndBoot :: ICorRuntimeHost -> IO (FunPtr (Ptr Word16 -> IO (FunPtr a))) +loadDriverAndBoot clrHost = do + -- Obtain an _AppDomain interface pointer to the default application domain + withInterface (getDefaultDomain_ICorRuntimeHost clrHost) $ \untypedAppDomain -> do + let iid_AppDomain = Guid 0x05F696DC 0x2B29 0x3663 0xAD 0x8B 0xC4 0x38 0x9C 0xF2 0xA7 0x13 + withInterface (queryInterface untypedAppDomain iid_AppDomain) $ \appDomain -> do + + -- Create a safe array for the contents of the driver assembly binary + bracket (prim_SafeArrayCreateVector varType_UI1 0 (fromIntegral $ S.length driverData)) + (prim_SafeArrayDestroy) + (\sa -> do + -- Copy the driver assembly data into the safe array + saDataPtr <- with (nullPtr :: Ptr Word8) $ \ptr -> + prim_SafeArrayAccessData sa ptr >> peek ptr + S.useAsCStringLen driverData $ \(bsPtr,bsLen) -> do + copyBytes saDataPtr (unsafeCoerce bsPtr) bsLen + prim_SafeArrayUnaccessData sa + + -- Load the driver assembly into the application domain + withInterface (load_AppDomain appDomain sa) $ \assembly -> do + + -- Obtain a _Type interface pointer to the Salsa.Driver type + withInterface (getType_Assembly assembly "Salsa.Driver") $ \typ -> do + + -- Invoke the Boot method of Salsa.Driver to obtain a function + -- pointer to the 'GetPointerToMethod' method + (Variant _ returnValue) <- invokeMember_Type typ "Boot" + + -- Return a wrapper function for the 'GetPointerToMethod' method + return $ unsafeCoerce returnValue) + + + diff --git a/src/Clr/Host/DotNet/Common.hs b/src/Clr/Host/DotNet/Common.hs new file mode 100644 --- /dev/null +++ b/src/Clr/Host/DotNet/Common.hs @@ -0,0 +1,72 @@ +module Clr.Host.DotNet.Common where + +import Clr.Host.DotNet.Guid +import Control.Exception (bracket) +import Data.Int +import Data.Word +import Foreign.Marshal +import Foreign.Ptr +import Foreign.Storable +import Text.Printf + +-- | 'InterfacePtr' is a pointer to an arbitrary COM interface (which is a pointer to +-- a vtable of function pointers for the interface methods). +type InterfacePtr = Ptr (Ptr (FunPtr ())) + +-- | 'withInterface i f' is like 'bracket' but for COM interface pointers, it calls +-- 'release' once the computation is finished. +withInterface :: (IO InterfacePtr) -> (InterfacePtr -> IO a) -> IO a +withInterface i = bracket i (\x -> if x == nullPtr then return 0 else release x) + + +-- | 'getInterfaceFunction' @i makeFun obj@ is an action that returns the @i@th function +-- of the COM interface referred to by @obj@. The function is returned as a Haskell +-- function by passing it through @makeFun@. +getInterfaceFunction :: Int -> (FunPtr a -> b) -> InterfacePtr -> IO b +getInterfaceFunction index makeFun this = do + -- Obtain a pointer to the appropriate element in the vtable for this interface + funPtr <- peek this >>= (flip peekElemOff) index + -- Cast the function pointer to the expected type, and import it as a Haskell function + return $ makeFun $ castFunPtr funPtr + + +foreign import stdcall "CoInitializeEx" coInitializeEx :: Ptr () -> Int32 -> IO HResult +foreign import stdcall "CoUninitialize" coUninitialize :: IO () + +coInit_MultiThreaded = 0 :: Int32 +coInit_ApartmentThreaded = 2 :: Int32 + + +-- +-- HResult Support +-- + +type HResult = Word32 + +checkHR :: String -> HResult -> IO HResult +checkHR msg 0 = return 0 +checkHR msg r = error $ printf "%s failed (0x%8x)" msg r + +-- +-- IUnknown +-- + +-- | 'queryInterface' calls the QueryInterface method of the given COM interface. +queryInterface this iid = do + f <- getInterfaceFunction 0 {- QueryInterface -} makeQueryInterface this + with (nullPtr :: InterfacePtr) $ \interfacePtr -> do + with iid $ \refIID -> f this refIID interfacePtr >>= checkHR "IUnknown.QueryInterface" + peek interfacePtr + +type QueryInterface = InterfacePtr -> Ptr IID -> Ptr InterfacePtr -> IO HResult +foreign import stdcall "dynamic" makeQueryInterface :: FunPtr QueryInterface -> QueryInterface + + +-- | 'release' calls the Release method of the given COM interface. +release this = do + f <- getInterfaceFunction 2 {- Release -} makeRelease this + f this + +type Release = InterfacePtr -> IO Word32 +foreign import stdcall "dynamic" makeRelease :: FunPtr Release -> Release + diff --git a/src/Clr/Host/DotNet/Guid.hs b/src/Clr/Host/DotNet/Guid.hs new file mode 100644 --- /dev/null +++ b/src/Clr/Host/DotNet/Guid.hs @@ -0,0 +1,43 @@ +module Clr.Host.DotNet.Guid where + +import Data.Word +import Foreign.Ptr +import Foreign.Storable + +data Guid = Guid Word32 Word16 Word16 Word8 Word8 Word8 Word8 Word8 Word8 Word8 Word8 + deriving (Show, Eq) + +instance Storable Guid where + sizeOf _ = 16 + alignment _ = 4 + + peek guidPtr = do + a <- peek $ plusPtr guidPtr 0 + b <- peek $ plusPtr guidPtr 4 + c <- peek $ plusPtr guidPtr 6 + d0 <- peek $ plusPtr guidPtr 8 + d1 <- peek $ plusPtr guidPtr 9 + d2 <- peek $ plusPtr guidPtr 10 + d3 <- peek $ plusPtr guidPtr 11 + d4 <- peek $ plusPtr guidPtr 12 + d5 <- peek $ plusPtr guidPtr 13 + d6 <- peek $ plusPtr guidPtr 14 + d7 <- peek $ plusPtr guidPtr 15 + return $ Guid a b c d0 d1 d2 d3 d4 d5 d6 d7 + + poke guidPtr (Guid a b c d0 d1 d2 d3 d4 d5 d6 d7) = do + poke (plusPtr guidPtr 0) a + poke (plusPtr guidPtr 4) b + poke (plusPtr guidPtr 6) c + poke (plusPtr guidPtr 8) d0 + poke (plusPtr guidPtr 9) d1 + poke (plusPtr guidPtr 10) d2 + poke (plusPtr guidPtr 11) d3 + poke (plusPtr guidPtr 12) d4 + poke (plusPtr guidPtr 13) d5 + poke (plusPtr guidPtr 14) d6 + poke (plusPtr guidPtr 15) d7 + +type CLSID = Guid +type IID = Guid + diff --git a/src/Clr/Host/DotNet/SafeArray.hs b/src/Clr/Host/DotNet/SafeArray.hs new file mode 100644 --- /dev/null +++ b/src/Clr/Host/DotNet/SafeArray.hs @@ -0,0 +1,15 @@ +module Clr.Host.DotNet.SafeArray where + +import Clr.Host.DotNet.Common +import Clr.Host.DotNet.Variant +import Data.Int +import Data.Word +import Foreign.Ptr + +newtype SafeArray = SafeArray (Ptr ()) deriving (Show, Eq) + +foreign import stdcall "SafeArrayCreateVector" prim_SafeArrayCreateVector :: VarType -> Int32 -> Word32 -> IO SafeArray +foreign import stdcall "SafeArrayAccessData" prim_SafeArrayAccessData :: SafeArray -> Ptr (Ptr a) -> IO HResult +foreign import stdcall "SafeArrayUnaccessData" prim_SafeArrayUnaccessData :: SafeArray -> IO HResult +foreign import stdcall "SafeArrayDestroy" prim_SafeArrayDestroy :: SafeArray -> IO HResult + diff --git a/src/Clr/Host/DotNet/Variant.hs b/src/Clr/Host/DotNet/Variant.hs new file mode 100644 --- /dev/null +++ b/src/Clr/Host/DotNet/Variant.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE CPP #-} + +module Clr.Host.DotNet.Variant where + +import Data.Word +import Foreign.Ptr +import Foreign.Storable + +data Variant = Variant VarType Word64 deriving (Show, Eq) +type VarType = Word16 + +varType_Empty, varType_UI1 :: VarType +varType_Empty = 0 +varType_UI1 = 17 + +emptyVariant = Variant varType_Empty 0 + +instance Storable Variant where +#if x86_64_HOST_ARCH + sizeOf _ = 24 +#else + sizeOf _ = 16 +#endif + alignment _ = 8 + + peek ptr = do + a <- peek $ plusPtr ptr 0 + b <- peek $ plusPtr ptr 8 + return $ Variant a b + + poke ptr (Variant a b) = do + poke (plusPtr ptr 0) a + poke (plusPtr ptr 2) (0 :: Word16) + poke (plusPtr ptr 4) (0 :: Word16) + poke (plusPtr ptr 6) (0 :: Word16) + poke (plusPtr ptr 8) b + diff --git a/src/Clr/Host/Driver.hs b/src/Clr/Host/Driver.hs new file mode 100644 --- /dev/null +++ b/src/Clr/Host/Driver.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Clr.Host.Driver (driverData) where + +import qualified Data.ByteString.Char8 as B +import Data.FileEmbed + +{-# NOINLINE driverData #-} +driverData :: B.ByteString +driverData = $(makeRelativeToProject "src/Driver.dll" >>= embedFile) + diff --git a/src/Clr/Host/Mono.hs b/src/Clr/Host/Mono.hs new file mode 100644 --- /dev/null +++ b/src/Clr/Host/Mono.hs @@ -0,0 +1,147 @@ + +module Clr.Host.Mono ( + startHostMono, + stopHostMono, + ) where + +import Data.Word +import Data.Int +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Foreign.Ptr +import Foreign.Storable +import Foreign.Marshal +import Foreign.C +import System.IO +import System.Environment (getProgName) +import Control.Exception (bracket) +import Text.Printf + +import Clr.Host.Driver + +data MonoAssembly = MonoAssembly +type MonoAssemblyPtr = Ptr MonoAssembly +data MonoDomain = MonoDomain +type MonoDomainPtr = Ptr MonoDomain +data MonoImage = MonoImage +type MonoImagePtr = Ptr MonoImage +data MonoMethodDesc = MonoMethodDesc +type MonoMethodDescPtr = Ptr MonoMethodDesc +data MonoClass = MonoClass +type MonoClassPtr = Ptr MonoClass +data MonoArray = MonoArray +type MonoArrayPtr = Ptr MonoArray +data MonoMethod = MonoMethod +type MonoMethodPtr = Ptr MonoMethod +data MonoObject = MonoObject +type MonoObjectPtr = Ptr MonoObject +data MonoAssemblyName = MonoAssemblyName +type MonoAssemblyNamePtr = Ptr MonoAssemblyName + +type MonoImageOpenStatus = CInt + +type GBool = CInt +gboolTrue = 1 +gboolFalse = 0 + +foreign import ccall mono_jit_init :: CString -> IO MonoDomainPtr +foreign import ccall mono_jit_cleanup :: MonoDomainPtr -> IO () +foreign import ccall mono_config_parse :: Ptr () -> IO () +foreign import ccall mono_get_corlib :: IO MonoImagePtr +foreign import ccall mono_method_desc_new :: CString -> GBool -> IO MonoMethodDescPtr +foreign import ccall mono_method_desc_search_in_image :: MonoMethodDescPtr -> MonoImagePtr -> IO MonoMethodPtr +foreign import ccall mono_method_desc_free :: MonoMethodDescPtr -> IO () +foreign import ccall mono_get_byte_class :: IO MonoClassPtr +foreign import ccall mono_array_new :: MonoDomainPtr -> MonoClassPtr -> Int -> IO MonoArrayPtr +foreign import ccall mono_value_copy_array :: MonoArrayPtr -> Int -> Ptr a -> Int -> IO () +foreign import ccall mono_image_open_from_data :: Ptr a -> Word32 -> GBool -> Ptr MonoImageOpenStatus -> IO MonoImagePtr +foreign import ccall mono_runtime_invoke :: MonoMethodPtr -> Ptr a -> Ptr b -> Ptr c -> IO MonoObjectPtr +foreign import ccall mono_object_unbox :: MonoObjectPtr -> IO (Ptr a) +foreign import ccall mono_domain_get :: IO MonoDomainPtr +foreign import ccall mono_assembly_loaded :: MonoAssemblyNamePtr -> IO MonoAssemblyPtr +foreign import ccall mono_assembly_name_new :: CString -> IO MonoAssemblyNamePtr +foreign import ccall mono_assembly_get_image :: MonoAssemblyPtr -> IO MonoImagePtr +foreign import ccall mono_domain_set_config :: MonoDomainPtr -> CString -> CString -> IO () + +getDriverDataArray :: IO MonoArrayPtr +getDriverDataArray = unsafeUseAsCStringLen driverData $ \(p,l)-> do + dom <- mono_domain_get + if dom == nullPtr then + error "null domain" + else do + bcls <- mono_get_byte_class + ar <- mono_array_new dom bcls l + mono_value_copy_array ar 0 p l + return ar + +startHostMono :: IO (FunPtr (Ptr Word16 -> IO (FunPtr a))) +startHostMono = do + mono_config_parse nullPtr + domain <- return "salsa" >>= flip withCString mono_jit_init + if (domain == nullPtr) then + error "null domain" + else do + setupDomain + loadDriver + bootDriver + +stopHostMono :: IO () +stopHostMono = return () + +getDriverImage :: IO MonoImagePtr +getDriverImage = withCString "Driver" $ \c-> do + name <- mono_assembly_name_new c + if name == nullPtr then + error "Could not create assembly name" + else do + assem <- mono_assembly_loaded name + if assem == nullPtr then + error "Could not get Salsa assembly" + else do + image <- mono_assembly_get_image assem + if image == nullPtr then + error "Could not get Salsa image" + else return image + +getMethodFromNameImage :: String -> MonoImagePtr -> IO MonoMethodPtr +getMethodFromNameImage nameS img = withCString nameS $ \nameC-> do + mthDes <- mono_method_desc_new nameC gboolTrue + if mthDes == nullPtr then + error "null mth des" + else do + method <- mono_method_desc_search_in_image mthDes img + if method == nullPtr then + error ("null method " ++ nameS) + else return method + +setupDomain :: IO () +setupDomain = withCString "Salsa.config" $ \configFile-> do + withCString "./" $ \baseDir-> do + dom <- mono_domain_get + mono_domain_set_config dom baseDir configFile + +bootDriver :: IO (FunPtr (Ptr Word16 -> IO (FunPtr a))) +bootDriver = do + salsa <- getDriverImage + method <- getMethodFromNameImage "Salsa.Driver:Boot()" salsa + if method == nullPtr then + error "Could not find boot method" + else do + oret <- mono_runtime_invoke method nullPtr nullPtr nullPtr + pret <- mono_object_unbox oret + peek pret + +loadDriver :: IO () +loadDriver = do + corlib <- mono_get_corlib + if (corlib == nullPtr) then + error "null image" + else do + method <- getMethodFromNameImage "System.Reflection.Assembly:Load(byte[])" corlib + if (method == nullPtr) then + error "Cannot find method" + else do + dd <- getDriverDataArray + withArray [dd] $ \argp-> mono_runtime_invoke method nullPtr argp nullPtr + return () + + diff --git a/src/Driver.cs b/src/Driver.cs new file mode 100644 --- /dev/null +++ b/src/Driver.cs @@ -0,0 +1,1179 @@ +// +// Salsa .NET Driver +// +// Licence: BSD3 (see LICENSE) +// + +using System; +using System.Linq; +using System.Collections.Generic; +using System.Text; +using System.Runtime.InteropServices; +using System.Net; +using System.Reflection; +using System.Reflection.Emit; +using System.Diagnostics; +using System.IO; +using System.Threading; + +[assembly: AssemblyTitle("Salsa")] +[assembly: AssemblyDescription(".NET Bridge for Haskell")] +[assembly: AssemblyProduct("Salsa")] +[assembly: AssemblyCopyright("Copyright © 2007-2008 Andrew Appleyard")] +[assembly: AssemblyVersion("1.0.0.0")] +[assembly: AssemblyFileVersion("1.0.0.0")] + +// TODO: Consider caching the results of the Get*Stub(string, ...) methods +// (although it's not really necessary, Haskell will cache the results). + +namespace Salsa +{ + public class Driver + { + internal static AssemblyBuilder _assemblyBuilder; + internal static ModuleBuilder _dynamicModuleBuilder; + internal static TypeBuilder _stubsTypeBuilder; + + static Driver() + { + //Console.WriteLine("Using Salsa.dll (version {0})", + // Assembly.GetExecutingAssembly().GetName().Version); + + Trace.Listeners.Add(new ConsoleTraceListener()); + + _assemblyBuilder = AppDomain.CurrentDomain.DefineDynamicAssembly( + 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() + { + // TODO: Accept an option from Salsa for the threading model to use + // Thread.CurrentThread.SetApartmentState(ApartmentState.STA); + + return GetPointerToMethod("GetPointerToMethod"); + } + + /// + /// Returns a native function pointer (as an int) to a stub wrapping the given method. + /// + /// + /// This is the first .NET function called by Haskell, and is called by using the + /// ICLRRuntimeHost.ExecuteInDefaultAppDomain method. + /// + public static IntPtr GetPointerToMethod(string methodName) + { + //Trace.WriteLine("GetPointerToMethod(" + methodName + ")"); + //Console.WriteLine("Called on thread: " + System.Threading.Thread.CurrentThread.ManagedThreadId); + + MethodInfo meth = typeof(Driver).GetMethod(methodName); + if (meth == null) + throw new ArgumentException("Method not found.", methodName); + + // Return a delegate pointing to the indicated method (cast to an int + // so we can call this method using ExecuteInDefaultAppDomain) + return GenerateMethodStub(meth); + } + + #region Entry points + + /// + /// This method is called by Haskell so that the .NET side of the bridge + /// has access to the Haskell function 'freeHaskellFunPtr'. + /// + public static void SetFreeHaskellFunPtr(IntPtr freeHaskellFunPtr) + { + if (freeHaskellFunPtr == IntPtr.Zero) + { + // Clear any previously stored delegate wrapping 'freeHaskellFunPtr' + // (this will prevent calls into Haskell from .NET finalizers) + FreeHaskellFunPtr = null; + } + else + { + // Store the delegate wrapping the 'freeHaskellFunPtr' function passed in + FreeHaskellFunPtr = + (FreeHaskellFunPtrDelegate)Marshal.GetDelegateForFunctionPointer( + freeHaskellFunPtr, typeof(FreeHaskellFunPtrDelegate)); + } + Trace.WriteLine(string.Format("SetFreeHaskellFunPtr(0x{0:x})", freeHaskellFunPtr)); + } + + public static FreeHaskellFunPtrDelegate FreeHaskellFunPtr; + + /// + /// Saves the assembly containing the dynamically generated wrapper methods and + /// delegate classes created during the bridge operation. + /// + public static void SaveDynamicAssembly() + { + _stubsTypeBuilder.CreateType(); + + string fileName = Path.GetFileName(_dynamicModuleBuilder.FullyQualifiedName); + Console.WriteLine("Saving dynamic assembly: " + fileName); + _assemblyBuilder.Save(fileName); + } + + /// + /// Given the class, name, and signature of a method or constructor, returns a + /// native function pointer to a delegate that calls the method or constructor + /// when invoked. + /// + /// + /// Use a 'methodName' of '.ctor' to obtain a constructor stub. + /// + public static IntPtr GetMethodStub(string className, string methodName, + string parameterTypeNames) + { + if (methodName == ".ctor") + { + ConstructorInfo con = StringToType(className).GetConstructor( + StringToTypes(parameterTypeNames)); + return GenerateConstructorStub(con); + } + else + { + Type typ = StringToType(className); + MethodInfo meth; + if (parameterTypeNames != null) + meth = typ.GetMethod(methodName, StringToTypes(parameterTypeNames)); + else + meth = typ.GetMethod(methodName); + if(meth == null) { + var knownMethods = typ.GetMethods().Select(x => x.Name).ToArray(); + throw new ArgumentException(String.Format("Method {0}({1}) not found in type {2}({3}). Try with: {4}", methodName, parameterTypeNames, typ.Name, typ.Assembly.FullName, String.Join(",",knownMethods) )); + } + return GenerateMethodStub(meth); + } + } + + /// + /// Given the name of a delegate type, returns a function pointer to a delegate that, + /// when called, instantiates delegate instances of the given delegate type when given + /// a pointer to a Haskell function. + /// + public static IntPtr GetDelegateConstructorStub(string delegateTypeName) + { + Type delegateType = StringToType(delegateTypeName); + return GenerateDelegateConstructorStub(delegateType); + } + + /// + /// Given the class and name of a field, returns a native function pointer to a + /// delegate that returns the value of the field when invoked. + /// + public static IntPtr GetFieldGetStub(string className, string fieldName) + { + FieldInfo field = StringToType(className).GetField(fieldName); + return GenerateFieldGetStub(field); + } + + /// + /// Given the class and name of a field, returns a native function pointer to a + /// delegate that sets the value of the field when invoked. + /// + public static IntPtr GetFieldSetStub(string className, string fieldName) + { + FieldInfo field = StringToType(className).GetField(fieldName); + return GenerateFieldSetStub(field); + } + + /// + /// Given a value type, returns a native function pointer to a method that + /// boxes values of the given value type. + /// + public static IntPtr GetBoxStub(string typeName) + { + Type typeToBox = StringToType(typeName); + return GenerateBoxStub(typeToBox); + } + + #endregion + + #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) + { + if (o == null) + return 0; + + if (o is bool?) // HACK for Nullable + { + bool b = (bool)o; + return b ? 1 : 2; + } + + lock (_inTable) + { + _inTable.Add(_nextId, o); + return _nextId++; + } + } + + public static object GetObject(long oId) + { + if (oId == 0) // 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; + + 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. + } + } + } + + [UnmanagedFunctionPointer(CallingConvention.Cdecl)] + public delegate void ReleaseObjectDelegate(long oId); + private static ReleaseObjectDelegate _ReleaseObjectDelegate = ReleaseObject; + + public static void ReleaseObject(long oId) + { + lock (_inTable) + { + _inTable.Remove(oId); + } + } + + #endregion + + #region Managed delegate references (function pointer in-table) + + /// + /// Maintains references to any .NET delegates that have a native function pointer + /// referring to them (as obtained using Marshal.GetFunctionPointerForDelegate), so + /// that they are not collected prematurely. + /// + private static Dictionary _dotNetFunPtrDelegates = new Dictionary(); + + /// + /// Returns a native function pointer for calling the given .NET delegate. A + /// reference to the delegate is stored in _dotNetFunPtrDelegates to prevent + /// the delegate from being garbage collected while the function pointer is + /// still being used. + /// + private static IntPtr GetDotNetFunPtrForDelegate(Delegate d) // TODO: Perhaps rename 'RegisterDelegate' + { + IntPtr funPtr = Marshal.GetFunctionPointerForDelegate(d); + lock (_dotNetFunPtrDelegates) + _dotNetFunPtrDelegates.Add(funPtr, d); + return funPtr; + } + + /// + /// This method is called to indicate that the given native function pointer + /// will no longer be called from Haskell. It allows the associated .NET + /// delegate to be garbage collected provided there are no other references + /// to it. + /// + public static void FreeDotNetFunPtr(IntPtr funPtr) // TODO: Perhaps rename 'ReleaseDelegate' + { + lock (_dotNetFunPtrDelegates) + _dotNetFunPtrDelegates.Remove(funPtr); + } + + #endregion + + #region Stub method generation + + /// + /// Generates a dynamic method of the given name and signature, containing the instructions + /// produced by 'ilWriter'. A delegate to the method, is returned to the caller as a native + /// function pointer. + /// + /// + /// This method also writes the method to the 'Stubs' class in 'Dynamic.dll' for debugging + /// purposes. + /// + private static IntPtr GenerateDynamicMethod(string methodName, + DelegateSignature methodSignature, ILWriterDelegate ilWriter) + { + if (true) + { + // Optional: generate an implementation of the stub method inside the 'Stubs' + // class (which is saved to 'Dynamic.dll') for debugging purposes. + MethodBuilder savedMethod = _stubsTypeBuilder.DefineMethod(methodName, MethodAttributes.Public, + methodSignature.ReturnType, methodSignature.ParameterTypes); + ilWriter(savedMethod.GetILGenerator()); + } + + // Generate a dynamic method of the given name and signature, and the + // IL instructions given by 'ilWriter', then return a delegate to the + // method as a function pointer. + + // [stubReturnType] [classType]_[methodname]([classType] this, [args...]): + DynamicMethod method = new DynamicMethod(methodName, methodSignature.ReturnType, + methodSignature.ParameterTypes, typeof(Driver)); + ilWriter(method.GetILGenerator()); + + return GetDotNetFunPtrForDelegate(method.CreateDelegate(methodSignature.ToDelegateType())); + } + + /// + /// Returns a native function pointer to a wrapper stub that accepts foreign + /// parameters, marshals them, calls the indicated constructor, and returns the + /// resulting object instance (marshaled as necessary). + /// + /// + /// The returned function pointer should be freed with 'FreeDotNetFunPtr'. + /// When used to construct a value type, 'con' may be null, in which case + /// no constructor is called (the value is just initialised to zero). + /// + public static IntPtr GenerateConstructorStub(ConstructorInfo con) + { + Type type = con.DeclaringType; + + if (!type.IsValueType && con == null) + throw new ArgumentNullException("'con' cannot be null if creating a reference type."); + + // Generate a dynamic method that does the following: + // + // Int64 [classType]New([args...]) + // { + // [classType] o = new [classType]([args... using GetObject ... ]); + // (box o if it is a value type) + // return Driver.RegisterObject(o); + // } + + // Signature of the stub method returned (as a delegate) by this function + DelegateSignature methodSignature = new DelegateSignature( + typeof(Int64), + con == null ? Type.EmptyTypes : + ConvertToStubTypes(Util.MapParametersToTypes(con.GetParameters()))); + + return GenerateDynamicMethod(type.Name + "New", methodSignature, + delegate(ILGenerator ilg) + { + if (con == null) // Initialise object to zero? + { + // Initialise the object in a local variable + ilg.DeclareLocal(type); + ilg.Emit(OpCodes.Ldloca_S, (byte)0); + ilg.Emit(OpCodes.Initobj, type); + + // Load the object onto the stack + ilg.Emit(OpCodes.Ldloc_0); + } + else // Call object constructor: + { + // Load (and unmarshal), the arguments to the constructor stub + EmitParameterLoading(ilg, 0, con.GetParameters()); + + // Call the constructor, i.e. 'o = new [classType]([unmarshaled args])' + ilg.Emit(OpCodes.Newobj, con); + } + + // Return the new object (marshaled as an index) + EmitToStub(ilg, type); + ilg.Emit(OpCodes.Ret); + }); + } + + /// + /// Returns a native function pointer to a stub method that calls the given + /// method, marshaling arguments as necessary. + /// + /// + /// The returned function pointer should be freed with 'FreeDotNetFunPtr'. + /// + public static IntPtr GenerateMethodStub(MethodInfo meth) + { + Type classType = meth.DeclaringType; + + // Generate a dynamic method that does the following: + // + // [stubReturnType] [classType]_[methodName]([classType] this, [args...]) + // OR (if a static method) + // [stubReturnType] [classType]_[methodName]([args...]) + // { + // [resultType] r = this.[methodName]([marshaledThis], [marshaled args]); + // OR (if a static method) + // [resultType] r = [className].[methodName]([marshaled args]); + // + // return r; OR return Driver.RegisterObject(r); + // } + + // Signature of the stub method returned (as a delegate) by this function + DelegateSignature methodSignature = new DelegateSignature( + ConvertToStubType(meth.ReturnParameter.ParameterType), + meth.IsStatic ? ConvertToStubTypes(Util.MapParametersToTypes(meth.GetParameters())) : + Util.ConcatArray( + ConvertToStubType(meth.DeclaringType), + ConvertToStubTypes(Util.MapParametersToTypes(meth.GetParameters())))); + + return GenerateDynamicMethod(classType.Name + "_" + meth.Name, methodSignature, + delegate(ILGenerator ilg) + { + // Load (and unmarshal), the arguments to the method stub, then call the real method + if (meth.IsStatic) + { + EmitParameterLoading(ilg, 0, meth.GetParameters()); + ilg.Emit(OpCodes.Call, meth); + } + else + { + EmitParameterLoading(ilg, 0, meth.DeclaringType); + EmitParameterLoading(ilg, 1, meth.GetParameters()); + ilg.Emit(OpCodes.Callvirt, meth); + } + + // Unmarshal and return the result + EmitMarshaledReturn(ilg, meth.ReturnParameter); + }); + } + + /// + /// Instantiates a delegate that, given an IntPtr to a Haskell function, returns a + /// delegate instance (of the given delegate type) that wraps this native function + /// (and deals with parameter value marshaling and finalization). + /// + /// Type of delegate returned by the returned delegate. + /// + /// Wrapper delegate that accepts an IntPtr and returns a delegate of the + /// indicated type. + /// + public static IntPtr GenerateDelegateConstructorStub(Type delegateType) + { + // Obtain (creating, if necessary) the type of a wrapper class for the delegate + Type wrapperType = GetDelegateWrapperType(delegateType); + + DelegateSignature delegateSignature = DelegateSignature.FromDelegateType(delegateType); + + // Generate a dynamic method that does the following: + // + // Int64 [delegateType]New(IntPtr funPtr) + // { + // [wrapperType] wrapper = new [wrapperType](funPtr); + // Delegate d = new [delegateType](wrapper.Invoke); + // return Driver.RegisterObject(d); + // } + + // Signature of the method returned (as a delegate) by this function (the + // 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) }); + + return GenerateDynamicMethod(delegateType.Name + "New", methodSignature, + delegate(ILGenerator ilg) + { + // wrapper = new [wrapperType](funPtr): + ilg.Emit(OpCodes.Ldarg_0); + ilg.Emit(OpCodes.Newobj, wrapperType.GetConstructor(new Type[] { typeof(IntPtr) })); + + // Obtain wrapper.Invoke + ilg.Emit(OpCodes.Ldftn, wrapperType.GetMethod("Invoke")); + + // Delegate d = new [delegateType](wrapper.Invoke): + ilg.Emit(OpCodes.Newobj, delegateType.GetConstructor(new Type[] { typeof(object), typeof(IntPtr) })); + + // return Driver.RegisterObject(d): + ilg.Emit(OpCodes.Call, MemberInfos.Driver_RegisterObject); + ilg.Emit(OpCodes.Ret); + }); + } + + /// + /// Returns a native function pointer to a stub method that retrieves the value + /// of the given static or instance field. + /// + /// + /// The returned function pointer should be freed with 'FreeDotNetFunPtr'. + /// + public static IntPtr GenerateFieldGetStub(FieldInfo field) + { + // Signature of the stub method returned (as a delegate) by this function + DelegateSignature methodSignature = new DelegateSignature( + ConvertToStubType(field.FieldType), + field.IsStatic ? Type.EmptyTypes : new Type[] { ConvertToStubType(field.DeclaringType) }); + + return GenerateDynamicMethod(field.DeclaringType.Name + "_field_get_" + field.Name, methodSignature, + delegate(ILGenerator ilg) + { + if (field.IsStatic) + { + if (field.IsLiteral) + { + // FIXME: Move literal calculation to the generator, and add + // support for literal values in the bridge (i.e. + // values other than 'Obj ObjectId's + object literalValue = field.GetRawConstantValue(); + if (literalValue is Int32) + ilg.Emit(OpCodes.Ldc_I4, (Int32)literalValue); + } + else + ilg.Emit(OpCodes.Ldsfld, field); + } + else + { + // Load (and unmarshal) the argument to the method stub, then load the field value + EmitParameterLoading(ilg, 0, field.DeclaringType); + ilg.Emit(OpCodes.Ldfld, field); + } + + // Unmarshal and return the result + EmitToStub(ilg, field.FieldType); + ilg.Emit(OpCodes.Ret); + }); + } + + /// + /// Returns a native function pointer to a stub method that sets the value + /// of the given static or instance field. + /// + /// + /// The returned function pointer should be freed with 'FreeDotNetFunPtr'. + /// + public static IntPtr GenerateFieldSetStub(FieldInfo field) + { + // Signature of the stub method returned (as a delegate) by this function + DelegateSignature methodSignature = new DelegateSignature( + typeof(void), + field.IsStatic ? + new Type[] { ConvertToStubType(field.FieldType) } : + new Type[] { ConvertToStubType(field.DeclaringType), ConvertToStubType(field.FieldType) }); + + return GenerateDynamicMethod(field.DeclaringType.Name + "_field_set_" + field.Name, methodSignature, + delegate(ILGenerator ilg) + { + if (field.IsStatic) + { + // Load (and unmarshal) the field value from the stub call + EmitParameterLoading(ilg, 0, field.FieldType); + ilg.Emit(OpCodes.Stsfld, field); + } + else + { + // Load (and unmarshal) the instance argument and field value from the stub call + EmitParameterLoading(ilg, 0, field.DeclaringType); + EmitParameterLoading(ilg, 1, field.FieldType); + ilg.Emit(OpCodes.Stfld, field); + } + + ilg.Emit(OpCodes.Ret); + }); + } + + /// + /// Returns a native function pointer to a stub method that returns a + /// reference to the given value (boxing value types as necessary). + /// + /// + /// The returned function pointer should be freed with 'FreeDotNetFunPtr'. + /// + public static IntPtr GenerateBoxStub(Type typeToBox) + { + // Signature of the stub method returned (as a delegate) by this function + DelegateSignature methodSignature = new DelegateSignature( + typeof(Int64), new Type[] { ConvertToStubType(typeToBox) }); + + return GenerateDynamicMethod("box_" + typeToBox.Name, methodSignature, + delegate(ILGenerator ilg) + { + // Load the (unboxed) value + EmitParameterLoading(ilg, 0, typeToBox); + + if (typeToBox.IsValueType) + { + // Box the type value to as an object + ilg.Emit(OpCodes.Box, typeToBox); + } + + // Marshal the object instance out as an object index + EmitToStub(ilg, typeof(object)); + ilg.Emit(OpCodes.Ret); + }); + } + + #endregion + + #region Parameter and result marshaling + + private static bool IsMarshaledByIndex(Type t) + { + return !t.IsPrimitive && t != typeof(void) && t != typeof(string); + } + + + private static bool isMono = Type.GetType ("Mono.Runtime") != null; + + /// + /// Given an array of parameters (say of a constructor, or method), returns the + /// array of types that a corresponding wrapper stub would accept. + /// + private static Type[] ConvertToStubTypes(Type[] types) + { + return Util.MapArray(ConvertToStubType, types); + } + + private static Type ConvertToStubType(Type type) + { + if (IsMarshaledByIndex(type)) + return typeof(Int64); + else + return type; + } + + /// + /// Emits code (via the given IL generator) to load a single parameter of the given + /// type from the given argument index and on to the stack. It ensures that object + /// types (which are marshaled by index), are resolved to the appropriate .NET object + /// instance. + /// + private static void EmitParameterLoading(ILGenerator ilg, int argumentIndex, Type parameterType) + { + Util.EmitLdarg(ilg, argumentIndex); + EmitFromStub(ilg, parameterType); + } + + // Converts a value on the stack from a stub stub to the associated 'real' .NET type + /// + /// Emits code to convert a value on the stack from a stub type to the associated + /// 'real' .NET type. + /// + /// + /// 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 + /// no code is emitted at all since the stub type matches the desired .NET type + /// exactly. + /// + private static void EmitFromStub(ILGenerator ilg, Type valueType) + { + if (IsMarshaledByIndex(valueType)) + { + // [valueType]x = ([valueType])GetObject(value): + + // Call GetObject on the object index to obtain the object instance + ilg.Emit(OpCodes.Call, MemberInfos.Driver_GetObject); + + // Cast from Object to the appropriate type for the value (unboxing if necessary) + ilg.Emit(OpCodes.Unbox_Any, valueType); + + // Note, the above instruction is equivalent to: + // + // if (valueType.IsValueType) + // { + // ilg.Emit(OpCodes.Unbox, valueType); + // ilg.Emit(OpCodes.Ldobj); + // } + // else + // ilg.Emit(OpCodes.Castclass, valueType); + // + } + else + { + // Leave value as is + } + } + + /// + /// Emits code (via the given IL generator) to load parameters of the given types + /// from the arguments of the method (starting with 'startingArgument') and on to + /// the stack. It ensures that object types (which are marshaled by index), are + /// resolved to the appropriate .NET object instance. + /// + private static void EmitParameterLoading(ILGenerator ilg, int startingArgument, + IEnumerable parameterInfos) + { + int argumentIndex = startingArgument; + foreach (ParameterInfo parameterInfo in parameterInfos) + { + Type parameterType = parameterInfo.ParameterType; + Util.EmitLdarg(ilg, argumentIndex++); + EmitFromStub(ilg, parameterType); + } + } + + private static void EmitToStub(ILGenerator ilg, Type type) + { + if (IsMarshaledByIndex(type)) + { + if (type.IsValueType) + { + // Box the value type for passing it to RegisterObject + ilg.Emit(OpCodes.Box, type); + } + + // Marshal the object instance out as an object index, by + // calling RegisterObject + ilg.Emit(OpCodes.Call, MemberInfos.Driver_RegisterObject); + } + else + { + // Leave value as is + } + } + + /// + /// Emits code (via the given IL generator) to return the value on the top of the + /// stack, knowing that its type is given by 'returnParameterInfo'. It ensures + /// that object types (which are marshaled by index), are returned as an index. + /// + private static void EmitMarshaledReturn(ILGenerator ilg, ParameterInfo returnParameterInfo) + { + Type parameterType = returnParameterInfo.ParameterType; + EmitToStub(ilg, parameterType); + ilg.Emit(OpCodes.Ret); + } + + #endregion + + #region Delegate wrappers + + /// + /// Maintains a cache of the delegate wrapper types that have been generated. + /// + private static Dictionary _delegateWrapperTypes = + new Dictionary(); + + private static Type GetDelegateWrapperType(Type delegateType) + { + string wrapperTypeName = delegateType.Name + "Wrapper"; + lock (_delegateWrapperTypes) + { + Type type; + if (!_delegateWrapperTypes.TryGetValue(wrapperTypeName, out type)) + { + // Could not find wrapper class of appropriate type in the cache: create one + type = CreateDelegateWrapperType(wrapperTypeName, delegateType); + _delegateWrapperTypes.Add(wrapperTypeName, type); + } + return type; + } + } + + /// + /// Creates (and returns the type of) a class that wraps a pointer to a + /// Haskell function as a .NET delegate. The class ensures that the + /// wrapper function pointer is freed when the delegate is no longer being + /// used by .NET. It also performs any translation from .NET values to + /// interop values (object references are converted to object identifiers). + /// + /// Type of delegate produced by the wrapper + private static Type CreateDelegateWrapperType(string name, Type delegateType) + { + // Obtain the signature of the delegate being produced + DelegateSignature delegateSignature = DelegateSignature.FromDelegateType(delegateType); + + // Obtain the delegate type of the associated thunk for calling into Haskell + Type thunkDelegateType = new DelegateSignature( + ConvertToStubType(delegateSignature.ReturnType), + ConvertToStubTypes(delegateSignature.ParameterTypes)).ToDelegateType(); + + TypeBuilder typeBuilder = _dynamicModuleBuilder.DefineType(name, + TypeAttributes.Public | TypeAttributes.Sealed); + + // Define the _thunkDelegate field + FieldBuilder thunkDelegateField = typeBuilder.DefineField("_thunkDelegate", + thunkDelegateType, FieldAttributes.Private); + + { + // Define the constructor for the wrapper type: + // + // public DelegateWrapper(IntPtr funPtrToWrap) + // { + // _thunkDelegate = (ThunkDelegate) + // Marshal.GetDelegateForFunctionPointer( + // funPtrToWrap, typeof(ThunkDelegate)); + // } + + ConstructorBuilder constructorBuilder = typeBuilder.DefineConstructor( + MethodAttributes.Public | MethodAttributes.RTSpecialName, + CallingConventions.Standard, new Type[] { typeof(IntPtr) }); + ILGenerator ilg = constructorBuilder.GetILGenerator(); + + // Call Object's constructor + ilg.Emit(OpCodes.Ldarg_0); + ilg.Emit(OpCodes.Call, MemberInfos.Object_ctor); + + ilg.Emit(OpCodes.Ldarg_0); // Load this (for the 'stfld' below) + ilg.Emit(OpCodes.Ldarg_1); // Load funPtrToWrap + + ilg.Emit(OpCodes.Ldtoken, thunkDelegateType); // Load typeof(ThunkDelegate) + ilg.Emit(OpCodes.Call, MemberInfos.Type_GetTypeFromHandle); + + // Call (ThunkDelegate)Marshal.GetDelegateForFunctionPointer( + // funPtrToWrap, typeof(ThunkDelegate)) + ilg.Emit(OpCodes.Call, MemberInfos.Marshal_GetDelegateForFunctionPointer); + ilg.Emit(OpCodes.Castclass, thunkDelegateType); + + // Store in _thunkDelegate + ilg.Emit(OpCodes.Stfld, thunkDelegateField); + + ilg.Emit(OpCodes.Ret); + } + + { + // Define a Finalize method for the wrapper class: + // + // ~Delegate() + // { + // if (Driver.FreeHaskellFunPtr != null) + // Driver.FreeHaskellFunPtr(Marshal.GetFunctionPointerForDelegate( + // _thunkDelegate)); + // } + + MethodBuilder finalizeMethod = typeBuilder.DefineMethod("Finalize", + MethodAttributes.Family | MethodAttributes.HideBySig | MethodAttributes.Virtual); + finalizeMethod.SetImplementationFlags(MethodImplAttributes.IL | MethodImplAttributes.Managed); + ILGenerator ilg = finalizeMethod.GetILGenerator(); + Label endLabel = ilg.DefineLabel(); + + // Obtain the freeHaskellFunPtr delegate + ilg.Emit(OpCodes.Ldsfld, MemberInfos.Driver_FreeHaskellFunPtr); + + // Return immediately if the delegate is null + ilg.Emit(OpCodes.Ldc_I4_0); + ilg.Emit(OpCodes.Beq, endLabel); + + // Obtain the freeHaskellFunPtr delegate (again) + ilg.Emit(OpCodes.Ldsfld, MemberInfos.Driver_FreeHaskellFunPtr); + + // Load _thunkDelegate + ilg.Emit(OpCodes.Ldarg_0); + ilg.Emit(OpCodes.Ldfld, thunkDelegateField); + + // Call Marshal.GetFunctionPointerForDelegate to obtain the original function pointerusing + ilg.Emit(OpCodes.Call, MemberInfos.Marshal_GetFunctionPointerForDelegate); + + // Invoke freeHaskellFunPtr on this function pointer + ilg.Emit(OpCodes.Call, MemberInfos.FreeHaskellFunPtrDelegate_Invoke); + + ilg.MarkLabel(endLabel); + ilg.Emit(OpCodes.Ret); + } + + { + // Define an Invoke method that calls _thunkDelegate after marshaling + // the arguments as necessary: + // + // private void Invoke(...) + // { + // _thunkDelegate(... using RegisterObject as appropriate ...); + // } + + MethodBuilder invokeMethod = typeBuilder.DefineMethod("Invoke", + MethodAttributes.Public, delegateSignature.ReturnType, delegateSignature.ParameterTypes); + ILGenerator ilg = invokeMethod.GetILGenerator(); + + // Load _thunkDelegate (for calling it later) + ilg.Emit(OpCodes.Ldarg_0); + ilg.Emit(OpCodes.Ldfld, thunkDelegateField); + + // Load the parameters (and marshal according to type) + for (int i = 0; i < delegateSignature.ParameterTypes.Length; i++) + { + Util.EmitLdarg(ilg, i + 1); + EmitToStub(ilg, delegateSignature.ParameterTypes[i]); + } + + ilg.Emit(OpCodes.Callvirt, thunkDelegateType.GetMethod("Invoke")); + EmitFromStub(ilg, delegateSignature.ReturnType); + ilg.Emit(OpCodes.Ret); + } + + return typeBuilder.CreateType(); + } + + #endregion + + #region DelegateSignature implementation + + public struct DelegateSignature + { + private Type _returnType; + private Type[] _parameterTypes; + + public Type ReturnType + { + get { return _returnType; } + } + + public Type[] ParameterTypes + { + get { return _parameterTypes; } + } + + public DelegateSignature(Type returnType, Type[] parameterTypes) + { + _returnType = returnType; + _parameterTypes = parameterTypes; + } + + public override string ToString() + { + StringBuilder sb = new StringBuilder(); + foreach (Type parameter in _parameterTypes) + { + sb.Append(parameter.Name); + sb.Append("To"); + } + sb.Append(_returnType.Name); + return sb.ToString(); + } + + public static DelegateSignature FromDelegateType(Type delegateType) + { + MethodInfo invokeMethod = delegateType.GetMethod("Invoke"); + return new DelegateSignature( + invokeMethod.ReturnType, + Util.MapParametersToTypes(invokeMethod.GetParameters())); + } + + #region Delegate creation + + /// + /// Maintains a cache of the delegate types that have been generated. + /// + private static Dictionary _delegateTypes = + new Dictionary(); + + /// + /// Returns (after creating, if necessary) a delegate type of the given type signature. + /// + public Type ToDelegateType() + { + string delegateName = ToString() + "Delegate"; + lock (_delegateTypes) + { + Type type; + if (!_delegateTypes.TryGetValue(delegateName, out type)) + { + // Could not find delegate of appropriate type in the cache: create one + type = CreateDelegateType(delegateName); + _delegateTypes.Add(delegateName, type); + } + return type; + } + } + + private void ApplyMarshalAsAttribute(Type type, int paramIndex, MethodBuilder methodBuilder) + { + if (type == null) + return; + else if (type == typeof(string)) + { + ParameterBuilder pb = methodBuilder.DefineParameter(paramIndex, ParameterAttributes.None, null); + pb.SetCustomAttribute( + new CustomAttributeBuilder( + typeof(MarshalAsAttribute).GetConstructor(new Type[] { typeof(UnmanagedType) }), + new object[] { UnmanagedType.BStr } + ) + ); + } + } + + /// + /// Dynamically creates (and returns the type of) a delegate class with the given + /// name and type signature. + /// + private Type CreateDelegateType(string name) + { + TypeBuilder typeBuilder = Driver._dynamicModuleBuilder.DefineType(name, + TypeAttributes.Class | TypeAttributes.Public | + TypeAttributes.Sealed | TypeAttributes.AnsiClass | + TypeAttributes.AutoClass, typeof(System.MulticastDelegate)); + + // Add a '[UnmanagedFunctionPointer(CallingConvention.Cdecl)]' attribute to the delegate + typeBuilder.SetCustomAttribute(new CustomAttributeBuilder( + typeof(UnmanagedFunctionPointerAttribute).GetConstructor(new Type[] { typeof(CallingConvention) }), + new object[] { CallingConvention.Cdecl })); + + ConstructorBuilder constructorBuilder = typeBuilder.DefineConstructor( + MethodAttributes.RTSpecialName | MethodAttributes.HideBySig | + MethodAttributes.Public, CallingConventions.Standard, + new Type[] { typeof(object), typeof(System.IntPtr) }); + constructorBuilder.SetImplementationFlags(MethodImplAttributes.Runtime | MethodImplAttributes.Managed); + + MethodBuilder methodBuilder = typeBuilder.DefineMethod("Invoke", MethodAttributes.Public | + MethodAttributes.HideBySig | MethodAttributes.NewSlot | + MethodAttributes.Virtual, + ReturnType, ParameterTypes); + methodBuilder.SetImplementationFlags(MethodImplAttributes.Runtime | MethodImplAttributes.Managed); + + // For the return type and any parameter types + for (int i = 0; i < ParameterTypes.Length + 1; i++) + { + Type currentParam; + if (i == 0) + currentParam = ReturnType; + else + currentParam = ParameterTypes[i - 1]; + + ApplyMarshalAsAttribute(currentParam, i, methodBuilder); + } + return typeBuilder.CreateType(); + } + + #endregion + } + + #endregion + + private static Dictionary LoadedAssemblies = new Dictionary(); + + /// Helper function to load an assembly from bytes + public static Assembly LoadAssemblyFromBytes(IntPtr ptr, int len) { + byte[] bytes = new byte[len]; + Marshal.Copy(ptr,bytes,0,len); + Assembly res = System.Reflection.Assembly.Load(bytes, null, System.Security.SecurityContextSource.CurrentAppDomain); + LoadedAssemblies.Add(res.GetName().FullName, res); + return res; + } + + private static Assembly GetLoadedAssembly(AssemblyName assName) { + Assembly a; + if (LoadedAssemblies.TryGetValue(assName.FullName, out a)) + return a; + else{ + 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))); + } + } + 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); + return t; + } + + public static Type[] StringToTypes(string s) + { + return Util.MapArray(delegate(string t) + { return StringToType(t); }, + s.Split(new char[] { ';' }, StringSplitOptions.RemoveEmptyEntries)); + } + } + + /// + /// A delegate for the signature of the Haskell function 'freeHaskellFunPtr'. + /// + [UnmanagedFunctionPointer(CallingConvention.Cdecl)] + public delegate void FreeHaskellFunPtrDelegate(IntPtr funPtr); + + /// + /// A delegate for code the emits IL instructions on demand. + /// + public delegate void ILWriterDelegate(ILGenerator ilg); + + /// + /// Stores references to commonly used reflection object instances. + /// + internal static class MemberInfos + { + public static readonly MethodInfo Type_GetTypeFromHandle = + typeof(Type).GetMethod("GetTypeFromHandle"); + + public static readonly ConstructorInfo Object_ctor = + typeof(object).GetConstructor(Type.EmptyTypes); + + public static readonly MethodInfo Marshal_GetDelegateForFunctionPointer = + typeof(Marshal).GetMethod("GetDelegateForFunctionPointer", new Type[] { typeof(IntPtr), typeof(Type) }); + + public static readonly MethodInfo Marshal_GetFunctionPointerForDelegate = + typeof(Marshal).GetMethod("GetFunctionPointerForDelegate", new Type[]{ typeof(Delegate) }); + + public static readonly MethodInfo Marshal_StringToHGlobalUni = + typeof(Marshal).GetMethod("StringToHGlobalUni"); + + public static readonly MethodInfo Marshal_StringToHGlobalAnsi = + typeof(Marshal).GetMethod("StringToHGlobalAnsi"); + + public static readonly FieldInfo Driver_FreeHaskellFunPtr = + typeof(Driver).GetField("FreeHaskellFunPtr", BindingFlags.Static | BindingFlags.Public); + + public static readonly MethodInfo Driver_RegisterObject = + typeof(Driver).GetMethod("RegisterObject", BindingFlags.Static | BindingFlags.Public); + + public static readonly MethodInfo Driver_GetObject = + typeof(Driver).GetMethod("GetObject", BindingFlags.Static | BindingFlags.Public); + + public static readonly MethodInfo FreeHaskellFunPtrDelegate_Invoke = + typeof(FreeHaskellFunPtrDelegate).GetMethod("Invoke"); + } + + internal static class Util + { + + public static T[] ConcatArray(T[] a, T[] b) + { + T[] r = new T[a.Length + b.Length]; + for (int i = 0; i < a.Length; i++) + r[i] = a[i]; + for (int i = 0; i < b.Length; i++) + r[a.Length + i] = b[i]; + return r; + } + + public static T[] ConcatArray(T x, T[] b) + { + T[] r = new T[1 + b.Length]; + r[0] = x; + for (int i = 0; i < b.Length; i++) + r[1 + i] = b[i]; + return r; + } + + public static B[] MapArray(Func f, A[] xs) + { + B[] r = new B[xs.Length]; + for (int i = 0; i < xs.Length; i++) + r[i] = f(xs[i]); + return r; + } + + public delegate B Func(A x1); + + public static Type[] MapParametersToTypes(ParameterInfo[] parameters) + { + return MapArray( + delegate(ParameterInfo p) { return p.ParameterType; }, + parameters); + } + + public static void EmitLdarg(ILGenerator ilg, int argumentIndex) + { + if (argumentIndex == 0) ilg.Emit(OpCodes.Ldarg_0); + else if (argumentIndex == 1) ilg.Emit(OpCodes.Ldarg_1); + else if (argumentIndex == 2) ilg.Emit(OpCodes.Ldarg_2); + else if (argumentIndex == 3) ilg.Emit(OpCodes.Ldarg_3); + else if (argumentIndex <= 255) ilg.Emit(OpCodes.Ldarg_S, (byte)argumentIndex); + else ilg.Emit(OpCodes.Ldarg, (int)argumentIndex); + } + + } +} diff --git a/src/clrHost.c b/src/clrHost.c new file mode 100644 --- /dev/null +++ b/src/clrHost.c @@ -0,0 +1,13 @@ + +void * global_getPointerToMethod; + +void getPointerToMethod_set(void * getPointerToMethod) +{ + global_getPointerToMethod = getPointerToMethod; +} + +void * getPointerToMethod_get() +{ + return global_getPointerToMethod; +} + diff --git a/src/dotNetHost.c b/src/dotNetHost.c new file mode 100644 --- /dev/null +++ b/src/dotNetHost.c @@ -0,0 +1,20 @@ + +void * global_ICorRuntimeHost; +void * global_ICLRRuntimeHost; + +void setHostRefs(void * ICorRuntimeHost, void * ICLRRuntimeHost) +{ + global_ICorRuntimeHost = ICorRuntimeHost; + global_ICLRRuntimeHost = ICLRRuntimeHost; +} + +void * getICorRuntimeHost() +{ + return global_ICorRuntimeHost; +} + +void * getICLRRuntimeHost() +{ + return global_ICLRRuntimeHost; +} + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented."