made hooking newinstance finally reliably cross-platform

[Thaddy]

For people that need real speed on small objects/classes.
This code was originally written for high speed pool or stack allocations for stock exchange tickers and now finally UNIX code performs as expected.
This example code does not show that, it only shows the hooking, but if you need the real stuff please contact me (at no or voluntary cost) and I provide an example that keeps up with Reuters tickers with 8ms resolution over fiber.

Code: Pascal  [Select][+][-]

1. program vmthooks;
2. {$ifdef fpc}{$mode delphi}{$endif}
3. uses
4.   {$if defined(mswindows)}
5.   windows,
6.   {$elseif defined(unix)}
7.   cthreads,
8.   baseunix,
9.   unixtype,
10.   {$else}
11.   {$error not supported}
12.   {$ifend}
13.   sysutils;
14.  
15. type
16.   TInstanceMethod = function(AClass: TClass): TObject;
17.  
18. { Make a memory page writable, write the new pointer, restore perms.}
19. {$if defined(mswindows)}
20. procedure PatchVMTSlot(AClass: TClass; Offset: PtrInt; NewProc: Pointer);
21. var
22.   VMTSlot : PPointer;
23.   OldProt : DWORD;
24. begin
25.   { The VMT pointer is stored at AClass + Offset.
26.     Because Offset is negative we go *before* the class pointer. }
27.   VMTSlot := PPointer(PByte(AClass) + Offset);
28.   VirtualProtect(VMTSlot, SizeOf(Pointer), PAGE_READWRITE, @OldProt);
29.   VMTSlot^ := NewProc;
30.   VirtualProtect(VMTSlot, SizeOf(Pointer), OldProt, @OldProt);
31. end;
32. {$elseif defined(unix)}
33. { Returns the system page size }
34. const
35.   _SC_PAGESIZE = 30;   // Linux x86/x86-64/arm
36.   // _SC_PAGESIZE = 29; // macOS — uncomment if targeting macOS
37.  
38. function sysconf(name: cint): clong; cdecl; external;
39.  
40. function GetPageSize: PtrUInt;
41. begin
42.   Result := PtrUInt(sysconf(_SC_PAGESIZE));
43.   if Result = 0 then
44.     Result := 4096; // safe fallback
45. end;
46.  
47.  
48. { Aligns an address DOWN to the nearest page boundary }
49. function PageAlignDown(Addr: PtrUInt; PageSize: PtrUInt): PtrUInt;
50. begin
51.   Result := Addr and not (PageSize - 1);
52. end;
53.  
54. { Makes the page(s) containing the given memory range writable,
55.   patches the pointer, then restores the original protection.     }
56. procedure PatchVMTSlot(AClass: TClass; Offset: PtrInt; NewProc: Pointer);
57. var
58.   VMTSlot: PPointer;
59.   PageSize: PtrUInt;
60.   AlignedAddr: PtrUInt;
61.   RangeSize: PtrUInt;
62. begin
63.   VMTSlot := PPointer(PByte(AClass) + Offset);
64.  
65.   PageSize := GetPageSize;
66.   AlignedAddr := PtrUInt(VMTSlot) and not (PageSize - 1);
67.   RangeSize := (PtrUInt(VMTSlot) + SizeOf(Pointer)) - AlignedAddr;
68.  
69.   if fpMProtect(Pointer(AlignedAddr), RangeSize, PROT_READ or PROT_WRITE) <> 0 then
70.     raise Exception.CreateFmt('mprotect rw failed: errno %d', [fpGetErrno]);
71.  
72.   VMTSlot^ := NewProc;
73.  
74.   { Do not restore to PROT_READ here unless you know the original page perms. }
75. end;{$else}
76.   {$error not supported}
77. {$endif}
78.  
79. { Replacement methods — must match the calling convention exactly.   }
80. type
81.   TSomeClass = class
82.   public
83.     procedure DoSomething; virtual;
84.   end;
85.  
86. var
87.   OriginalNewInstance  : Pointer;
88.   OriginalFreeInstance : Pointer;
89.  
90. { NewInstance receives the class reference in Self (first implicit arg).
91.   It must return a fully initialised TObject. }
92. function HookedNewInstance(AClass: TClass): TObject;
93. type
94.   TOriginal = function(AClass: TClass): TObject;
95. begin
96.   WriteLn('** HookedNewInstance called for ', AClass.ClassName);
97.   { Call the original so real allocation still happens: }
98.   Result := TOriginal(OriginalNewInstance)(AClass);
99. end;
100.  
101. { FreeInstance receives the object instance in Self. }
102. procedure HookedFreeInstance(Instance: TObject);
103. type
104.   TOriginal = procedure(Instance: TObject);
105. begin
106.   WriteLn('** HookedFreeInstance called for ', Instance.ClassName);
107.   TOriginal(OriginalFreeInstance)(Instance);
108. end;
109.  
110.  
111. { Install / uninstall }
112. procedure InstallHooks(AClass: TClass);
113. begin
114.   { Save originals before overwriting }
115.   OriginalNewInstance  := PPointer(PByte(AClass) + vmtNewInstance )^;
116.   OriginalFreeInstance := PPointer(PByte(AClass) + vmtFreeInstance)^;
117.  
118.   PatchVMTSlot(AClass, vmtNewInstance,  @HookedNewInstance);
119.   PatchVMTSlot(AClass, vmtFreeInstance, @HookedFreeInstance);
120. end;
121.  
122. procedure UninstallHooks(AClass: TClass);
123. begin
124.   PatchVMTSlot(AClass, vmtNewInstance,  OriginalNewInstance);
125.   PatchVMTSlot(AClass, vmtFreeInstance, OriginalFreeInstance);
126. end;
127.  
128. { ------------------------------------------------------------------ }
129. { Demo                                                                }
130. { ------------------------------------------------------------------ }
131. procedure TSomeClass.DoSomething;
132. begin
133.   WriteLn('DoSomething');
134. end;
135.  
136. var
137.   Obj: TSomeClass;
138. begin
139.   InstallHooks(TSomeClass);
140.   { triggers HookedNewInstance }
141.   Obj := TSomeClass.Create;
142.   Obj.DoSomething;
143.   { triggers HookedFreeInstance }
144.   Obj.Free;
145.  
146.   UninstallHooks(TSomeClass);
147.   writeln(vmtNewInstance);
148.   writeln(vmtfreeinstance);
149.   readln;
150. end.

Stack or pool allocation for very simple object without managed types speeds things up to 8ms or less per Reuters ticker. Reduces the bottleneck to storing your own trades in the database or the Reuters connection latency.
You will still need a very fast connection, tested on dedicated 10000 fiber connection (pings 2) without misses but a home fiber connection with 1000 still renders ~15ms and few misses 99.9 of the time. IOW it can keep up with real-time tickers. Trades you have to do yourself.

I have raised this subject before, using assembler, but this is assembler free and performs like I would have wished when I was not retired yet. My old team is flabbergasted. (Damn)
Since I am retired this code has no non-disclosure attached. It is free for all to use.
People who need it know how to use it.
note: Codex helped me to debug the unix part. It solved both an unnecessary pointer dereference and page rights.

[runewalsh]

What a sophisticated way to spell override.

[Handoko]

Interesting. There are many things I can't understand in the code above. Bookmarked, will be back to study it someday.

Thank you for sharing it.

[Martin_fr]

Well if I understand it correctly (I could be totally wrong, there isn't much info to deduct anything from), the idea is to reduce the initialization cost of new objects.

That is, every time you create an instance of any TObject it will call "InitInstance" (currently called from NewInstance).
And normally, that sets up stuff like interfaces, goes through RTTI for mgmt operators... So it takes a bit of time.

Of course you can just "procedure NewInstance; override;", but you must do that to each and every class that you have.
On the other hand: Each and every class has a copy of the VMT entry for NewInstance. So you also must do the above "run-time replace" for each and every class.

And if you do that, you could also create JIT sub classes on the normal heap, avoiding the memory protection stuff => but then you have to use "class of" variables, since JIT classes aren't known at run time.

[Thaddy]

Yes. Correct. This code allows overriding where and how a class is instantiated. This can lead to dramatic speed-ups of your code with small classes. Upto 600% faster than heap allocation and from 400% for Pooled heap. You can not use it universally because of managed types, which are supported but won't get the dramatic speed increase. Since it works on a per class base, that is a non-issue if you do not use managed types.
(e.g. use short-strings, no other string types)

The stock exchange example is a real-world example. The speed gain is not exaggerated.
It is not only the allocation but also the disposal. It is for short lived classes.

[Thaddy]

What a sophisticated way to spell override.

You seem to have no clue: that does not work in these cases. Usually you are more perceptive.
You start with override, but you still have to manage the memory. That is what my code does.
For stack allocations this is very hard to achieve without the hooking. (Or the calloc discussion)
And it is reversable for debugging purposes. Runtime. The windows code was already in production when I retired, but the UNIX code not.

[ALLIGATOR]

an alternative that doesn't require patching:

https://forum.lazarus.freepascal.org/index.php/topic,71085.msg554288.html

[Thaddy]

Not quite for speed... 

[runewalsh]

but you still have to manage the memory. That is what my code does.

...No, it doesn’t? You just patch VMTs and call it a day, thus reinventing override.

Here’s how a sane person would create class instances in pre‑allocated buffers (well, still way less sane than is required to understand the incompatibility of the concepts of “classes” and “speed” — if you need speed, you simply don’t use classes rather than trying to speed them up):

Code: Pascal  [Select][+][-]

1. {$mode objfpc} {$longstrings on} {$modeswitch duplicatelocals}
2. uses
3.         SysUtils;
4.  
5. type
6.         MyClass = class
7.                 msg: string;
8.                 instanceSizeOfs: record end;
9.                 constructor Create(const msg: string);
10.                 destructor Destroy; override;
11.                 procedure FreeInstance; override;
12.         end;
13.  
14.         constructor MyClass.Create(const msg: string);
15.         begin
16.                 inherited Create;
17.                 writeln('Creating: ', msg);
18.                 self.msg := msg;
19.         end;
20.  
21.         destructor MyClass.Destroy;
22.         begin
23.                 writeln('Destroying: ', msg);
24.                 inherited;
25.         end;
26.  
27.         procedure MyClass.FreeInstance;
28.         begin
29.                 CleanupInstance;
30.                 // ...But don’t free memory.
31.         end;
32.  
33. const
34.         MyClassInstanceSize = PtrUint(@MyClass(nil).instanceSizeOfs);
35.  
36. var
37.         store: array[0 .. 10 * MyClassInstanceSize - 1] of byte;
38.         i: SizeInt;
39.  
40. begin
41.         for i := 0 to 9 do
42.         begin
43.                 MyClass.InitInstance(@store[i * MyClassInstanceSize]);
44.                 MyClass(@store[i * MyClassInstanceSize]).Create('Instance #' + IntToStr(i));
45.         end;
46.         for i := 0 to 9 do
47.                 MyClass(@store[i * MyClassInstanceSize]).Destroy;
48. end.

How on earth would patching a VMT help with that? Moreover, you don’t have a good way to pass parameters to NewInstance, like the address of your object, lol.

[ALLIGATOR]

@runewalsh
Wow, I didn't know that if you call constructors like this: TClassType(ptr).Create, NewInstance won't be called - that's awesome!

[tooknox]

@runewalsh

That's really awesome, got to know something new today !!

@Thaddy I might be missing something here but how is patching VMTs directly more advantageous here cuz it does look like override with extra steps...

[Thaddy]

I didn't know that either. Nice example.
I will add a much better example for my code later.
Classes can be used in high speed code. Parameters are not an issue for the use case.

The code is based on a very old article by Halvar Vasbotn in Delphi magazine.
Ever since we used that, but we could not use it on Linux and now we can.
Halvar developed it for the same purpose: high speed stock exchange tickers,

The new example will explain why. I know the plain code just shows how, not why.
Don't forget it can patch any vmt entry, not just newinstance.