From box at dupuislogiciels.com  Mon Nov 27 19:22:41 2006
From: box at dupuislogiciels.com (box at dupuislogiciels.com)
Date: Mon, 27 Nov 2006 19:22:41 +0100
Subject: [Rd] R.DLL mapping by P/Invoke
Message-ID: <courier.456B2CF1.00007A11@wormhole.dupuislogiciels.com>

After a long processing, I was able to create a version of a small C# class 
that was able to emulate the rproxy by P/Invoke. This is mostly to find a 
workaround a performance problem of the StatConnector. 

It's almost work but ... I have strange memory exception when I call the 
print function. The variable seems to not survive from one call to the 
other. 

As there is no debug symbol for the R.DLL (and I don't want to spend my 
youth on the disassembly window of VS), I put there the result of my search. 
If some of you can find the reason of the crash, I will be extremely happy! 

Here is a sample program.cs to invoke the DLL (and crash) : 

using System;
using System.Collections;
using System.Text; 

namespace SharpR
{
   class Program
   {
       static void Main(string[] args)
       {
           RWrapper.EvaluateNoReturn("print(\"Boom!\")");
       }
   }
} 


-------------- next part --------------
#define SUPERCONSOLE

using System;
using System.Collections;
using System.Runtime.InteropServices;
using System.Text;
using Microsoft.Win32;

namespace SharpR
{
    /// <summary>
    /// Class for interp with the R.DLL. All is static as R is mono-threaded.
    /// </summary>
    class RWrapper
    {
        #region <R.DLL interop signatures>
        //- DLL Management/Information
        [DllImport("R.DLL", /*CallingConvention = CallingConvention.Cdecl,*/ CharSet = CharSet.Ansi)]
        [return: MarshalAs(UnmanagedType.LPStr)]
        static extern string getDLLVersion();
        [DllImport("R.DLL", /*CallingConvention = CallingConvention.Cdecl,*/ CharSet = CharSet.Ansi)]
        [return: MarshalAs(UnmanagedType.LPStr)]
        static extern string get_R_HOME();
        [DllImport("R.DLL", /*CallingConvention = CallingConvention.Cdecl,*/ CharSet = CharSet.Ansi)]
        [return: MarshalAs(UnmanagedType.LPStr)]
        static extern string getRUser();

        //- R Start Up
        [DllImport("R.DLL", /*CallingConvention = CallingConvention.Cdecl,*/ CharSet = CharSet.Ansi)]
        static extern void R_setStartTime();
        [DllImport("R.DLL", /*CallingConvention = CallingConvention.Cdecl,*/ CharSet = CharSet.Ansi)]
        static extern void R_DefParams(ref RStartStruct @params);
        [DllImport("R.DLL", /*CallingConvention = CallingConvention.Cdecl,*/ CharSet = CharSet.Ansi)]
        static extern void R_SetParams(ref RStartStruct @params);
        [DllImport("R.DLL", /*CallingConvention = CallingConvention.Cdecl,*/ CharSet = CharSet.Ansi)]
        static extern void R_set_command_line_arguments(int argc, string[] args);
        [DllImport("R.DLL", /*CallingConvention = CallingConvention.Cdecl,*/ CharSet = CharSet.Ansi)]
        static extern int GA_initapp(int argc, string[] args);
        [DllImport("R.DLL", /*CallingConvention = CallingConvention.Cdecl,*/ CharSet = CharSet.Ansi)]
        static extern void readconsolecfg();
        [DllImport("R.DLL", /*CallingConvention = CallingConvention.Cdecl,*/ CharSet = CharSet.Ansi)]
        static extern void setup_Rmainloop();
        [DllImport("R.DLL", /*CallingConvention = CallingConvention.Cdecl,*/ CharSet = CharSet.Ansi)]
        static extern void R_ReplDLLinit();
        
        //- R SEXP management
        [DllImport("R.DLL", /*CallingConvention = CallingConvention.Cdecl,*/ CharSet = CharSet.Ansi)]
        static extern IntPtr Rf_mkString(string toConvert);
        [DllImport("R.DLL", /*CallingConvention = CallingConvention.Cdecl,*/ CharSet = CharSet.Ansi)]
        static extern IntPtr Rf_protect(IntPtr ptr);
        [DllImport("R.DLL", /*CallingConvention = CallingConvention.Cdecl,*/ CharSet = CharSet.Ansi)]
        static extern void Rf_unprotect(int l);
        [DllImport("R.DLL", /*CallingConvention = CallingConvention.Cdecl,*/ CharSet = CharSet.Ansi)]
        static extern void Rf_unprotect_ptr(IntPtr ptr);

        //- R Parser/Eval
        [DllImport("R.DLL", /*CallingConvention = CallingConvention.Cdecl,*/ CharSet = CharSet.Ansi)]
        static extern IntPtr R_ParseVector(IntPtr str, int x, out RParseStatus result);
        [DllImport("R.DLL", /*CallingConvention = CallingConvention.Cdecl,*/ CharSet = CharSet.Ansi)]
        static extern IntPtr R_tryEval(IntPtr exp, IntPtr env, out int evalError);
        
        //- R Symbols
        [DllImport("R.DLL", /*CallingConvention = CallingConvention.Cdecl,*/ CharSet = CharSet.Ansi)]
        static extern IntPtr Rf_install(string name);
        [DllImport("R.DLL", /*CallingConvention = CallingConvention.Cdecl,*/ CharSet = CharSet.Ansi)]
        static extern IntPtr Rf_findVar(IntPtr symbol, IntPtr env);
        [DllImport("R.DLL", /*CallingConvention = CallingConvention.Cdecl,*/ CharSet = CharSet.Ansi)]
        static extern void Rf_setVar(IntPtr symbol, IntPtr value, IntPtr env);

        #endregion

        #region <R.DLL interop types>
        enum RParseStatus
        {
            PARSE_NULL,
            PARSE_OK,
            PARSE_INCOMPLETE,
            PARSE_ERROR,
            PARSE_EOF
        };        
        
        enum SaType
        {
            SA_NORESTORE = 0,/* = 0 */
            SA_RESTORE,
            SA_DEFAULT,/* was === SA_RESTORE */
            SA_NOSAVE,
            SA_SAVE,
            SA_SAVEASK,
            SA_SUICIDE
        };
        enum RBool
        {
            RFalse = 0,
            RTrue
        };
        enum RYesNoCancel
        {
            Yes = 1,
            No = -1,
            Cancel = 0
        };
        enum RUIMode
        {
            RGui = 0, RTerm, LinkDLL
        };
        [StructLayout(LayoutKind.Sequential)]
        struct RStartStruct
        {
            public RBool R_Quiet;
            public RBool R_Slave;
            public RBool R_Interactive;
            public RBool R_Verbose;
            public RBool LoadSiteFile;
            public RBool LoadInitFile;
            public RBool DebugInitFile;
            public SaType RestoreAction;
            public SaType SaveAction;
            public uint vsize;
            public uint nsize;
            public uint max_vsize;
            public uint max_nsize;
            public uint ppsize;
            public int NoRenviron;
            //!! Warning - R will keep theses pointers. See gnuwin32\system.c (line 638)
            public IntPtr home;
            public IntPtr rhome;
            //!!
            [MarshalAs(UnmanagedType.FunctionPtr)]
            public dgReadConsole readConsole;
            [MarshalAs(UnmanagedType.FunctionPtr)]
            public dgWriteConsole writeConsole;
            [MarshalAs(UnmanagedType.FunctionPtr)]
            public dgCallback callback;
            [MarshalAs(UnmanagedType.FunctionPtr)]
            public dgShowMessage showMessage;
            [MarshalAs(UnmanagedType.FunctionPtr)]
            public dgYesNoCancel yesNoCancel;
            [MarshalAs(UnmanagedType.FunctionPtr)]
            public dgBusy busy;
            public RUIMode characterMode;
        };

        //[UnmanagedFunctionPointer(CallingConvention.Cdecl)] < .Net 2.0
        delegate int dgReadConsole(
            [MarshalAs(UnmanagedType.LPStr)]string prompt,
           IntPtr buf, int len,
           int addtohistory
        );
        //[UnmanagedFunctionPointer(CallingConvention.Cdecl)] < .Net 2.0
        delegate void dgWriteConsole(
            [MarshalAs(UnmanagedType.LPStr,SizeParamIndex = 1)]
            string buf, int len);
        //[UnmanagedFunctionPointer(CallingConvention.Cdecl)] < .Net 2.0
        delegate void dgCallback();
        //[UnmanagedFunctionPointer(CallingConvention.Cdecl)] < .Net 2.0
        delegate void dgShowMessage(string msg);
        //[UnmanagedFunctionPointer(CallingConvention.Cdecl)] < .Net 2.0
        [return: MarshalAs(UnmanagedType.I4)]
        delegate RYesNoCancel dgYesNoCancel(string msg);
        //[UnmanagedFunctionPointer(CallingConvention.Cdecl)] < .Net 2.0
        delegate void dgBusy(int which);        
        
        #endregion

        #region <BDX Interops frm RPROXY.DLL>
  /*      const string strBdxGetObject = "BDX_get_vtbl at 8";

        /// <summary>
        /// PInvoke with automatic marshal on GetProcAddress to return dgScProxyGetObject function
        /// </summary>
        /// <param name="hModule">HMODULE of the RPROXY.DLL</param>
        /// <param name="procName">*MUST* be strScProxyGetObject</param>
        /// <returns></returns>
        [DllImport("kernel32.dll", CharSet = CharSet.Ansi, EntryPoint = "GetProcAddress")]
        [return: MarshalAs(UnmanagedType.FunctionPtr)]
        static extern dgBdxGetObject GetPABdxGetObject(IntPtr hModule, string procName);

        delegate int dgBdxGetObject(out IntPtr vtable, uint value);

        delegate void BdxFree(IntPtr bdx);
        delegate void BdxTrace(IntPtr bdx);
        delegate int BdxVariant2BDX([MarshalAs(UnmanagedType.Struct)]object var, out IntPtr bdx);
        delegate int BdxBDX2Variant(IntPtr bdx, [MarshalAs(UnmanagedType.Struct)]out object var);

        [StructLayout(LayoutKind.Sequential)]
        struct RBdxVtable
        {
            public BdxFree free;
            public BdxTrace trace;
            public BdxVariant2BDX v2bdx;
            public BdxBDX2Variant bdx2v;
        } */

        [DllImport("Rproxy.DLL", CallingConvention = CallingConvention.Cdecl)]
        static extern int BDX2SEXP(IntPtr pBDXData, out IntPtr pSEXPData);
        [DllImport("Rproxy.dll", CallingConvention = CallingConvention.Cdecl)]
        static extern int SEXP2BDX(IntPtr pSexp, out IntPtr ppBDXData);
        [DllImport("Rproxy.dll", EntryPoint = "Variant2BDX at 20")]
        static extern int Variant2BDX([MarshalAs(UnmanagedType.Struct)]object var, out IntPtr bdx);
        [DllImport("Rproxy.dll", EntryPoint = "BDX2Variant at 8")]
        static extern int BDX2Variant(IntPtr bdx,[MarshalAs(UnmanagedType.Struct)]out object var);
        [DllImport("Rproxy.dll", EntryPoint = "bdx_free at 4")]
        static extern void bdx_free(IntPtr bdx);
        #endregion


        #region <Win32 interop signatures>
        [DllImport("kernel32.dll")]
        static extern IntPtr LoadLibrary(string lpFileName);
        [DllImport("kernel32.dll", CharSet = CharSet.Ansi, ExactSpelling = true)]
        public static extern IntPtr GetProcAddress(IntPtr hModule, string procName);
        #endregion

        static string sg_dllVersion,sg_RHome,sg_RUsersHome;
        static IntPtr sg_hModR;
        static IntPtr sg_hModRProxy;
        static StringBuilder sg_ConsoleOutput;

        static IntPtr sg_rDll_R_GlobalEnvPtr, sg_rDll_R_UserBreakPtr;
        static IntPtr sg_rDll_R_UnboundValue;

        static GCHandle[] sg_lockDelegates;

        static RWrapper()
        {
            try {
            //- Get the active DLL path from the registry
            string dllPath = Convert.ToString(
                Registry.LocalMachine.OpenSubKey("Software\\R-core\\R", false).GetValue("InstallPath")
             );
            //- Fix the process PATH
            Environment.SetEnvironmentVariable("PATH",
                dllPath + "\\bin;" + Environment.GetEnvironmentVariable("PATH"),
                EnvironmentVariableTarget.Process
            );
            
            //- Load the R.DLL module into the process
            sg_hModR = LoadLibrary(dllPath + "\\bin\\R.dll");
            if (sg_hModR == IntPtr.Zero) throw new Exception("Unable to load R.DLL");
            //- Load the Rproxy.DLL module into the process
            sg_hModRProxy = LoadLibrary(dllPath + "\\bin\\Rproxy.dll");
            if (sg_hModRProxy == IntPtr.Zero) throw new Exception("Unable to load R.DLL");
            
            //- Read the DLL version by Interop
            sg_dllVersion = getDLLVersion();

            //- Get important R global variable pointers from GetProcAddress
            sg_rDll_R_GlobalEnvPtr = GetProcAddress(sg_hModR, "R_GlobalEnv");
            sg_rDll_R_UserBreakPtr = GetProcAddress(sg_hModR, "UserBreak");
            sg_rDll_R_UnboundValue = GetProcAddress(sg_hModR, "R_UnboundValue");

            //- Output DLL
            sg_ConsoleOutput = new StringBuilder();
            
            //- Let's start R
            RStartStruct start = new RStartStruct();

            //- Get Defaults
            R_setStartTime();
            R_DefParams(ref start);

            sg_RHome = get_R_HOME();
            sg_RUsersHome = getRUser();

            //- Inject R Home
            start.home = Marshal.StringToHGlobalAnsi(sg_RHome);
            start.rhome = Marshal.StringToHGlobalAnsi(sg_RUsersHome);

            //- Setup R in embedded/batch mode
            start.characterMode = RUIMode.LinkDLL;
            start.R_Quiet = RBool.RTrue;
            start.R_Interactive = RBool.RTrue;
            start.RestoreAction = SaType.SA_RESTORE;
            start.SaveAction = SaType.SA_NOSAVE;

            //- Setup the callbacks
            start.readConsole = new dgReadConsole(cbReadConsole);
            start.writeConsole = new dgWriteConsole(cbWriteConsole);
            start.busy = new dgBusy(cbBusy);
            start.callback = new dgCallback(cbCallback);
            start.showMessage = new dgShowMessage(cbShowMessage);
            start.yesNoCancel = new dgYesNoCancel(cbYesNoCancel);

            sg_lockDelegates = new GCHandle[7];
            sg_lockDelegates[0] = GCHandle.Alloc(start.readConsole);
            sg_lockDelegates[1] = GCHandle.Alloc(start.writeConsole);
            sg_lockDelegates[2] = GCHandle.Alloc(start.busy);
            sg_lockDelegates[3] = GCHandle.Alloc(start.callback);
            sg_lockDelegates[4] = GCHandle.Alloc(start.showMessage);
            sg_lockDelegates[5] = GCHandle.Alloc(start.yesNoCancel);
            sg_lockDelegates[6] = GCHandle.Alloc(start);
                
            //- Gentleman start your engines !
            R_SetParams(ref start);
            R_set_command_line_arguments(0, new string[] { });
            GA_initapp(0, new string[] { });
            readconsolecfg();
            setup_Rmainloop();
            R_ReplDLLinit();
        } catch(Exception e)
        {
            throw;
        }
        }
        private RWrapper() {}
        
        static int UserBreak
        {
            get
            {
                return Marshal.ReadInt32(sg_rDll_R_UserBreakPtr);
            }
            set
            {
                Marshal.WriteInt32(sg_rDll_R_UserBreakPtr,value);
            }
        }

        static public string RDllVersion { get { return sg_dllVersion; } }
        static public string RHome { get { return sg_RHome; } }
        static public string RUsersHome { get { return sg_RUsersHome; } }

        #region <R Callbacks>
        static int cbReadConsole(string prompt, IntPtr buf, int len, int addtohistory)
        {
            //- We don't use the console to interact with R. The function returns 0
            //  to force R exiting any event loop.
            return 0;
        }

        static void cbWriteConsole(string buf, int len)
        {
           sg_ConsoleOutput.Append(buf);
#if SUPERCONSOLE            
            ConsoleColor c = Console.ForegroundColor;
            Console.ForegroundColor = ConsoleColor.Green;
            Console.Write(buf);
            Console.ForegroundColor = c;
#endif
        }

        static void cbCallback() { /*NoOp*/ }

        static void cbBusy(int which)
        {
#if SUPERCONSOLE            
            int top = Console.CursorTop, left = Console.CursorLeft;
            Console.CursorTop = Console.CursorLeft = 0;
            Console.Write("Busy : {0}", which);
            Console.CursorTop = top; Console.CursorLeft = left;
#endif
        }

        static void cbShowMessage(string msg)
        {
            Console.WriteLine("Message : " + msg);
        }

        static RYesNoCancel cbYesNoCancel(string msg)
        {
            Console.WriteLine("YesNoCancel : " + msg);
            return RYesNoCancel.Cancel;
        }
        #endregion
        
        static IntPtr GetCurrentEnv()
        {
            IntPtr ret =  Marshal.ReadIntPtr(sg_rDll_R_GlobalEnvPtr);
            return ret;
        }
        
        static bool IsUnbound(IntPtr Sexp)
        {
            IntPtr unbound = Marshal.ReadIntPtr(sg_rDll_R_UnboundValue);
            return Sexp == unbound;
        }
        
        static public void EvaluateNoReturn(string statement)
        {
            //- Parse the expresion
            RParseStatus status;
            IntPtr lSexpVect = R_ParseVector(Rf_mkString(statement), 1, out status);
            if(status!=RParseStatus.PARSE_OK)
            {
                throw new Exception("R Parse Error : " + status.ToString());
            }

            Rf_protect(lSexpVect);
            // lSexpVect is a vector of lSexp. We need to read the memory directly to get
            // the lSexp
            int evalError;
            IntPtr lSexp = Marshal.ReadIntPtr(lSexpVect, 24);
            R_tryEval(lSexp, IntPtr.Zero, out evalError);
            Rf_unprotect(1);

            if (evalError != 0) throw new Exception("R Eval Error : " + evalError.ToString());
        }
        
        static public object Evaluate(string statement)
        {
            //- Parse the expresion
            RParseStatus status;
            IntPtr lSexpVect = R_ParseVector(Rf_mkString(statement), 1, out status);
            if (status != RParseStatus.PARSE_OK)
            {
                throw new Exception("R Parse Error : " + status.ToString());
            }

            Rf_protect(lSexpVect);
            // lSexpVect is a vector of lSexp. We need to read the memory directly to get
            // the lSexp
            int evalError;
            IntPtr lSexp = Marshal.ReadIntPtr(lSexpVect, 24);
            Rf_protect(lSexp);
            IntPtr lresult = R_tryEval(lSexp, GetCurrentEnv(), out evalError);
            Rf_unprotect(1);

            if (evalError != 0) throw new Exception("R Eval Error : " + evalError.ToString());

            IntPtr bdxResult;
            object result;
            evalError = SEXP2BDX(lresult, out bdxResult);
            evalError = BDX2Variant(bdxResult, out result);
            bdx_free(bdxResult);

            return result;
        }        
        
        static public object GetSymbol(string name)
        {
            IntPtr lsValue = Rf_findVar(Rf_install(name), GetCurrentEnv());
            if (IsUnbound(lsValue))
            {
                throw new Exception(name + " is an unbound value");
            }
            
            IntPtr bdxResult;
            object result;
            int evalError = SEXP2BDX(lsValue, out bdxResult);
            evalError = BDX2Variant(bdxResult, out result);
            bdx_free(bdxResult);

            return result;
        }
        
        static public void SetSymbol(string name,object value)
        {
            IntPtr bdxData, sexpData;
            int evalError = Variant2BDX(value, out bdxData);
            evalError = BDX2SEXP(bdxData, out sexpData);
            bdx_free(bdxData);
            
            IntPtr lsSymbol = Rf_install(name);
            Rf_setVar(lsSymbol, sexpData, GetCurrentEnv());
        }
        
        static public string CollectConsole()
        {
            string ret = sg_ConsoleOutput.ToString();
            sg_ConsoleOutput = new StringBuilder();
            return ret;
        }
        
    }
}


[Rd] R.DLL mapping by P/Invoke
box at dupuislogiciels.com