packages feed

clr-host (empty) → 0.1.0.0

raw patch · 20 files changed

+2263/−0 lines, 20 filesdep +Win32dep +basedep +bytestringbuild-type:Customsetup-changed

Dependencies added: Win32, base, bytestring, clr-host, file-embed

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -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 }+
+ clr-host.cabal view
@@ -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
+ src/Clr/Host.hs view
@@ -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"+
+ src/Clr/Host/BStr.hs view
@@ -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++
+ src/Clr/Host/BStr/DotNet.hs view
@@ -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)+
+ src/Clr/Host/BStr/Mono.hs view
@@ -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 ()+
+ src/Clr/Host/BStr/Type.hs view
@@ -0,0 +1,7 @@+module Clr.Host.BStr.Type where++import Data.Word+import Foreign.Ptr++newtype BStr = BStr (Ptr Word16) deriving (Show)+
+ src/Clr/Host/Config.hs view
@@ -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+
+ src/Clr/Host/DotNet.hs view
@@ -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)+++
+ src/Clr/Host/DotNet/Common.hs view
@@ -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+
+ src/Clr/Host/DotNet/Guid.hs view
@@ -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+
+ src/Clr/Host/DotNet/SafeArray.hs view
@@ -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+
+ src/Clr/Host/DotNet/Variant.hs view
@@ -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+
+ src/Clr/Host/Driver.hs view
@@ -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)+
+ src/Clr/Host/Mono.hs view
@@ -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 ()++
+ src/Driver.cs view
@@ -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");+        }++        /// <summary>+        /// Returns a native function pointer (as an int) to a stub wrapping the given method.+        /// </summary>+        /// <remarks>+        /// This is the first .NET function called by Haskell, and is called by using the+        /// ICLRRuntimeHost.ExecuteInDefaultAppDomain method.+        /// </remarks>+        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++        /// <summary>+        /// This method is called by Haskell so that the .NET side of the bridge+        /// has access to the Haskell function 'freeHaskellFunPtr'.+        /// </summary>+        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;++        /// <summary>+        /// Saves the assembly containing the dynamically generated wrapper methods and+        /// delegate classes created during the bridge operation.+        /// </summary>+        public static void SaveDynamicAssembly()+        {+            _stubsTypeBuilder.CreateType();++            string fileName = Path.GetFileName(_dynamicModuleBuilder.FullyQualifiedName);+            Console.WriteLine("Saving dynamic assembly: " + fileName);+            _assemblyBuilder.Save(fileName);+        }++        /// <summary>+        /// 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.+        /// </summary>+        /// <remarks>+        /// Use a 'methodName' of '.ctor' to obtain a constructor stub.+        /// </remarks>+        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);+            }+        }++        /// <summary>+        /// 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.+        /// </summary>+        public static IntPtr GetDelegateConstructorStub(string delegateTypeName)+        {+            Type delegateType = StringToType(delegateTypeName);+            return GenerateDelegateConstructorStub(delegateType);+        }++        /// <summary>+        /// 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.+        /// </summary>+        public static IntPtr GetFieldGetStub(string className, string fieldName)+        {+            FieldInfo field = StringToType(className).GetField(fieldName);+            return GenerateFieldGetStub(field);+        }++        /// <summary>+        /// 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.+        /// </summary>+        public static IntPtr GetFieldSetStub(string className, string fieldName)+        {+            FieldInfo field = StringToType(className).GetField(fieldName);+            return GenerateFieldSetStub(field);+        }++        /// <summary>+        /// Given a value type, returns a native function pointer to a method that+        /// boxes values of the given value type.+        /// </summary>+        public static IntPtr GetBoxStub(string typeName)+        {+            Type typeToBox = StringToType(typeName);+            return GenerateBoxStub(typeToBox);+        }++        #endregion++        #region Foreign object references (object in-table)++        /// <summary>+        /// 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.+        /// </summary>+        static Dictionary<long, object> _inTable = new Dictionary<long, Object>();++        static long _nextId = 1;++        /// <summary>+        /// Registers the given object in the 'in table' and returns the object id+        /// that was assigned to it.+        /// </summary>+        public static long RegisterObject(object o)+        {+            if (o == null)+                return 0;++            if (o is bool?) // HACK for Nullable<bool>+            {+                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)++        /// <summary>+        /// 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.+        /// </summary>+        private static Dictionary<IntPtr, Delegate> _dotNetFunPtrDelegates = new Dictionary<IntPtr, Delegate>();++        /// <summary>+        /// 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.+        /// </summary>+        private static IntPtr GetDotNetFunPtrForDelegate(Delegate d) // TODO: Perhaps rename 'RegisterDelegate'+        {+            IntPtr funPtr = Marshal.GetFunctionPointerForDelegate(d);+            lock (_dotNetFunPtrDelegates)+                _dotNetFunPtrDelegates.Add(funPtr, d);+            return funPtr;+        }++        /// <summary>+        /// 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.+        /// </summary>+        public static void FreeDotNetFunPtr(IntPtr funPtr) // TODO: Perhaps rename 'ReleaseDelegate'+        {+            lock (_dotNetFunPtrDelegates)+                _dotNetFunPtrDelegates.Remove(funPtr);+        }++        #endregion++        #region Stub method generation++        /// <summary>+        /// 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.+        /// </summary>+        /// <remarks>+        /// This method also writes the method to the 'Stubs' class in 'Dynamic.dll' for debugging+        /// purposes.+        /// </remarks>+        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()));+        }++        /// <summary>+        /// 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).+        /// </summary>+        /// <remarks>+        /// 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).+        /// </remarks>+        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);+                });+        }++        /// <summary>+        /// Returns a native function pointer to a stub method that calls the given+        /// method, marshaling arguments as necessary.+        /// </summary>+        /// <remarks>+        /// The returned function pointer should be freed with 'FreeDotNetFunPtr'.+        /// </remarks>+        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<Type>(+                        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);+                });+        }++        /// <summary>+        /// 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).+        /// </summary>+        /// <param name="delegateType">Type of delegate returned by the returned delegate.</param>+        /// <returns>+        /// Wrapper delegate that accepts an IntPtr and returns a delegate of the+        /// indicated type.+        /// </returns>+        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);+                });+        }++        /// <summary>+        /// Returns a native function pointer to a stub method that retrieves the value+        /// of the given static or instance field.+        /// </summary>+        /// <remarks>+        /// The returned function pointer should be freed with 'FreeDotNetFunPtr'.+        /// </remarks>+        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);+                });+        }++        /// <summary>+        /// Returns a native function pointer to a stub method that sets the value+        /// of the given static or instance field.+        /// </summary>+        /// <remarks>+        /// The returned function pointer should be freed with 'FreeDotNetFunPtr'.+        /// </remarks>+        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);+                });+        }++        /// <summary>+        /// Returns a native function pointer to a stub method that returns a+        /// reference to the given value (boxing value types as necessary).+        /// </summary>+        /// <remarks>+        /// The returned function pointer should be freed with 'FreeDotNetFunPtr'.+        /// </remarks>+        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;++        /// <summary>+        /// Given an array of parameters (say of a constructor, or method), returns the+        /// array of types that a corresponding wrapper stub would accept.+        /// </summary>+        private static Type[] ConvertToStubTypes(Type[] types)+        {+            return Util.MapArray<Type, Type>(ConvertToStubType, types);+        }++        private static Type ConvertToStubType(Type type)+        {+            if (IsMarshaledByIndex(type))+                return typeof(Int64);+            else+                return type;+        }++        /// <summary>+        /// 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.+        /// </summary>+        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+        /// <summary>+        /// Emits code to convert a value on the stack from a stub type to the associated+        /// 'real' .NET type.+        /// </summary>+        /// <remarks>+        /// 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.+        /// </remarks>+        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+            }+        }++        /// <summary>+        /// 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.+        /// </summary>+        private static void EmitParameterLoading(ILGenerator ilg, int startingArgument,+            IEnumerable<ParameterInfo> 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+            }+        }++        /// <summary>+        /// 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.+        /// </summary>+        private static void EmitMarshaledReturn(ILGenerator ilg, ParameterInfo returnParameterInfo)+        {+            Type parameterType = returnParameterInfo.ParameterType;+            EmitToStub(ilg, parameterType);+            ilg.Emit(OpCodes.Ret);+        }++        #endregion++        #region Delegate wrappers++        /// <summary>+        /// Maintains a cache of the delegate wrapper types that have been generated.+        /// </summary>+        private static Dictionary<string, Type> _delegateWrapperTypes =+            new Dictionary<string, Type>();++        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;+            }+        }++        /// <summary>+        /// 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).+        /// </summary>+        /// <param name="delegateType">Type of delegate produced by the wrapper</param>+        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++            /// <summary>+            /// Maintains a cache of the delegate types that have been generated.+            /// </summary>+            private static Dictionary<string, Type> _delegateTypes =+                new Dictionary<string, Type>();++            /// <summary>+            /// Returns (after creating, if necessary) a delegate type of the given type signature.+            /// </summary>+            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 }+                        )+                    );+                }+            }++            /// <summary>+            /// Dynamically creates (and returns the type of) a delegate class with the given+            /// name and type signature.+            /// </summary>+            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<String, Assembly> LoadedAssemblies = new Dictionary<String, Assembly>();++        /// 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<string, Type>(delegate(string t)+                                               { return StringToType(t); },+                                               s.Split(new char[] { ';' }, StringSplitOptions.RemoveEmptyEntries));+        }+    }++    /// <summary>+    /// A delegate for the signature of the Haskell function 'freeHaskellFunPtr'.+    /// </summary>+    [UnmanagedFunctionPointer(CallingConvention.Cdecl)]+    public delegate void FreeHaskellFunPtrDelegate(IntPtr funPtr);++    /// <summary>+    /// A delegate for code the emits IL instructions on demand.+    /// </summary>+    public delegate void ILWriterDelegate(ILGenerator ilg);++    /// <summary>+    /// Stores references to commonly used reflection object instances.+    /// </summary>+    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>(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>(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<A, B>(Func<A, B> 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, B>(A x1);++        public static Type[] MapParametersToTypes(ParameterInfo[] parameters)+        {+            return MapArray<ParameterInfo, Type>(+                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);+        }++    }+}
+ src/clrHost.c view
@@ -0,0 +1,13 @@++void * global_getPointerToMethod;++void getPointerToMethod_set(void * getPointerToMethod)+{+  global_getPointerToMethod = getPointerToMethod;+}++void * getPointerToMethod_get()+{+  return global_getPointerToMethod;+}+
+ src/dotNetHost.c view
@@ -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;+}+
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented."