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.