COM interop in Doors

Last week i’ve been working mainly on improving COM-related part of Doors.

As i have mentioned before, Doors allows two-way interoperability with COM.

This means Doors allows you not only to use external interfaces, but also to define you own COM classes, and pass their instances’ interfaces into foreign code.

As you probably know, COM is a binary standard of an object model, the core concept of which is a so-called COM-interface, which is basically a pointer to an array of functions(a so-called virtual method table). COM specification requires that the only way to gain access to the methods of an interface is through a pointer to the interface.

The specification does not mention anything about the actual object which implements an interface, therefore completely separating interface from its implementation. An interface may be a part of an actual object, which is, as far as i know, the case of Visual C++, or it may be a simple proxy, which delegates interface implementation to something else. The latter case is exactly how COM interfaces are implemented in Doors.

Every lisp-side COM object(an instance of COM-OBJECT class, or any of its descendants) holds a hash-table, which maps interface classes to pointers, each of which points to a block of memory which holds a pointer to a method table. Those blocks of memory are allocated during a call to ACQUIRE-INTERFACE function(and are allocated only once for each interface class) and deallocated inside the object’s finalizer(i.e. during the process of garbage collection). By the way, objects will not be garbage collected until their reference count reaches zero.

Instance of COM-OBJECT A hash-table A block of foreign memory -------------------- ---------------------------- ------------------------------- [ interface pointers ] ----> [ interface class metaobject ] -----> [ a pointer to the method table ] -------------------- ---------------------------- ------------------------------- [ ref-count ] [ ... ] -------------------- ---------------------------- [ other slots ] [ ... ] --------------------

Method tables are constructed inside DEFINE-INTERFACE macro. Every function inside a method table is a simple trampoline which translates arguments into lisp values and calls corresponding generic function. ‘this’ argument is translated by performing a lookup in the global hash-table which maps interface pointers to lisp objects.

Methods with HRESULT return type are treated in a special way. Trampoline establishes handlers, which translate lisp errors into HRESULT codes. Warnings are also handled, but unlike errors, they do not cause stack unwinding, allowing generic function to proceed execution.

IUnknown method table --------------------------- [ QueryInterface trampoline ] -------------> QUERY-INTERFACE generic function --------------------------- [ AddRef trampoline ] -------------> ADD-REF generic function --------------------------- [ Release trampoline ] -------------> RELEASE generic function ---------------------------

Interfaces, by the way, are also represented as CLOS objects. An interface object is a simple wrapper around a pointer. Generic functions’ methods which are specialized on interface classes perform translation of lisp values into foreign values and invoke corresponding foreign functions from the interfaces’ method tables. Those methods are defined inside DEFINE-INTERFACE macro, but you can redefine them using DEFINE-INTERFACE-METHOD.

Instance of COM-INTERFACE ------------------------- [ pointer ] -----------------> Actual COM interface ------------------------- [ other slots ] [ ... ] ------------------------- IUnknown method table ----------------------- QUERY-INTERFACE ((interface UNKNOWN) iid) -----> [ QueryInterface method ] ADD-REF ((interface UNKNOWN)) ----------> [ AddRef method ] RELEASE ((interface UNKNOWN)) ----------> [ Release method ]

Here’s an example. Registering a simple COM server, which is able to output a string to the console.

(define-interface hello-world ;;interface class name
    ((iid-hello-world
       ;;Interface identifier.
       ;;this particular guid has been generated by
       ;;DOORS.COM:CREATE-GUID function
       #xF9210244 #x38D1 #x49C0
       #xA8 #x48 #x68 #x4E #xDD #x3D #xBF #xF0)
     ;;parent interface class:
     unknown)
  ;;(defmethod hello-world ((interface hello-world)
  ;;                        &optional (string "Hello, world!"))
  ;;    ...)
  (hello-world (hresult)
      ;;(& wstring) is translated into a pointer to utf-16 string
      (string (& wstring) :optional "Hello, world!")))

;;define-guid macro defines a constant variable which holds GUID structure
(define-guid clsid-hello-world
  #xDF748DA7 #xBCB9 #x4F67
  #x8D #x32 #xF9 #xAA #x1A #xAA #x3A #xBF)

;;the actual object class
(defclass hello-world-object (com-object)
  ;;this slot is required to implement IClassFactory::LockServer
  ((locked :initform nil :accessor hwo-locked-p))
  (:metaclass com-class)
  (:clsid . clsid-hello-world))

(defmethod hello-world ((object hello-world-object)
                        &optional (string "Hello, world!"))
  (write-line string)
  ;; (values ...) form is required to support arguments of
  ;; reference types(particulary :inout and :out ones).
  ;; Every method that could be called inside a trampoline
  ;;  must return all of its arguments as multiple values
  ;;  in order that is specified in the interface definition
  (values nil string))

(defmethod lock-server ((object hello-world-object) lock)
  (if (hwo-locked-p object)
    (if lock
      (warn 'windows-status :code status-false)
      (progn (release object)
             (setf (hwo-locked-p object) nil)))
    (if lock
      (progn (add-ref object)
             (setf (hwo-locked-p object) t))
      (warn 'windows-status :code status-false)))
  (values nil lock))

(defmethod create-instance
    ((object hello-world-object) iid &optional outer)
  (if outer
    (error 'com-error :code error-not-implemented)
    (progn
      (unless (typep iid 'com-interface-class)
        (setf iid (find-interface-class iid)))
      (unless (member (class-name iid)
                      ;; HELLO-WORLD-OBJECT implements only
                      ;; IUnknown, IClassFactory and HELLO-WORLD interfaces
                      '(unknown class-factory hello-world))
        (error 'com-error :code error-no-interface))
      (let ((object (make-instance 'hello-world-object)))
        (values nil outer iid (acquire-interface object iid))))))

(defun register-server ()
  (handler-bind
    ((windows-status #'muffle-warning))
    ;;CoInitialize may return S_FALSE(0x00000001)
    (initialize))
  (let* ((object (make-instance 'hello-world-object))
         (unknown (acquire-interface object 'unknown t))
         (register (register-class-object ;;CoRegisterClassObject
                     'hello-world-object ;;CLSID
                     unknown ;;an interface pointer
                     :server ;;CLSCTX_SERVER
                     :multiple-use))) ;;REGCLS_MULTIPLEUSE
    (values register object)))

;;After calling REGISTER-SERVER we can create
;;instances of hello-world-object
;;using CoCreateInstance/CoGetClassObject
;;An example:
;(defvar *hello-world-interface* (create-com-instance ;;CoCreateInstance
;                                    'hello-world-object ;;CLSID
;                                    'hello-world ;;IID
;                                    nil
;                                    :server))
;(hello-world *hello-world-interface*) ;; outputs 'Hello, world!' to *STANDARD-OUTPUT*

This server can also be called from foreign code.
I.e.

// You'll need Microsoft Visual C++ compiler to compile this.
// cl.exe /LD doors_com_example.cpp ole32.lib
// Then you should load the library into lisp using cffi:load-foreign-library
// And then call "foo" function using cffi:foreign-funcall
// i.e. (cffi:foreign-funcall "foo" :void)
// If everything goes well, you'll notice "Hi there" message on the console
#include <stdlib.h>
#include <stdio.h>
#include <windows.h>

const CLSID CLSID_HelloWorld = {0xdf748da7, 0xbcb9, 0x4f67,
                                {0x8D, 0x32, 0xf9, 0xaa, 0x1a, 0xaa, 0x3a, 0xbf}};

const IID IID_IHelloWorld = {0xf9210244, 0x38d1, 0x49c0,
                             {0xa8, 0x48, 0x68, 0x4e, 0xdd, 0x3d, 0xbf, 0xf0}};

typedef interface IHelloWorld IHelloWorld;
extern "C++"
{
    MIDL_INTERFACE("DF748DA7-BCB9-4F67-8D32-F9AA1AAA3ABF")
    IHelloWorld : public IUnknown
    {
        public:
                virtual HRESULT STDMETHODCALLTYPE HelloWorld(
                        /* [in] */ LPCWSTR message
                        ) = 0;
    };
}

extern "C"
{
    void __declspec(dllexport) foo()
    {
        IClassFactory* factory = NULL;
        IHelloWorld* helloWorld = NULL;
        HRESULT hr = 0;
        hr = CoGetClassObject(CLSID_HelloWorld, CLSCTX_INPROC_SERVER,
                              NULL, IID_IClassFactory, (void**)&factory);
        if(FAILED(hr))
        {
            printf("Failure: %08X\n", hr);
            return;
        }
        hr = factory->CreateInstance(NULL, IID_IHelloWorld, (void**)&helloWorld);
        if(FAILED(hr))
        {
            printf("Factory failure: %08X\n", hr);
            factory->Release();
            return;
        }
        hr = helloWorld->HelloWorld(L"Hi there!");
        if(FAILED(hr))
        {
            printf("HelloWorld failure: %08X\n", hr);
        }
        factory->Release();
        helloWorld->Release();
    }
}

Note for SBCL users:

COM interface methods use stdcall calling convention. And unfortunately, SBCL does not support stdcall callbacks at the moment, so passing lisp interfaces into foreign code will likely cause stack corruption and will likely result in weird errors, such as EXCEPTION_PRIV_INSTRUCTION.  Although, i’m going to implement some workaround in Virgil in the future.

Advertisements

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s

%d bloggers like this: