TDM#9: Exceptional Stack Tracing (HVEST)

One of the key questions you should ask yourself as a serious Delphi developer is; what kind of exception handling and logging am I using. If you're not using any custom or third party solution for tracking down exceptional incidents that occur in your production systems or at your customer sites, you're missing out big time!

A proper exception handling and logging system should at least log the calling context (the calls that lead up to the exception) in the form of a stack trace. This makes it so much easier to track down, identify and fix the cause of the problem.

In 1999 I wrote such a tool and published it in The Delphi Magazine article Exceptional Stack Tracing in October 1999. As I have mentioned before, parts of this tool is based on my earlier work on 16-bit stack tracer, YAST. It also uses the excellent RTLI (run-time line information) tool by Vitaly Miryanov. At the time I was inspired by Per Larsen's ExHook32 and Stefan Hoffmeister's Debug Mapper. So I upgraded and improved the stack tracer for Win32, integrated the RTLI code and researched and developed a general implicit DLL import hooking system and a specific exception notification mechanism.

Putting all the pieces together we were able to get meaningful symbolic stack traces from any exceptional error incident - wether it happened during development, testing or at the customer's site. This made it an order of magnitude easier and faster to identify and fix bugs that caused the exception (or to handle it more gracefully).

I always spent a fair amount of time on my articles, but this one was by far the most time-consuming. Here are some key excerpts from the article.

"Often, during beta testing of an application (and, horrors, sometimes in a release version), users will encounter bugs in the form of exceptions (both logical such as EConvertError and hardware such as EAccessViolation). The tricky part is that only address of where the exception occurred is reported by the default Delphi exception handler. This is more often than not, less than helpful. Typically, that address will map to a line deep inside the VCL or RTL. What we’re really interested in is how we ended up there in the first place with invalid parameters (i.e. a blank string or a nil pointer). To get that we would need a complete stack trace of the calls that ended up in the exception being raised.

This article is about developing such an exception stack tracer. Not only will it show a complete stack trace leading up to an exception, but in the presence of so-called Run-Time Location Information (RTLI), it will also give a complete symbolic stack trace. "

"I remember reading an excellent article about PE files by Matt Pietrek^[i]. In it he describes how implicit linking to external DLLs work. About the import address table, he says:

"Since the import address table is in a writeable section, it's relatively easy to intercept calls that an EXE or DLL makes to another DLL.. Simply patch the appropriate import address table entry to point at the desired interception function. There's no need to modify any code in either the caller or callee images. What could be easier?"

Yeah, what could be easier <g>? Such a statement just screams: “Implement me!”. We will implement a completely general way of hooking any routine in any implicitly loaded DLL. We can then use this technique to hook the Kernel32.RaiseException routine that is called from System._RaiseExcept. "

The key routine for hooking DLL imports is listed below:

function IsWin95CallThunk(Thunk: PWin95CallThunk): boolean;
begin
  Result := (Thunk^.PUSH = $68) and (Thunk^.JMP = $E9);
end;
 
function ReplaceImport(Base: Pointer; ModuleName: PChar; FromProc, ToProc: pointer): boolean;
var
  NtHeader          : PImageNtHeaders;
  ImportDescriptor  : PImageImportDescriptor;
  ImportEntry       : PImageThunkData;
  CurrModuleName    : PChar;
  IsThunked         : Boolean;
  FromProcThunk     : PWin95CallThunk;
  ImportThunk       : PWin95CallThunk;
  FoundProc         : boolean;
begin
  Result := false;
  FromProcThunk := PWin95CallThunk(FromProc);
  IsThunked := (Win32Platform = VER_PLATFORM_WIN32_WINDOWS) and
               IsWin95CallThunk(FromProcThunk);
  NtHeader := GetImageNtHeader(Base);
  ImportDescriptor := PImageImportDescriptor(DWORD(Base)+
    NtHeader.OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_IMPORT].VirtualAddress);
  while ImportDescriptor^.NameOffset <> 0 do
  begin
    CurrModuleName := PChar(Base) + ImportDescriptor^.NameOffset;
    if StrIComp(CurrModuleName, ModuleName) = 0 then
    begin
      ImportEntry := PImageThunkData(DWORD(Base) + ImportDescriptor^.IATOffset);
      while ImportEntry^.FunctionPtr <> nil do
      begin
        if IsThunked then
        begin
          ImportThunk := PWin95CallThunk(ImportEntry^.FunctionPtr);
          FoundProc := IsWin95CallThunk(ImportThunk) and
                       (ImportThunk^.Addr = FromProcThunk^.Addr);
        end
        else
          FoundProc := (ImportEntry^.FunctionPtr = FromProc);
        if FoundProc then
        begin
          ImportEntry^.FunctionPtr := ToProc;
          Result := true;
        end;
        Inc(ImportEntry);
      end;
    end;
    Inc(ImportDescriptor);
  end;
end;

"Hooking RaiseException

Now that we have the HVHookDLL, it is very easy to hook the RaiseException routine in Kernel32.DLL – take a look at [the code below]"

unit HVExceptNotify;
// Unit that provides a notification service when exceptions are being raised
//
// Written by Hallvard Vassbotn, hallvard@balder.no, September 1999
interface
 
type
  TExceptNotify = procedure (ExceptObj: TObject; ExceptAddr: pointer; OSException: boolean);
var
  ExceptNotify: TExceptNotify;
 
implementation
 
uses
  Windows,
  SysUtils,
  HVHookDLL;
 
var
  Kernel32_RaiseException : procedure (dwExceptionCode, dwExceptionFlags, nNumberOfArguments: DWORD;
  lpArguments: PDWORD); stdcall;
 
type
  PExceptionArguments = ^TExceptionArguments;
  TExceptionArguments = record
    ExceptAddr: pointer;
    ExceptObj : TObject;
  end;
 
procedure HookedRaiseException(ExceptionCode, ExceptionFlags, NumberOfArguments: DWORD;
  Arguments: PExceptionArguments); stdcall;
// All calls to Kernel32.RaiseException ends up here
const
  // D2 has a different signature for Delphi exceptions
  cDelphiException    = {$IFDEF VER90}$0EEDFACE{$ELSE}$0EEDFADE{$ENDIF};
  cNonContinuable     = 1;
begin
  // We're only interested in Delphi exceptions raised from System's
  // internal _RaiseExcept routine
  if (ExceptionFlags    = cNonContinuable)       and
     (ExceptionCode     = cDelphiException)      and
     (NumberOfArguments = 7)                     and
     (DWORD(Arguments)  = DWORD(@Arguments) + 4) then
  begin
    // Run the event if it has been assigned
    if Assigned(ExceptNotify) then
      ExceptNotify(Arguments.ExceptObj, Arguments.ExceptAddr, false);
  end;
  // Call the original routine in Kernel32.DLL
  Kernel32_RaiseException(ExceptionCode, ExceptionFlags, NumberOfArguments, PDWORD(Arguments));
end;
 
var
  SysUtils_ExceptObjProc: function (P: PExceptionRecord): Exception;
 
function HookedExceptObjProc(P: PExceptionRecord): Exception;
begin
  // Non-Delphi exceptions such as AVs, OS and hardware exceptions
  // end up here. This routine is normally responsible for creating
  // a Delphi Exception object corresponding to the OS-level exception
  // described in the TExceptionRecord structure.
  //
  // We leave the mapping to the standard SysUtils routine,
  // but hook this to know about the exception and call our
  // event.

  // First call the original mapping function in SysUtils
  Result := SysUtils_ExceptObjProc(P);

  // Run the event if it has been assigned
  if Assigned(ExceptNotify) then
    ExceptNotify(Result, P^.ExceptionAddress, true);
end;
 
function GetRaiseExceptAddr: pointer;
asm
  LEA EAX, System.@RaiseExcept;
end;
 
initialization
  SysUtils_ExceptObjProc := System.ExceptObjProc;
  System.ExceptObjProc := @HookedExceptObjProc;
  HookImport(Pointer(FindHInstance(GetRaiseExceptAddr)), 'Kernel32.dll', 'RaiseException', @HookedRaiseException, @Kernel32_RaiseException)
 
finalization
  UnHookImport(Pointer(FindHInstance(GetRaiseExceptAddr)), 'Kernel32.dll', 'RaiseException', @HookedRaiseException, @Kernel32_RaiseException);
  System.ExceptObjProc := @SysUtils_ExceptObjProc;
  SysUtils_ExceptObjProc := nil;
 
end.

"The definition of what might be useful context information can vary according to what kind of application you are developing. The name of the currently focused form, the name of active database tables, the name of the logged in user and other global information might be useful. You can easily add any such value-added information yourself.

However, in all cases, a complete overview of the function calls that preceded the raised exception will be most useful. To get that, we have to implement something called a stack tracer. A stack tracer will analyze the current contents of the stack and try to figure out the return addresses stored there by the CPU as part of the CALL instruction operation.

YAST Nostalgia

[...] I have now converted [the 16-bit YAST stack tracer] to a 32-bit version and added some bells and whistles along the way – see the [code below]"

unit HVYAST32;
// Yet-Another-Stack-Tracer, 32-bit version
//
// Loosely based on my 16-bit YAST code published in
// The Delphi Magazine, issue 7.
//
// Description: A general call-back based stack-trace utility.
// Both stack frames based and raw stack tracing is supported.
//
// Written by Hallvard Vassbotn, hallvard@balder.no, July 1999
//
interface
 
uses
  Windows,
  SysUtils;
 
// The generic stack tracing machinery
 
const
  MaxBlock = MaxInt-$f;
type
  PBytes  = ^TBytes;
  TBytes  = array[0..MaxBlock div SizeOf(byte)] of byte;
  PDWORDS = ^TDWORDS;
  TDWORDS = array[0..MaxBlock div SizeOf(DWORD)] of DWORD;
  PStackFrame = ^TStackFrame;
  TStackFrame = record
    CallersEBP : DWORD;
    CallerAdr  : DWORD;
  end;
  TStackInfo = record
    CallerAdr  : DWORD;
    Level      : DWORD;
    CallersEBP : DWORD;
    DumpSize   : DWORD;
    ParamSize  : DWORD;
    ParamPtr   : PDWORDS;
    case integer of
     0 : (StackFrame : PStackFrame);
     1 : (DumpPtr    : PBytes);
  end;
  TReportStackFrame = function(var StackInfo: TStackInfo; PrivateData: Pointer): boolean;
 
procedure TraceStackFrames(ReportStackFrame: TReportStackFrame; PrivateData: Pointer);
procedure TraceStackRaw(ReportStackFrame: TReportStackFrame; PrivateData: Pointer);
 
// Default stack tracer
 
const
  MaxStackLevels = 50;
type
  TStackInfoArray = array[0..MaxStackLevels-1] of TStackInfo;
var
  StackDump: TStackInfoArray;
  StackDumpCount: integer;
 
function PhysicalToLogical(Physical: DWORD): DWORD;
function DefaultReportStackFrame(var StackInfo: TStackInfo; PrivateData: Pointer): boolean;
procedure SaveStackTrace(Raw: boolean; IgnoreLevels: integer; FirstCaller: pointer);
 
implementation
 
uses
  HVPEUtils;
 
{$W-} // This routine should not have a EBP stack frame
function GetEBP: pointer;
// Return the current contents of the EBP register
asm
  MOV EAX, EBP
end;
 
function GetESP: pointer;
// Return the current contents of the ESP register
asm
  MOV EAX, ESP
end;
 
function GetStackTop: DWORD;
asm
  // Pick up the top of the stack from the Thread Information Block (TIB)
  // pointed to by the FS segment register.
  //
  // Reference: Matt Pietrek, MSJ, Under the hood, on TIBs:
  // PVOID pvStackUserTop  // 04h Top of user stack
  // http:{msdn.microsoft.com/library/periodic/period96/periodic/msj/F1/D6/S2CE.htm }
  //
  MOV EAX, FS:[4]
end;
 
var
  TopOfStack : DWORD;
  BaseOfStack: DWORD;
  BaseOfCode : DWORD;
  TopOfCode  : DWORD;
 
procedure InitGlobalVars;
var
  NTHeader: PImageNTHeaders;
begin
  { Get pointers into the EXE file image }
  if BaseOfCode = 0 then
  begin
    NTHeader := GetImageNtHeader(Pointer(hInstance));
    BaseOfCode := DWord(hInstance) + NTHeader.OptionalHeader.BaseOfCode;
    TopOfCode := BaseOfCode + NTHeader.OptionalHeader.SizeOfCode;
    TopOfStack := GetStackTop;
  end;
end;
 
function ValidStackAddr(StackAddr: DWORD): boolean;
begin
  Result := (BaseOfStack < StackAddr) and (StackAddr < TopOfStack);
end;
 
function ValidCodeAddr(CodeAddr: DWORD): boolean;
begin
  Result := (BaseOfCode < CodeAddr) and  (CodeAddr < TopOfCode);
end;
 
function ValidCallSite(CodeAddr: DWORD): boolean;
// Validate that the code address is a valid code site
//
// Information from Intel Manual 24319102(2).pdf, Download the 6.5 MBs from:
//  http://developer.intel.com/design/pentiumii/manuals/243191.htm
//  Instruction format, Chapter 2 and The CALL instruction: page 3-53, 3-54
var
  CodeDWORD4: DWORD;
  CodeDWORD8: DWORD;
begin
  // First check that the address is within range of our code segment! 
  Result := (BaseOfCode < CodeAddr) and  (CodeAddr < TopOfCode);

  // Now check to see if the instruction preceding the return address  
  // could be a valid CALL instruction 
  if Result then
  begin
    // Check the instruction prior to the potential call site. 
    // We consider it a valid call site if we find a CALL instruction there 
    // Check the most common CALL variants first 
    CodeDWORD8 := PDWORD(CodeAddr-8)^;
    CodeDWORD4 := PDWORD(CodeAddr-4)^;

    Result :=
          ((CodeDWORD8 and $FF000000) = $E8000000) // 5-byte, CALL [-$1234567] 
       or ((CodeDWORD4 and $38FF0000) = $10FF0000) // 2 byte, CALL EAX 
       or ((CodeDWORD4 and $0038FF00) = $0010FF00) // 3 byte, CALL [EBP+0x8] 
       or ((CodeDWORD4 and $000038FF) = $000010FF) // 4 byte, CALL ?? 
       or ((CodeDWORD8 and $38FF0000) = $10FF0000) // 6-byte, CALL ?? 
       or ((CodeDWORD8 and $0038FF00) = $0010FF00) // 7-byte, CALL [ESP-0x1234567] 
    // It is possible to simulate a CALL by doing a PUSH followed by RET, 
    // so we check for a RET just prior to the return address
       or ((CodeDWORD4 and $FF000000) = $C3000000);// PUSH XX, RET 

    // Because we're not doing a complete disassembly, we will potentially report
    // false positives. If there is odd code that uses the CALL 16:32 format, we 
    // can also get false negatives. 

  end;
end;
 
function NextStackFrame(var StackFrame: PStackFrame;
                        var StackInfo : TStackInfo): boolean;
begin
  // Only report this stack frame into the StackInfo structure 
  // if the StackFrame pointer, EBP on the stack and return 
  // address on the stack are valid addresses 
  while ValidStackAddr(DWORD(StackFrame)) do
  begin
    // CallerAdr within current process space, code segment etc. 
    if ValidCodeAddr(StackFrame^.CallerAdr) then
    begin
      Inc(StackInfo.Level);
      StackInfo.StackFrame := StackFrame;
      StackInfo.ParamPtr   := PDWORDS(DWORD(StackFrame) + SizeOf(TStackFrame));
      StackInfo.CallersEBP := StackFrame^.CallersEBP;
      StackInfo.CallerAdr  := StackFrame^.CallerAdr;
      StackInfo.DumpSize   := StackFrame^.CallersEBP - DWORD(StackFrame);
      StackInfo.ParamSize  := (StackInfo.DumpSize - SizeOf(TStackFrame)) div 4;
      // Step to the next stack frame by following the EBP pointer 
      StackFrame           := PStackFrame(StackFrame^.CallersEBP);
      Result := true;
      Exit;
    end;
    // Step to the next stack frame by following the EBP pointer
    StackFrame := PStackFrame(StackFrame^.CallersEBP);
  end;
  Result := false;
end;
 
{$W+} // We must have stack-frames on for this routine
 
procedure TraceStackFrames(ReportStackFrame: TReportStackFrame; PrivateData: Pointer);
var
  StackFrame : PStackFrame;
  StackInfo  : TStackInfo;
begin
  // Start at level 0 
  StackInfo.Level := 0;

  // Make sure the global variables are correctly set 
  InitGlobalVars;

  // Get the current stack from from the EBP register 
  StackFrame := GetEBP;

  // We define the bottom of the valid stack to be the current EBP Pointer 
  // There is a TIB field called pvStackUserBase, but this includes more of the 
  // stack than what would define valid stack frames. 
  BaseOfStack := DWORD(StackFrame) - 1;

  // Loop over and report all valid stackframes
  while NextStackFrame(StackFrame, StackInfo) and
        ReportStackFrame(StackInfo, PrivateData) do
    {Loop};
end;
 
procedure TraceStackRaw(ReportStackFrame: TReportStackFrame; PrivateData: Pointer);
var
  StackInfo : TStackInfo;
  StackPtr : PDWORD;
  PrevCaller: DWORD;
begin
  // We define the bottom of the valid stack to be the current ESP pointer
  BaseOfStack := DWORD(GetESP);

  // We will not be able to fill in all the fields in the StackInfo record,
  // so just blank it all out first
  FillChar(StackInfo, SizeOf(StackInfo), 0);

  // Make sure the global variables are correctly set
  InitGlobalVars;

  // Clear the previous call address
  PrevCaller := 0;

  // Get a pointer to the current bottom of the stack
  StackPtr := PDWORD(BaseOfStack);
 
  // Loop through all of the valid stack space
  while DWORD(StackPtr) < TopOfStack do
  begin

    // If the current DWORD on the stack,
    // refers to a valid call site...
    if ValidCallSite(StackPtr^) and (StackPtr^ <> PrevCaller) then
    begin
      // then pick up the callers address 
      StackInfo.CallerAdr := StackPtr^;

      // remeber to callers address so that we don't report it repeatedly 
      PrevCaller := StackPtr^;

      // increase the stack level 
      Inc(StackInfo.Level);

      // then report it back to our caller 
      if not ReportStackFrame(StackInfo, PrivateData) then
        Break;
    end;

    // Look at the next DWORD on the stack 
    Inc(StackPtr);
  end;
end;
 
function DefaultReportStackFrame(var StackInfo: TStackInfo; PrivateData: Pointer): boolean;
begin
  Result := (StackDumpCount < MaxStackLevels-1);
  if Result                                 and  // We have an available slot 
     (DWORD(PrivateData) < StackInfo.Level) then // We're not going to skip this level 
  begin
    // Save the contents of this stack frame
    StackDump[StackDumpCount] := StackInfo;
    Inc(StackDumpCount);
  end;
end;
 
procedure SaveStackTrace(Raw: boolean; IgnoreLevels: integer; FirstCaller: pointer);
begin
  FillChar(StackDump, SizeOf(StackDump), 0);
  StackDumpCount := 0;
  // Fill the first slot, if we are given an address directly
  if Assigned(FirstCaller) then
  begin
    StackDump[0].CallerAdr := DWORD(FirstCaller);
    StackDumpCount := 1;
  end;
  if Raw
  then TraceStackRaw   (DefaultReportStackFrame, Pointer(IgnoreLevels))
  else TraceStackFrames(DefaultReportStackFrame, Pointer(IgnoreLevels));
end;
 
const
  LinkerOffset = $1000;
 
function PhysicalToLogical(Physical: DWORD): DWORD;
begin
  Result :=   Physical
            - DWORD(HInstance)
            - LinkerOffset;
end;
 
end.

"To Stack Frame, or not to Stack Frame – that is the Question

There are generally two different types of algorithms to choose from when implementing a stack tracer: the more elegant stack frame based algorithm and the raw brute force algorithm.

[...]

The frame-based stack tracing is elegant and fairly fast, but it has one major weakness. It will not find callers that have no stack frames. With the current crop of optimising compilers, most smaller routines will not have stack frames and this reduces the usefulness of the stack tracer dramatically. There are two solutions to this. Either force stack frames for all your code – and preferably the VCL and RTL, too. Or use another algorithm.

[...]

[T]he brute-force method is much more primitive. The algorithm is very easy: just look at all the DWORDs stored on the stack. If a DWORD happens to be a value that falls within the valid code segment of this module, include it in the stack trace. To avoid getting too many false positives, we can add some more constraints."

"Dusting off the RTLI

While having the stack trace in hand is a great step in the right direction, it is still rather cumbersome having to locate the correct copy of the project’s MAP file (providing that we have it somewhere) and then start searching for each logical address from the stack trace.

Ideally, the stack trace itself should include symbolic information such as the unit name, filename, line number and routine name the logical address corresponds to. Thanks to Vitaly Miryanov and his RTLI^[ii], we get this wonderful capability almost for free. He has already developed the framework and set of routines to make this possible. We just have to tweak the code a little to make it work with the newer compiler versions."

HVEST was a step in the right direction and using it is certainly better than nothing. If you are already using it you your code today, by all means continue to do so. But time has moved on and there are now more mature solutions available - including the open source JclDebug (as part of the JCL library) and the commercial madExcept, Exceptional Magic and EurekaLog. JclDebug was in part based on my HVEST code and brought forward by Petr Vones and others. If you haven't already, you should seriously consider using one of these - you will not regret it, believe me! ;)

As usual you can read the full article (PDF) and download the full, original code (zip). Enjoy!

---

[i] Matt Pietrek, MSJ March 1994: Peering inside the PE: A Tour of the Win32 Portable Executable File Format: http://msdn.microsoft.com/library/techart/msdn_peeringpe.htm

[ii] Vitaly Miryanov, TDM Issue 22, June 1997, Run-Time Location Information In Delphi 2

TDM#4: Delphi 4 Bugs and Fixes

Delphi 4, released in the summer of 1998, was one of the most notorious Delphi releases ever. The initial release contained  a large number of serious bugs, and it later became clear that the release date had been pushed by management and/or marketing and not sanctioned by technical and R&D.

While all of this is water under the bridge, one very visible bug, the so-called TListBox ItemIndex bug, called for an interesting patching technique that has since been employed numerous times (by me and others) to fix RTL and VCL issues at runtime.

Dave Jewell and myself both contributed to the TDM article named Delphi 4 Bugs and Fixes, published in the September 1998 issue. I have Dave's permission to publish our joint effort here [Thanks, Dave!].

The gist of the problem was:

"Cause
With the release of Delphi4, Inprise changed the implementation of TCustomListBox’s ItemIndex property. The implementation of the access methods in Delphi 3 was [like this]:

function TCustomListBox.GetItemIndex: Integer;
begin
  Result := SendMessage(Handle, LB_GETCURSEL, 0, 0);
end;
 
function TCustomListBox.GetSelCount: Integer;
begin
  Result := SendMessage(Handle, LB_GETSELCOUNT, 0, 0);
end;

This was changed in Delphi 4 build 5.3 into [this]code:

function TCustomListBox.GetItemIndex: Integer;
begin
  if not MultiSelect then
    Result := SendMessage(Handle, LB_GETCARETINDEX, 0, 0) else
    Result := SendMessage(Handle, LB_GETCURSEL, 0, 0);
end;
 
procedure TCustomListBox.SetItemIndex(Value: Integer);
begin
  if GetItemIndex <> Value then
    if MultiSelect then
      SendMessage(Handle, LB_SETCARETINDEX, Value, 0) else
      SendMessage(Handle, LB_SETCURSEL, Value, 0);
end;

The change has an obvious bug, in TCustomListBox.GetItemIndex the if statement should have been:

  if MultiSelect then 

instead of:

  if not MultiSelect

"

And indeed, that is how the method looks like in current Delphis. The solution to the problem was:

"a small unit that patches the code in TCustomListBox.GetItemIndex at runtime. It can handle both statically linked and packaged VCL.

unit FixupLB;
// Simple unit that patches the StdCtrls.TCustomListBox.GetItemIndex
// method in Delphi 4.0 (build 5.37)
//
// July 1998, by Hallvard Vassbotn (hallvard@falcon.no)
  
interface
  
implementation
  
uses
  Windows,
  TypInfo,
  StdCtrls;
  
type
  PPGetItemIndex = ^PGetItemIndex;
  PGetItemIndex = ^TGetItemIndex;
  TGetItemIndex = packed record
    PUSH_EBX      :  byte;
    MOV_EBX_EAX   : word;
    CMP_BYTE_PTR  : word;
    ADDR_Offset   : Cardinal;
    False_ZERO    : byte;
    JNZ           : byte;
    ELSE_REL_ADDR : byte;
    PUSH_LParam   : word;
    PUSH_WParam   : word;
    PUSH_Msg      : byte;
    Msg_Const     : Cardinal;
    MOV_EAX_EBX   : word;
    CALL          : byte;
  end;
  PGetItemIndexInPackage = ^TGetItemIndexInPackage;
  TGetItemIndexInPackage = packed record
    JMP_DWORD: word;
    ActualGetItemIndex : PPGetItemIndex;
  end;
  TBytes = array[0..3] of byte;
 
const
  OpCode_JNZ       = $75;
  OpCode_JZ        = $74;
  OpCode_JMP_DWORD = $25FF;
 
function IsBuggyCode(var GetItemIndex: PGetItemIndex): boolean;
var
  GetItemIndexInPackage: PGetItemIndexInPackage absolute GetItemIndex;
begin
  // Verify that this is a static method
  Result := (TBytes(GetItemIndex)[3] < $FE);
  if Result then
  begin
    // Handle the case when TCustomList.GetItemIndex is in a package
    if (GetItemIndexInPackage^.JMP_DWORD = OpCode_JMP_DWORD) then
      GetItemIndex := GetItemIndexInPackage^.ActualGetItemIndex^;
    with GetItemIndex^ do
    begin
      Result :=
        // The buggy instruction, should have been OpCode_JZ
        (JNZ = OpCode_JNZ)     and
        // Check the other instructions as well, just to be sure
        (PUSH_EBX     = $53)   and
        (MOV_EBX_EAX  = $D88B) and
        (CMP_BYTE_PTR = $BB80) and
        (False_ZERO   = $00)   and
        (ELSE_REL_ADDR= $18)   and
        (PUSH_LParam  = $006A) and
        (PUSH_WParam  = $006A) and
        (PUSH_Msg     = $68)   and
        (Msg_Const    = $19f)  and
        (MOV_EAX_EBX  = $C38B) and
        (CALL         = $E8)   ;
    end;
  end;
end;
 
procedure WriteCodeByte(CodeAddress: pointer; Value: byte);
var
  WrittenBytes: Cardinal;
begin
  // Must use WriteProcessMemory or VirtualProtect to write to code segment
  WriteProcessMemory(GetCurrentProcess, CodeAddress, @Value, SizeOf(Value), WrittenBytes);
end;
 
type
  // Publish ItemIndex to easily get address of GetItemIndex method
  TPublishedListBox = class(TCustomListBox)
  published
    property ItemIndex;
  end;
 
procedure Fix_TCustomListBox_GetItemIndex_Bug;
var
  PropInfo    : PPropInfo;
  GetItemIndex: PGetItemIndex;
begin
  // Get the property information for the newly published ItemIndex property
  PropInfo := TypInfo.GetPropInfo(TPublishedListBox.ClassInfo, 'ItemIndex');
  if Assigned(PropInfo) then
  begin
    // Get the get-property method address
    GetItemIndex := PropInfo^.GetProc;
    // Now check that the buggy code is there
    if IsBuggyCode(GetItemIndex) then
      // Patch in the correction, voilà!
      // Same as GetItemIndex^.JNZ := OpCode_JZ, without the AV...
      WriteCodeByte(@GetItemIndex^.JNZ, OpCode_JZ);
  end;
end;
 
initialization
  Fix_TCustomListBox_GetItemIndex_Bug;
end.

...

When you get hold of and install the Delphi 4 update, the fix unit will silently find out that the code in GetItemIndex has changed and cause no harm. However,at that time you should remove the fix unit from the project anyway: it is better not to have self-modifying code in your project if you can avoid it."

The full PDF article and code are available for download.

TDM#2: Hooking Heapcheck

Inspired by the apparent popularity if my YAST article, a few months later, in July 1996, I published my second Delphi Magazine article - called Hooking HeapCheck. While the article is mainly irrelevant to 32-bit Delphis, it does show what is possible to achieve with a little hacking.

The gist of the article is to expand a mostly useless, parameterless Delphi 1 memory manager callback-function, HeapCheck, into a general purpose heap statistics tool. The missing parameter values are obtained by peeking into the stack and register contents.

"By checking values on the stack and in the registers, I'm able to determine whether the call is an allocation or a deallocation. For deallocations, I can determine both the pointer value and the size of the block. For allocations, only the block size is available. This is because the HeapCheck callback is called prior to the actual allocation, so the pointer value has not been determined yet."

The technique to peek at the stack contents without resorting to assembly code, is also interesting and is still relevant today:

"We could use some dirty tricks with Ptr, SSeg and SPtr or even used
assembly to look at the stack without POPing any parameters from the
stack. However, there is a cleaner and more elegant solution.

In Delphi, we can declare a procedure as "cdecl", which means that the
so-called C-calling convention should be used when calling and sending
parameters to the routine. This implies that the caller of the routine
PUSHes the parameters on the stack in reversed order and that the caller
is also responsible for cleaning up the stack after the call. The net
effect is that the routine accesses its parameters without changing
the layout of the stack."

BTW, I was wrong in my previous blog post - Delphi 1 *did* have (16-bit) BASM - I use it in the HeapCheck hooking code... :).

unit HeapStat;
 
{ Heap statistics unit. Supports both non-OOP callbacks and OOP events.
 
  Implemented by using the scarcely documented HeapCheck callback in
  the System unit. Delphi 1.0 only!
 
  Written by Hallvard Vassbotn, December 1995 (hallvard@falcon.no) }
 
interface
 
{$IFNDEF VER80}
  Can only be used with Delphi 1.0
{$ENDIF}
 
type
  THeapOp   = (hoAlloc, hoDealloc, hoBigAlloc);
  THeapStat = record
    ThisOp       : THeapOp;
    ThisSize     : longint;
    FreePtr      : pointer;
    AllocBytes   : longint;
    AllocCount   : longint;
    DeallocBytes : longint;
    DeallocCount : longint;
    DiffBytes    : longint;
    DiffCount    : longint;
    BigBytes     : longint;
    BigCount     : longint;
    Recursive    : boolean;
    IsInCallBack : boolean;
  end;
  THeapStatEvent = procedure(const HeapStat: THeapStat) of object;
  THeapStatProc  = procedure(const HeapStat: THeapStat);
 
procedure HeapStatInit(aHeapStatEvent: THeapStatEvent;
                       aHeapStatProc : THeapStatProc);
 
function HeapStatDone: boolean;
 
implementation
 
uses
  SysUtils;
 
type
  PtrRec = record
    Ofs, Seg: word;
  end;
  TProcedure = procedure;
 
const
  HeapStatEvent  : THeapStatEvent = nil;
  HeapStatProc   : THeapStatProc = nil;
  SaveHeapCheck  : pointer = nil;
  HeapCheckMagic : word = 0;
var
  HeapStatistics: THeapStat;
  LocalHS       : THeapStat;
 
{$IFOPT S+} {$DEFINE STACKCHK} {$S-} {$ENDIF}
 
{ Note: Stack-checking cannot be turned on here. It would overwrite AX!
 
  The HeapCheck callback doesn't really take any parameters, so we have
  to do some checks of registers and stack contents to find out were
  we are called from (allocation or deallocation) and what the
  block size is.
 
  Use Cdecl calling convention to look at the stack without changing
  the stack pointer. }
 
procedure HeapCheckProc(AllocSize, FreeSeg, FreeSize: word); cdecl; far;
var
  FreeOfs : word absolute AllocSize;
  AX_, BX_, CX_, ES_, SP_, BP_: Word;
  Allocate  : boolean;
  Deallocate: boolean;
begin
  { Save register values to variables }
  asm
    MOV AX_, AX
    MOV BX_, BX
    MOV CX_, CX
    MOV ES_, ES
    MOV BP_, BP
  end;
  { Do some magic checks to see if we are called from NewMemory or DisMemory in WMEM.ASM }
  Deallocate := (FreeSeg = ES_) and (FreeOfs = BX_) and (HeapCheckMagic = CX_);
  Allocate   := (not Deallocate) and (AllocSize = AX_);
 
  with HeapStatistics do
  begin
    if Allocate then
    begin
      FreePtr := nil;
      ThisSize := AllocSize;
      if ThisSize < System.HeapLimit then
      begin
        ThisOp := hoAlloc;
        Inc(AllocBytes, ThisSize);
        Inc(AllocCount);
      end
      else
      begin
        ThisOp := hoBigAlloc;
        Inc(BigBytes, ThisSize);
        Inc(BigCount);
      end;
    end
    else
    begin
      PtrRec(FreePtr).Seg := FreeSeg;
      PtrRec(FreePtr).Ofs := FreeOfs;
      ThisSize := FreeSize;
      ThisOp   := hoDealloc;
      Inc(DeallocBytes, ThisSize);
      Inc(DeallocCount);
    end;
    DiffBytes := AllocBytes - DeallocBytes;
    DiffCount := AllocCount - DeallocCount;
 
    { Call the callback/event handler, but look out for recursiveness }
    if not IsInCallBack then
    begin
      IsInCallBack := true;
      LocalHS := HeapStatistics;
      if Assigned(HeapStatProc) then
        HeapStatProc(LocalHS);
      if Assigned(HeapStatEvent) then
        HeapStatEvent(LocalHS);
      IsInCallBack := false;
    end
    else
      Recursive := true;
  end;
 
  { Call any previous HeapCheck callback that might be installed.}
  if Assigned(SaveHeapCheck) then
    TProcedure(SaveHeapCheck);
end;
 
{$IFDEF STACKCHK} {$UNDEF STACKCHK} {$S+} {$ENDIF}
 
procedure HeapStatInit(aHeapStatEvent: THeapStatEvent;
                       aHeapStatProc : THeapStatProc);
begin
  if System.HeapCheck <> @HeapCheckProc then
  begin
    FillChar(HeapStatistics, SizeOf(HeapStatistics), 0);
    SaveHeapCheck    := System.HeapCheck;
    System.HeapCheck := @HeapCheckProc;
    HeapCheckMagic   := LongRec(HeapCheck).Hi or LongRec(HeapCheck).Lo;
  end;
  HeapStatEvent    := aHeapStatEvent;
  HeapStatProc     := aHeapStatProc;
end;
 
function HeapStatDone: boolean;
begin
  System.HeapCheck := SaveHeapCheck;
  Result := not HeapStatistics.Recursive;
end;
 
end.

There are not many references to the Delphi 1 HeapCheck variable online, but Ray Lischner mentions it in a newsgroup posting and in his Secrets of Delphi 2 book.

I found the original article script in my archives - it was simply a plain text file, edited with Notepad, as I didn't have access to a proper word processor at the time ;). Of course, Chris Frizelle edited my raw text and produced this beautifully formatted PDF - the code is also available.

Sergey Antonov implements Yield for Delphi!

The Russian Delphi programmer Sergey Antonov (or Антонов Сергей - aka. 0xffff) is a real hacker in the positive sense. He approached me with some intriguing assembly code that implements the equivalent of the C# yield statement!

Yield makes it easier to implement enumerators (you know the simple classes or records with methods like GetCurrent and MoveNext that enables the for-in statement). Normally you have to implement a kind of state-machine to write an enumerator. With the yield statement this is turned around allowing you to express the iteration using easier to write loops (while, repeat-until or even a for-in loop). 

Sergey has pulled the impressive feat of implementing a proof-of-concept version of a yield infrastructure and mechanics - without help from the compiler!! It may have some limitations, but it is most interesting anyway. Without further ado, here is Sergey's article and code. Make sure you also read the follow-up article on Sergey's blog.

Despite some minor language barriers ;), this will be a most interesting blog to follow!

Guest article, by Sergey AntonoV

"C# Yield implementation in Delphi.

The C# yield keyword is used to provide a value to the enumerator object or to signal the end of iteration. The main idea of yield construction is to generate a collection item on request and return it to the enumerator consumer immediately. You may find it useful in some cases.

As you know the Enumerator has two methods MoveNext and GetCurrent.

But how does yield works?

Technical details of the implementation

When I saw this construction I asked myself where is MoveNext and GetCurrent?

The GetEnumerator function returns the enumerator object or interface, but the enumerator is not explicitly constructed anywhere. So there must be some secret mechanism that makes it possible.

How does it really work? After spending some time in the debugger and the answer appeared.

In short the compiler generates a special type of object that of course

has some magic MoveNext and GetCurrent functions.

And because this construction may be useful to our Delphi community, I asked myself, what can I do to get yield support in Delphi with no special methods calling with saving the form of using like in С#.

I first wanted to retain the yield C# syntax, but later I changed the syntax a little and used a delegate implementation to an external procedure almost like in C# but with an additional parameter yield wrapper object. First time it was a virtual procedure.

But of course I have to generalize implementation for all types.

And of course I had an additional question to myself. Сould I improve on the С# yield implementation? Maybe.

I started from the programmer’s viewpoint. Something like this:

var
  number, exponent, counter, Res:integer;
begin
  // ...
  Res:=1;
  while counter<exponent do
  begin
    Res:=Res*number;
    Yield(Res);
    Inc(counter);
  end;
end;

I had to implement some class that implemented the magic MoveNext and GetCurrent functions.

And if you use local vars (that is placed on stack) I had to implement some mechanism that guarantees no memory leaks for finalized types and some mechanism that guarantees that I use

the valid local vars when the actual address of local vars has changed after last yield calling due to external reasons (e.g. enumerator passed as parameter to other procedure, so the location in stack becomes different).

So after each yield call I have to preserve the state of local vars and processor registers,

clean up the stack and return a value to the enumerator consumer.

And after next call to MoveNext I must allocate stack space, restore the state of local vars and processor registers, i.e. emulate that nothing has happened.

And of course I must provide a normal procedure for exiting at the end.

So let’s begin

First of all we declare some types:

type
  TYieldObject = class;
  TYieldProc = procedure (YieldObject: TYieldObject);

  TYieldObject = class
  protected
    IsYield:boolean;
    NextItemEntryPoint:pointer;
    BESP:pointer;
    REAX,REBX,RECX,REDX,RESI,REDI,REBP:pointer;
    StackFrameSize:DWORD;
    StackFrame: array[1..128] of DWORD;
    procedure SaveYieldedValue(const Value); virtual; abstract;
  public
    constructor Create(YieldProc: TYieldProc);
    function MoveNext:boolean;
    procedure Yield(const Value);
  end;

And the implementation

constructor TYieldObject.Create(YieldProc:TYieldProc);
asm
  mov eax.TYieldObject.NextItemEntryPoint,ecx;
  mov eax.TYieldObject.REAX,EAX;
end;

function TYieldObject.MoveNext: boolean;
asm
  { Save the value of following registers.
    We must preserve EBP, EBX, EDI, ESI, EAX for some circumstances.
    Because there is no guarantee that the state of registers will 
    be the same after an iteration }
  push ebp;
  push ebx;
  push edi;
  push esi;
  push eax;

  mov eax.TYieldObject.IsYield,0
  push offset @a1
  xor edx,edx;
  cmp eax.TYieldObject.BESP,edx;
  jz @AfterEBPAdjust;

  { Here is the correction of EBP. Some need of optimization still exists. }
  mov edx,esp;
  sub edx,eax.TYieldObject.BESP;
  add [eax.TYieldObject.REBP],edx
  @AfterEBPAdjust:
  mov eax.TYieldObject.BESP,esp;

  { Is there any local frame? }
  cmp eax.TYieldObject.StackFrameSize,0
  jz @JumpIn;

  { Restore the local stack frame }
  mov ecx,eax.TYieldObject.StackFrameSize;
  sub esp,ecx;
  mov edi,esp;
  lea esi,eax.TYieldObject.StackFrame;

  { Some need of optimization still exists. Like movsd}
  rep movsb;
  @JumpIn:

  { Restore the content of processor registers }
  mov ebx,eax.TYieldObject.REBX;
  mov ecx,eax.TYieldObject.RECX;
  mov edx,eax.TYieldObject.REDX;
  mov esi,eax.TYieldObject.RESI;
  mov edi,eax.TYieldObject.REDI;
  mov ebp,eax.TYieldObject.REBP;
  push [eax.TYieldObject.NextItemEntryPoint];
  mov eax,eax.TYieldObject.REAX;

  { Here is the jump to next iteration }
  ret;

  { And we return here after next iteration in all cases, except exception of course. }
  @a1:;

  { Restore the preserved EBP, EBX, EDI, ESI, EAX registers }
  pop eax;
  pop esi;
  pop edi;
  pop ebx;
  pop ebp;
  { This Flag indicates the occurrence or no occurrence of Yield  }
  mov al,eax.TYieldObject.IsYield;
end;

procedure TYieldObject.Yield(const Value);
asm
  { Preserve EBP, EAX,EBX,ECX,EDX,ESI,EDI }
  mov eax.TYieldObject.REBP,ebp;
  mov eax.TYieldObject.REAX,eax;
  mov eax.TYieldObject.REBX,ebx;
  mov eax.TYieldObject.RECX,ecx;
  mov eax.TYieldObject.REDX,edx;   // This is the Ref to const param
  mov eax.TYieldObject.RESI,ESI;
  mov eax.TYieldObject.REDI,EDI;
  pop ecx;
  mov eax.TYieldObject.NextItemEntryPoint,ecx;

  //We must do it first for valid const reference
  push eax;
  mov ecx,[eax];
  CALL  DWORD PTR [ecx+VMTOFFSET TYieldObject.SaveYieldedValue];
  pop eax;
  
  { Calculate the current local stack frame size }
  mov ecx,eax.TYieldObject.BESP;
  sub ecx,esp;
  mov eax.TYieldObject.StackFrameSize,ecx;
  jz @AfterSaveStack;

  { Preserve the local stack frame }
  lea esi,[esp];
  lea edi,[eax.TYieldObject.StackFrame];
  
  { Some need of optimization still exists. Like movsd }
  rep movsb;
  mov esp,eax.TYieldObject.BESP;
  @AfterSaveStack:

  {Set flag of Yield occurance }
  mov eax.TYieldObject.IsYield,1;
end;

And what about my improvements

As for improvements I am still thinking about unwinding the local SEH (Structured Exception Handling) frames on yielding and restore it with any needed correction after return.

And how do you use it?

type
  TYieldInteger = class(TYieldObject)
  protected
    Value:integer;
    function GetCurrent:integer;
    procedure SaveYieldedValue(const Value); override;
  public
    property Current:integer read GetCurrent;
  end;

{ TYieldInteger }

function TYieldInteger.GetCurrent: integer;
begin
  Result:=Value;
end;

procedure TYieldInteger.SaveYieldedValue(const Value);
begin
  Self.Value:=integer(Value);
end;

So now there is full support for integer.

type
  TYieldString = class(TYieldObject)
  protected
    Value:string;
    function GetCurrent:string;
    procedure SaveYieldedValue(const Value); override;
  public
    property Current:string read GetCurrent;
  end;

{ TYieldString }

function TYieldString.GetCurrent: string;
begin
  Result:=Value;
end;

procedure TYieldString.SaveYieldedValue(const Value);
begin
  Self.Value := string(Value);
end;

And now there is full support for string.

Sample of using a string Enumerator

procedure StringYieldProc(YieldObj: TYieldObject);
var  
  YieldValue: string;
  i: integer;
begin
  YieldValue:='None';
  YieldObj.Yield(YieldValue);
  for i := 1 to 10 do
  begin
    YieldValue := YieldValue + IntToStr(i);
    YieldObj.Yield(YieldValue);
  end;
end;

function TForm1.GetEnumerator: TYieldString;
begin
  Result:=TYieldString.Create(StringYieldProc);
end;

procedure TForm1.Button1Click(Sender: TObject);
var 
  a:string;
begin
  for a in self do 
    Memo1.Lines.Add(a);
end;

From Russia with love

Sergey Antonov aka oxffff (Russia, Ukhta)

References:

ECMA 334

ECMA 335

MSDN

---

"

Sergey's next article is here.

Hack#17: Virtual class variables, Part II

In Part I of this blog post we introduced the concept of virtual class variables - a feature currently (Delphi 2007) lacking from Object Pascal (and most other languages). We also covered a potential syntax and suggested some compiler implementation details. In this post we will continue by looking at some hacks to try and implement the functionality of virtual class fields manually by using some clever tricks and hacks. The original idea is Patrick van Logchem's.

Hacking a solution

While we wait for CodeGear to eventually implement (or not) support for these virtual class fields, what should we do? This is where my little email conversation with Patrick van Logchem of everyangle.com comes into play. From his original email to me: 

 [...] Anyway, I discovered Delphi got class variables since version 2005, but I needed something a bit more specific: Class-specific variables. This is not a standard language construct, because a class var is just another type of global; not much use in my case - I want this:

TClass1 =  class(TObject)
 public
   // written once, read _very_ frequently 
   class property Variable: Type;
 end;

 TClass2 = class(TClass1);

and then TClass1.Variable <> TClass2.Variable. In words: when declaring a variable of this kind, the class itself and  all its derived classes should have their own version of this  variable.

This matches exactly the virtual class vars we have been discussing in Part I. Not content with the missing language support, Patrick did what any true hacker would have done - he devised his own solution. Patrick continues:

I haven't found a clean language-construct for such a simple requirement, so I started hacking. To make this work, I (ab-)use a slot in the VMT as a variable! Here a slightly edited cut-'n-paste of our production code:

type
  PClass = ^TClass;
  // this class contains important meta-data, 
  // accessed _very_ frequently
  TClassInfo = class(TObject);
 
  TBasicObject = class(TObject)
  strict private
    procedure VMT_Placeholder1; virtual;
  protected
    class procedure SetClassInfo(const aClassInfo: TClassInfo);
  public
    class procedure InitVMTPlaceholders; virtual;
    function GetClassInfo: TClassInfo; inline;
    // Strange: Inlining of class methods doesn't work (yet)!
    class function ClassGetClassInfo: TClassInfo; inline; 
  end;
 
  PBasicObjectOverlay = ^RBasicObjectOverlay;
  RBasicObjectOverlay = packed record
    OurClassInfo: TClassInfo;
  end;
 
procedure PatchCodeDWORD(Code: PDWORD; Value: DWORD);
// Self-modifying code - change one DWORD in the code segment
var
  RestoreProtection, Ignore: DWORD;
begin
  if VirtualProtect(Code, SizeOf(Code^), PAGE_EXECUTE_READWRITE,
    RestoreProtection) then
  begin
    Code^ := Value;
    VirtualProtect(Code, SizeOf(Code^), RestoreProtection, Ignore);
    FlushInstructionCache(GetCurrentProcess, Code, SizeOf(Code^));
  end;
end;
  
class procedure TBasicObject.InitVMTPlaceholders;
begin
  // First, check if the VMT-mapping came thru the compiler alright :
  if Pointer(ClassGetClassInfo) = Addr(TBasicObject.VMT_Placeholder1) then
  begin
    // Now, empty the variable default, 
    // very important for later code !
    PatchCodeDWORD(@PBasicObjectOverlay(Self).OurClassInfo, DWORD(nil));

    // Now check that we see a cleaned up variable :
    Assert(ClassGetClassInfo = nil, 'Failed cleaning VMT of ' + ClassName);
  end
  else
    // When there's no original content anymore, this initialization 
    // has already been done - there _has_ to be a nil here :
    Assert(ClassGetClassInfo = nil, 
      'Illegal value when checking initialized VMT of ' + ClassName);
end;
 
function TBasicObject.GetClassInfo: TClassInfo;
begin
  Result := PBasicObjectOverlay(PClass(Self)^).OurClassInfo;
end;
 
class function TBasicObject.ClassGetClassInfo: TClassInfo;
begin
  Result := PBasicObjectOverlay(Self).OurClassInfo;
end;

class procedure TBasicObject.SetClassInfo(const aClassInfo: TClassInfo);
begin
  PatchCodeDWORD(@PBasicObjectOverlay(Self).OurClassInfo, DWORD(aClassInfo));
end;
 
procedure TBasicObject.VMT_Placeholder1;
begin
  // This method may never be called! 
  // It only exists to occupy a space in the VMT!
  Assert(False); 
  // This line prevents warnings about unused symbols
  // (until the compiler detects endless recursive loops)...
  VMT_Placeholder1; 
end; 
 
initialization
  // call this for any derived class too
  TBasicObject.InitVMTPlaceholders;
end.

The nicest thing about this solution is, that an inlined call to GetClassInfo results in only 2 opcodes:

  MOV EAX, [EAX]    // Go from instance to VMT
  MOV EAX, [EAX+12] // read from the VMT at some offset (!)

You can't get it any faster than that!

Yes, that does look like impressively fast code!

Analyzing the Hack

Lets pause a little and analyze exactly what Patrick's hack is doing. The first thing to note is that he introduces a base class, TBasicObject,  that all other classes that wants the per-class class storage should inherit from (directly or indirectly). The base class then does something peculiar - it declares a strict private virtual method (called VMT_Placeholder1) that can never be overridden. This is because it is never meant to be overridden - in fact it is not even intended to ever be called - it is only there to take up place and reserve a slot in the class' (and all derived classes') VMT (virtual method table - see here and here for details).

Reserving space in the VMT

Why would he want to waste space in the VMT? To reserve space that can be used to store per-class data, of course! The whole point of this exercise is to have the instance function GetClassInfo (and the corresponding class function ClassGetClassInfo) return an instance of a user defined class TClassInfo that contains per-class meta-data (class attributes á la .NET, if you like) useful to the programmer. Lets look closer at the implementation of this function.

function TBasicObject.GetClassInfo: TClassInfo;
begin
  Result := PBasicObjectOverlay(PClass(Self)^).OurClassInfo;
end;

There is some funky looking type casts going on here. This is an instance function so the implicit Self parameter represents the TObject (or in this case, TBasicObject) instance that the method is being called on. As we already know, the first 4 bytes of the instance memory block contains a TClass - which is implemented as a pointer to the VMT of the class. The PClass(Self)^ cast first dereferences the instance pointer and picks up a copy of the VMT pointer. The VMT contains an array of the normal user-defined virtual methods of the class (at negative offsets we find the special TObject virtual methods and the magic VMT fields - details here).

Casting Magic

A TClass reference is opaque in the sense that you cannot explicitly dereference it in code - however the compiler does it all the time when you are calling virtual methods or accessing members such as ClassName. The code above takes the TClass value and casts it into a RBasicObjectOverlay record pointer. This record contains a single 4-byte field, OurClassInfo, that has the same type as the meta class object we want to access, TClassInfo. Since the VMT_Placeholder1 method is the first virtual method in TBasicObject, and since TBasicObject inherits from TObject (that has no "normal" (i.e. positive VMT offset) virtual methods), the OurClassInfo field access above just happens to match the VMT slot for VMT_Placeholder1. Got that?

Doing the compiler's work

The trouble is, of course, is that the VMT_Placeholder1 VMT slot does not contain the reference of a TClassInfo instance at all. Instead it contains the address of the virtual method implementation code (that will always be equal to @TBasicObject. VMT_Placeholder1 - being strict private, it cannot be overridden, remember?). So we will have to perform a little VMT patching again :-). (I told you this was a hack, right?). We'll divide this task in two parts - from the initialization section of all units that declare one or more TBasicObject descendants should be the code to clear the VMT slot so that it is ready for our purposes.

class procedure TBasicObject.InitVMTPlaceholders;
begin
  // First, check if the VMT-mapping came thru the compiler alright :
  if Pointer(ClassGetClassInfo) = Addr(TBasicObject.VMT_Placeholder1) then
  begin
    // Now, empty the variable default,
    // very important for later code !
    PatchCodeDWORD(@PBasicObjectOverlay(Self).OurClassInfo, DWORD(nil));

    // Now check that we see a cleaned up variable :
    Assert(ClassGetClassInfo = nil, 'Failed cleaning VMT of ' + ClassName);
  end
  else
    // When there's no original content anymore, this initialization
    // has already been done - there _has_ to be a nil here :
    Assert(ClassGetClassInfo = nil,
      'Illegal value when checking initialized VMT of ' + ClassName);
end;

initialization
  // call this for any derived class too
  TBasicObject.InitVMTPlaceholders;
end.

First there is some sanity checks, using Asserts, ensuring that the compiler generated value of the VMT slot we're going to patch matches our expectations. If the slot does not contain the static code address of the TBasicObject.VMT_Placeholder1 method, the method has either been overridden, not been compiled into a virtual method, or has received a different slot than we anticipated. Better safe than sorry.

Then we use the PatchCodeDWORD utility routine to do the actual dirty work of patching the VMT slot with a nil value (effectively clearing it). Again we check that the patching went well, raising an Assert exception if it didn't.

Creating a metainfo class

Ok, that's step one. The nil value is in fact assignment compatible as a TClassInfo reference, but you cannot store much data in a nil pointer ;). The next step is to actually create a TClassInfo instance and assign it to the now per-class variable slot we have made available in the VMT. This should only be done once per class - it can be done in the initialization section of the unit, or it could be done by some other startup code in the project. The assignment is done by calling the SetClassInfo class method. Here is a simple example where we have extended the application specific TClassInfo with a single integer field and a constructor to initialize it.

type
  TClassInfo = class(TObject)
  public
    A: integer;
    constructor Create(Value: integer);
  end;

constructor TClassInfo.Create(Value: integer);
begin
  inherited Create;
  A := Value;
end;

initialization
  TBasicObject.InitVMTPlaceholders;
  TBasicObject.SetClassInfo(TClassInfo.Create(42));

Having looked at both the GetClassInfo function and the InitVMTPlaceholders method above, the implementation of SetClassInfo should not be surprising.

class procedure TBasicObject.SetClassInfo(const aClassInfo: TClassInfo);
begin
  PatchCodeDWORD(@PBasicObjectOverlay(Self).OurClassInfo, DWORD(aClassInfo));
end;

This code patches the right VMT slot in the code segment with the instance reference of our per-class meta-data instance, TClassInfo. This should only be done once. After this the class-specific TClassInfo can be retrieved using the GetClassInfo function - and we can freely read and write the TClassInfo fields and properties - without any fear of triggering access violations. The TClassInfo instance lives in the dynamic heap, just like any other object instance.

Application level classes

Writing additional classes that supports these per-class TClassInfo variables is easy. Just derive the class from TBasicObject, call InitVMTPlaceholders for the class and assign a new TClassInfo instance using SetClassInfo. Lets rewrite the Apples & Oranges sample from Part I using this new hacking technique.

type
  TFruitClassInfo = class(TClassInfo)
  {unit} private
    var FInstanceCount: integer;
  end;
  TFruit = class(TBasicObject)
  protected
    class function FruitClassInfo: TFruitClassInfo; inline;
  public
    constructor Create;
    class function InstanceCount: integer;
  end;
  TApple = class(TFruit)
  end;
  TOrange = class(TFruit)
  end;
 
constructor TFruit.Create;
begin
  inherited Create;
  Inc(FruitClassInfo.FInstanceCount);
end;
 
class function TFruit.FruitClassInfo: TFruitClassInfo;
begin
  Result := ClassGetClassInfo as TFruitClassInfo;
end;
 
class function TFruit.InstanceCount: integer;
begin
  Result := FruitClassInfo.FInstanceCount;
end;
 
initialization
  TFruit.SetClassInfo(TFruitClassInfo.Create);
  TApple.SetClassInfo(TFruitClassInfo.Create);
  TOrange.SetClassInfo(TFruitClassInfo.Create);
end.

First notice that the code is much simpler now. The InstanceCount function is introduced and fully implemented by the TFruit class - the TApple and TOrange classes do no longer have to help implement it. Because the compiler does not support per-class variables, we see the presence of the hacking code in the initialization section. Note that I was lazy, skipping the checking and overwriting the VMT slot with nil (by calling InitVMTPlaceholders on each class). I like to live dangerously ;)).

We introduce a class that inherits from the generic TClassInfo and adds the variable we need for storage. To get type safe access to this TFruitClassInfo instance, I've also written a class function (FruitClassInfo) that returns it - performing an as-cast in the process.

ClassInfo Design

Depending on your application requirements and homogeneousness of your application classes, you might want to stick to a single TClassInfo class that contains all the fields and properties you need for all classes, or create specific TClassInfo descendents for some classes. Using a single shared class can produce faster code, because you don't need to do the type cast (you could "cheat" by using a faster hard-cast instead of the as-cast).

Inlining gotchas

In addition, the current inlining capability of the compiler seems to prevent class methods from being inlined. That's why you should call the instance method GetClassInfo from time-critical code - this assumes you have a live instance (rather than a static or dynamic class reference) to call it on. As you may be able to read below the striked-out font, I was incorrectly generalizing from one bad sample. In Patrick's code above the TBasicObject.InitVMTPlaceholders calls the inlined class function ClassGetClassInfo, and if you look closely at the generated assembly code, you'll find that the call is not inlined. After I while I spotted the reason; method implementation order. The implementation of an inlined routine must have been "seen" by the compiler before a call to it - otherwise the compiler will not be able to inline it. With the Delphi compiler explicitly (and deliberately) designed to be a single-pass compiler, this is only natural. The compiler cannot output code it hasn't seen yet. This might be biting other people too, so I've updated by inlining post here. If you move the InitVMTPlaceholders below the ClassGetClassInfo, the call will be inlined. Nice to get rid of that little misunderstanding ;).

The performance angle

As Patrick noted in his email, the combination of inlining, the GetClassInfo instance method and the ingenious, but hacky, casting allows the compiler to produce very efficient code when accessing the TClassInfo per-class metadata on an object instance.

ClassInfo := Apple.GetClassInfo;
// With inlinging and optimization enabled 
// this compiles into
asm
   mov eax,[eax]
   mov eax,[eax]
end;

To go from an object instance to the object's class' metainfo TClassInfo only takes two machine code instructions and two memory accesses. The first converts from TObject to TClass, the second picks up the contents of the first VMT slot (i.e. index and offset 0). It doesn't get any faster than this - very impressive! ;)

A cleaner Hack?

I think Patrick knew he had a great hack up his sleeve, but at the same time something was bothering him. Could it be done differently, better or cleaner? It most probably couldn't be made faster. Quoting Patrick again:

But, this functionality shouldn't be so dirty as this to implement - do you know of a cleaner solution than this?

Well, it is possible to write a cleaner solution, but it would probably end up being slower. One way is to use a hash table with the TClass reference as the key - looking up the TClassInfo instance that corresponds to a specific class.

Depending on your point of view you could make it more or less dirty by not using a new VMT slot for this, but instead overwrite and reuse one of the unused magic VMT slots, like the one for automated methods, AutoTable, a relic from Delphi 2 that is generally not used anymore. Here is the VMT pseudo record layout taken from this post.

type
  PVmt = ^TVmt;
  TVmt = packed record
    SelfPtr           : TClass;
    IntfTable         : Pointer;
    AutoTable         : Pointer;
    InitTable         : Pointer;
    TypeInfo          : Pointer;
    FieldTable        : Pointer;
    MethodTable       : Pointer;
    DynamicTable      : Pointer;
    ClassName         : PShortString;
    InstanceSize      : PLongint;
    Parent            : PClass;
    SafeCallException : PSafeCallException;
    AfterConstruction : PAfterConstruction;
    BeforeDestruction : PBeforeDestruction;
    Dispatch          : PDispatch;
    DefaultHandler    : PDefaultHandler;
    NewInstance       : PNewInstance;
    FreeInstance      : PFreeInstance;
    Destroy           : PDestroy;
   {UserDefinedVirtuals: array[0..999] of procedure;}
  end;

The advantage of re-using the AutoTable instead is:

• You don't need the magic virtual method anymore
  
• It is already initialized to nil (except for legacy Delphi 2 code)
  
• You can thus use this trick for any class, not just those derived from your TBasicObject

This main disadvantage is that we're using a VMT slot that could conceivably be used, even though the automated section has been deprecated since Delphi 3.

Nostalgia: Delphi 2, COM and automated

It does have the drawback of not being compatible with old Delphi 2 code that uses the automated section. Back in those days, Delphi didn't support COM compatible interfaces - so it had to implement COM objects using abstract classes  with virtual methods that just happened to match COMs requirements. Since Delphi only supported single-inheritance of classes, only a single "interface" could be implemented by a class. If you wanted an object to support multiple COM interfaces, each interface had to be implemented by a separate Delphi class, and you had to manually write QueryInterface methods that would marshall properly between the "interface" (read class) implementations.

The automated section was needed to get late-bound Automation support. The compiler generates special RTTI for automated sections so that the Delphi 2 COM support code could translate method and property name strings into callable entities. In Delphi 3, the COM support was substantially improved with proper support for interfaces and automation support with dual-interfaces (dispinterface). In short, automation section in classes should (hopefully) be rare about now. It may be used by clever code just to get at the automated RTTI for other purposes (a custom script language implementation, for example).

If you need access to full RTTI for (public or published) methods and properties, I would recommend using the more complete and better documented $METHODINFO ON feature instead. Se my posts about that feature here, here, here and here.

A "cleaner" hack - overwriting AutoTable

Changing Patrick's original hack to overwrite the AutoTable in the existing VMT instead of overwriting the VMT slot of a new virtual method, simplifies the code considerably.

type
  PClassVars = ^TClassVars;
  TClassVars = class(TObject)
  public
    InstanceCount: integer;
  end;
 
  TBasicObject = class(TObject)
  protected  
    class procedure SetClassVars(aClassVars: TClassVars);
  public
    class function GetClassVars: TClassVars; inline;
    function ClassVars: TClassVars; inline;
  end;
 
const
  vmtClassVars = System.vmtAutoTable;
 
function TBasicObject.ClassVars: TClassVars;
begin
  Result := PClassVars(PInteger(Self)^ + vmtClassVars)^; // Original code
end;
 
class function TBasicObject.GetClassVars: TClassVars;
begin
  Result := PClassVars(Integer(Self) + vmtClassVars)^;
end;
 
class procedure TBasicObject.SetClassVars(aClassVars: TClassVars);
begin
  PatchCodeDWORD(PDWORD(Integer(Self) + vmtClassVars), DWORD(aClassVars));
end;

We no longer need the artificially created strict private virtual method, nor the method to clear the VMT slot (as we assume that the AutoTable slot is already free). Notice that we use one of the magic constants from the System unit to determine the offset that we will use, vmtAutoTable. From the System unit:

const
  ...
{ Virtual method table entries }

  vmtSelfPtr           = -76;
  vmtIntfTable         = -72;
  vmtAutoTable         = -68;
  vmtInitTable         = -64;

Here you see that the AutoTable is at negative offset -68 (or -$44 in hex) from the base TClass pointer. I've also chosen to rename ClassInfo to ClassVars, to reduce confusion with the existing TObject.ClassInfo that returns a pointer to the RTTI of the published properties in the class (and used by the TypInfo unit). The SetClassInfo and ClassInfo methods are non-static class methods (so that they receive the implicit Self: TClass parameter that contains the runtime class reference), while the instance function ClassVar returns the TClassVars instance that holds the per-class variables of the class of the object instance.

To keep the code simple and fast, I've selected to put the InstanceCount field directly in the TClassVars class (instead of creating a descendent class). To add a certain shim of abstraction to the initialization of the ClassVars slot, I've thrown in a simple registration procedure as well.

procedure RegisterClassVarsSupport(const Classes: array of TBasicObjectClass);
var
  LClass: TBasicObjectClass;
begin
  for LClass in Classes do
    if LClass.GetClassVars = nil then
      LClass.SetClassVars(TClassVars.Create)
    else
      raise Exception.CreateFmt(
'Class %s has automated section or duplicated registration', [LClass.ClassName]);
end;

Our fruit example then becomes simpler too.

type
  TFruit = class(TBasicObject)
  public
    constructor Create;
    function InstanceCount: integer; inline; 
    class function ClassInstanceCount: integer; inline; 
  end;
  TApple = class(TFruit)
  end;
  TOrange = class(TFruit)
  end;

constructor TFruit.Create;
begin
  inherited Create;                                    
  Inc(ClassVars.InstanceCount);
end;

function TFruit.InstanceCount: integer;
begin
  Result := ClassVars.InstanceCount;
end;

class function TFruit.ClassInstanceCount: integer;
begin
  Result := GetClassVars.InstanceCount;
end;

initialization
  RegisterClassVarsSupport([TFruit, TApple, TOrange]);
end.

The test code stays the same as before. A quick look at the generated machine code for going from an object instance, via the object's TClass reference to the TClassVar slot in the VMT and finally referencing an integer field (InstanceCount) is impressive.

Count := Apple.ClassInstanceCount;
asm
  mov eax,[esi]
  add eax,-$44
  mov eax,[eax]
  mov ebx,[eax+$04]
end;

Only four instructions. Notice that this is one instruction more than the virtual method slot hack we started with. The main reason for this is that the vmtAutoTable is at a negative offset in the VMT, while the user-defined virtual method is at a positive offset. Currently, it does not seem to be a way to force the compiler to put the constant offset calculation inside the memory referencing mov reg, mem opcode - for negative offsets. The ideal would be if the compiler could generate the following machine code instead.

Count := Apple.ClassInstanceCount;
asm
  mov eax,[esi]
  mov eax,[eax-$44]
  mov ebx,[eax+$04]
end;

Here the subtraction of the $44 constant has been put into the opcode itself and this is smaller and faster than explicitly modifying the register. We may be looking into this issue in a later post.

Also notice that while all class VMTs have AutoTable fields, we are still using a TBasicObject class that the TFruit class is inheriting from. We may be looking at different ways of (trying to) overcome this restriction later. The blog post is running long enough already - most of you must be sleeping by now - and besides, Windows Live Writer will not let me edit in HTML mode any more (for inserting the HTML code snippets that Delphi2HTML generates for me) - seems like it has an incredibly silly 32 KB limit on editing HTML (hey, what is this, 1982??!). OTHO, it saved you from an even longer post ;)).

I'll just give Patrick the word again here at the end of the article:

I've now switched over to using vmtAutoTable completely, as you suggested. I've already applied it to all the classes we had older hacks for, and it did wonders for the speed of our query-engine, so thanks!

Well, thanks to you Patrick for sharing your ideas and hack with us! It's very interesting, but is only a small part of the puzzle. From our small email conversation, it is clear that Patrick and his colleagues in Every Angle are really a smart bunch. They have developed a very impressing architecture specialized for their extreme requirements. You can check the high-level descriptions of their SAP database analytics and data mining products here.

On a more technical level it suffices to say that they use custom and extremely compact and fast data structures, tricks and hacks to be able to represent millions and millions of objects within the constraints of a 32-bit Windows system. Throw in the use of Physical Address Extensions, storing per-class information in "virtual" class vars to reduce object instance size, creation of classes and their VMTs dynamically at runtime (!!), pointer packing, multithreading, the list just goes on and on.

Maybe we can convince Patrick to start a blog of his own, to share some of his ideas and techniques - alas, much of it may be company confidential.