+ Make/FreeObjectInstance for win32

git-svn-id: trunk@7856 -

.gitattributes

@@ -7041,6 +7041,7 @@ tests/test/uimpluni2.pp svneol=native#text/plain
 tests/test/uinline4a.pp svneol=native#text/plain
 tests/test/uinline4b.pp svneol=native#text/plain
 tests/test/umacpas1.pp svneol=native#text/plain
+tests/test/units/classes/tmakeobjinst.pp svneol=native#text/plain
 tests/test/units/crt/tcrt.pp svneol=native#text/plain
 tests/test/units/crt/tctrlc.pp svneol=native#text/plain
 tests/test/units/dos/hello.pp svneol=native#text/plain

rtl/win32/classes.pp

@@ -51,17 +51,98 @@ uses
 { OS - independent class implementations are in /inc directory. }
 {$i classes.inc}
 
+type
+  PMethodWrapperTrampoline = ^TMethodWrapperTrampoline;
+  PWrapperBlock = ^TWrapperBlock;
+
+  TMethodWrapperTrampoline = packed record
+    Call : byte;
+    CallOffset : PtrInt;
+    Jmp : byte;
+    JmpOffset : PtrInt;
+    case Integer of
+      0: (Next: PMethodWrapperTrampoline; Block : PWrapperBlock);
+      1: (Method: TWndMethod);
+  end;
+
+  TWrapperBlock = packed record
+    Next : PWrapperBlock;
+    UsageCount : Longint;
+    Trampolines : array[0..0] of TMethodWrapperTrampoline;
+  end;
+
+var
+  WrapperBlockList : PWrapperBlock;
+  TrampolineFreeList : PMethodWrapperTrampoline;
+
+function TrampolineWndProc(Window: HWND; Message, WParam: WPARAM;LParam: LPARAM): HRESULT; stdcall; assembler;
+asm
+  // build up tmessage structure
+  pushl $0
+  movl (%eax),%ecx
+  pushl LPARAM
+  pushl WPARAM
+  pushl Message
+  // msg
+  leal (%esp),%edx
+  // load self
+  movl 4(%eax),%eax
+  // call method
+  call %ecx
+  addl $12,%esp
+  // load result
+  popl %eax
+end;
+
+
+function get_method_offset : Pointer;assembler;nostackframe;
+  asm
+    movl    (%esp),%eax
+    addl    $5,%eax
+  end;
+
+
+const
+  SizeOfPage = 4096;
+
+
 function MakeObjectInstance(Method: TWndMethod): Pointer;
+  var
+    NewBlock : PWrapperBlock;
+    Trampoline : PMethodWrapperTrampoline;
   begin
-    { dummy }
-    runerror(217);
+    if not(assigned(TrampolineFreeList)) then
+      begin
+        NewBlock:=VirtualAlloc(nil,SizeOfPage,MEM_COMMIT,PAGE_EXECUTE_READWRITE);
+        NewBlock^.UsageCount:=0;
+        NewBlock^.Next:=WrapperBlockList;
+        WrapperBlockList:=NewBlock;
+        Trampoline:=@NewBlock^.Trampolines;
+        while pointer(Trampoline)+sizeof(Trampoline)<pointer(NewBlock)+SizeOfPage do
+          begin
+            Trampoline^.Next:=TrampolineFreeList;
+            Trampoline^.Block:=NewBlock;
+            TrampolineFreeList:=Trampoline;
+            inc(Trampoline);
+          end;
+      end;
+    Trampoline:=TrampolineFreeList;
+    TrampolineFreeList:=TrampolineFreeList^.Next;
+    inc(Trampoline^.Block^.UsageCount);
+    Trampoline^.Call:=$e8;
+    Trampoline^.CallOffset:=pointer(@get_method_offset)-pointer(@Trampoline^.Call)-5;
+    Trampoline^.Jmp:=$e9;
+    Trampoline^.JmpOffset:=pointer(@TrampolineWndProc)-pointer(@Trampoline^.Jmp)-5;
+    Trampoline^.Method:=Method;
+    Result:=Trampoline;
   end;
 
 
 procedure FreeObjectInstance(ObjectInstance: Pointer);
   begin
-    { dummy }
-    runerror(217);
+    dec(PMethodWrapperTrampoline(ObjectInstance)^.Block^.UsageCount);
+    PMethodWrapperTrampoline(ObjectInstance)^.Next:=TrampolineFreeList;
+    TrampolineFreeList:=PMethodWrapperTrampoline(ObjectInstance);
   end;
 
 
@@ -79,9 +160,26 @@ procedure DeallocateHWnd(Wnd: HWND);
   end;
 
 
+procedure DeleteInstBlockList;
+  var
+    hp : PWrapperBlock;
+  begin
+    while assigned(WrapperBlockList) do
+      begin
+        hp:=WrapperBlockList^.Next;
+        if VirtualFree(WrapperBlockList,4096,MEM_DECOMMIT) then
+          VirtualFree(WrapperBlockList,0,MEM_RELEASE);
+        WrapperBlockList:=hp;
+      end;
+  end;
+
+
 initialization
+  WrapperBlockList:=nil;
+  TrampolineFreeList:=nil;
   CommonInit;
 
 finalization
   CommonCleanup;
+  DeleteInstBlockList;
 end.

tests/test/units/classes/tmakeobjinst.pp

@@ -0,0 +1,34 @@
+{ %opt=-S2 }
+{ %target=win32 }
+uses
+  windows,messages,classes;
+
+type
+  tc1 = class
+    procedure p(var msg : TMessage);
+  end;
+
+  tf = function (Window: HWND; Message, WParam: WPARAM;LParam: LPARAM): HRESULT; stdcall;
+
+procedure tc1.p(var msg : TMessage);
+  begin
+    if (msg.msg<>1) or (msg.wparam<>2) or (msg.lparam<>3) then
+      halt(1);
+    msg.result:=4;
+  end;
+
+var
+  f : tf;
+  c : tc1;
+begin
+  c:=tc1.create;
+  f:=tf(MakeObjectInstance(@c.p));
+
+  if f(0,1,2,3)<>4 then
+    halt(1);
+
+  c.free;
+
+  FreeObjectInstance(f);
+  writeln('ok');
+end.