Hunting a GExperts Code Librarian corruption bug with a custom debug memory manager

AI;DR, Delphi, GExperts 7 Minutes

AI;DR – This blog post and the debug memory manager it describes were developed with significant help from Claude. If you don’t want to read “AI slop”, stop reading now.

I recently added a new import functionality to the GExperts Code Librarian. During the test phase I found a nasty (preexisting) bug: After deleting a folder branch, the whole file became corrupted. On the next open it failed with a “Stream Read Error”. Deleting the branch had shown no error at all. From the user’s point of view the deletion had simply worked. This happened in Delphi 6, the most ancient version that GExperts still supports.

The Code Librarian stores its snippets in a single-file container based on Primoz Gabrijelcic’s GpStructuredStorage. A “Stream Read Error” on open means the container’s internal directory is inconsistent, so something had corrupted the file during the delete without complaining.

Reproducing it

The first step was a tiny console program that builds a storage file with a folder tree, deletes a branch, and reopens it. On Delphi 6 it reproduced immediately, but instead of a silent corruption it raised an EInvalidPointer right in the middle of the delete.

That difference turned out to be a useful clue rather than a contradiction. The default Delphi 6 memory manager validates frees and raises EInvalidPointer the moment something frees a bad pointer. The memory manager the DLL actually runs under inside the IDE apparently does not validate, so the same faulty free proceeds silently, the delete “succeeds”, and only the file is left broken. “No error shown to the user” did not mean “no bug”.

A bit of bracketing narrowed the trigger to something oddly specific: it only corrupted reliably when the deleted tree had more than about ten sub-folders. Fewer than that and the delete usually looked fine. That smelled like a use-after-free whose visibility depends on whether the freed memory happens to get reused in a small window.

Better tools

The problem was a delayed heap corruption: the bad free happened, but the crash only surfaced on the next unrelated heap operation. Tracing could bracket it but never name the exact line. What I needed was a memory manager that would fill freed blocks with a sentinel and shout, with a stack trace, the instant a block was touched or freed twice. On modern Delphi that is FastMM4’s FullDebugMode; on Delphi 6 there is nothing built in.

Two things helped here. First, a caching/heap bug like this is almost always version independent, so it is fair to move to a newer Delphi just for the tooling and let the fix apply everywhere (the same repro crashed identically on Delphi 6 and Delphi 2010). Second, if the tool you want does not exist, you can write a small one (or in this case: Let Claude Code write one). Delphi lets you replace the memory manager at run time with SetMemoryManager.

The result is DebugMM.pas (full source at the end). It wraps the existing memory manager and keeps a table of live pointers in memory obtained directly from VirtualAlloc, so the bookkeeping never re-enters the manager it is instrumenting. During a marked phase – I switch it on with SetActive(True) right before the delete – it quarantines freed blocks: it records them as freed, captures the call stack of the free by walking the EBP chain, and does not hand the memory back. If the same block is freed a second time, it prints both the current stack and the stack of the original free.

The stacks come out as raw return addresses. Compiling the harness with a detailed map file (-GD) and a little arithmetic (runtime address minus the image base, minus the code segment start) maps each address to a source line via the map’s line-number section.

The culprit

That immediately produced a clean double free, with the two source lines that freed the same block. The offending method was TGpStructuredFolder.DeleteEntry, and the mechanism is a textbook const-parameter aliasing trap.

DeleteAll deletes children by passing each entry’s own name field straight into DeleteEntry:

procedure TGpStructuredFolder.DeleteAll;
begin
  while CountEntries > 0 do
    if not DeleteEntry(Entry[0].FileName) then   // passes the entry's own name field
      raise EGpStructuredStorage.CreateFmt(...);
end;

DeleteEntry takes that name as a const string, which means no independent reference is taken, so the parameter aliases the string owned by the entry. It then destroys that very entry and keeps using the parameter:

function TGpStructuredFolder.DeleteEntry(const entryName: string): boolean;
...
      FAT.ReleaseChain(Entry[idxEntry].FirstFatEntry);
      sfEntries.Delete(idxEntry);                   // frees the entry, finalizing its FileName
      Flush;
      if isFolder then
        sfFolderCache_ref.Remove(Self, entryName);  // entryName is now dangling

sfEntries is a TObjectList that owns its entries, so sfEntries.Delete frees the entry and finalizes its FileName. The entryName reference that aliased it is now dangling, and the string ends up freed twice. The “more than ten sub-folders” threshold is just the amount of internal folder-cache churn needed to overwrite that freed string during the window and turn the latent bug into visible corruption.

The fix

The fix is one local variable: take a private, reference-counted copy of the name at the top of DeleteEntry and use that throughout, so destroying the entry can no longer free the string out from under the method.

function TGpStructuredFolder.DeleteEntry(const entryName: string): boolean;
var
  ...
  name: string;
begin
  // entryName is often passed the FileName of the very entry deleted below (see
  // DeleteAll). Deleting the entry frees that string, so keep a private reference.
  name := entryName;
  ... // use `name` in place of `entryName` throughout

Assigning to a local string bumps the reference count, so the buffer survives until the method returns and is freed exactly once. With the fix in place the delete completes cleanly at every scale, the file reopens without errors, and a sibling branch survives untouched.

An alternative approach would have been to simply remove the const from the parameter declaration. This would also have re-enabled reference counting and prevented the string from being freed. But that approach would have been less obvious and also prone to being reverted later in an attempt to improve performance, thus reintroducing the bug.

One more note: GpStructuredStorage is vendored into GExperts, so the fix went into the bundled copy. But the same code is still present in the current upstream GpDelphiUnits (version 2.0c), caching mechanism and all, so it has been reported upstream too.

Discussion about this in the corresponding post in the international Delphi Praxis forum.

DebugMM.pas

The debug memory manager in full. Note that the TMemoryManagerEx function signatures differ between Delphi versions (for example AllocMem takes a Cardinal while GetMem/ReallocMem take an Integer on Delphi 2010, and later versions use NativeInt); this version compiles on Delphi 2010. It is a throwaway diagnostic tool, not production code.

unit DebugMM;

// Minimal debug memory manager to catch double-free / free-of-freed during a
// marked phase. On such an event it prints the current stack and the stack of
// the original free (return addresses; map via the .map file).

interface

procedure SetActive(_Active: Boolean);

implementation

{$POINTERMATH ON}

uses
  Windows,
  SysUtils;

const
  TABLE_BITS = 21;
  TABLE_SIZE = 1 shl TABLE_BITS;
  TABLE_MASK = TABLE_SIZE - 1;
  ST_EMPTY = 0;
  ST_ALLOC = 1;
  ST_FREED = 2;
  STACK_DEPTH = 14;

type
  PEntry = ^TEntry;
  TEntry = record
    Ptr: Pointer;
    State: Integer;
    FreeStack: array[0..STACK_DEPTH - 1] of Pointer;
  end;

var
  OldMM: TMemoryManagerEx;
  Table: PEntry;
  Active: Boolean = False;
  InReport: Boolean = False;

procedure CaptureStack(var _Stack: array of Pointer);
var
  Frame: PPointer;
  i: Integer;
begin
  for i := 0 to High(_Stack) do
    _Stack[i] := nil;
  asm
    mov Frame, ebp
  end;
  i := 0;
  while (i <= High(_Stack)) and (Frame <> nil) do begin
    // return address is at [ebp+4]
    _Stack[i] := PPointer(PAnsiChar(Frame) + 4)^;
    Frame := PPointer(Frame)^;
    Inc(i);
  end;
end;

function HashIndex(_P: Pointer): Cardinal;
begin
  Result := (Cardinal(_P) * 2654435761) and TABLE_MASK;
end;

function Lookup(_P: Pointer): PEntry;
var
  idx: Cardinal;
  n: Integer;
begin
  idx := HashIndex(_P);
  n := 0;
  while n < TABLE_SIZE do begin
    Result := @Table[idx];
    if Result.State = ST_EMPTY then begin
      Result := nil;
      Exit;
    end;
    if Result.Ptr = _P then
      Exit;
    idx := (idx + 1) and TABLE_MASK;
    Inc(n);
  end;
  Result := nil;
end;

function Insert(_P: Pointer): PEntry;
var
  idx: Cardinal;
begin
  idx := HashIndex(_P);
  while Table[idx].State <> ST_EMPTY do begin
    if Table[idx].Ptr = _P then
      Break; // reuse slot (was FREED and OS gave same address again)
    idx := (idx + 1) and TABLE_MASK;
  end;
  Result := @Table[idx];
  Result.Ptr := _P;
  Result.State := ST_ALLOC;
end;

procedure PrintStack(const _Label: AnsiString; const _Stack: array of Pointer);
var
  i: Integer;
  s: AnsiString;
begin
  s := _Label;
  for i := 0 to High(_Stack) do
    if _Stack[i] <> nil then
      s := s + ' ' + AnsiString(IntToHex(Cardinal(_Stack[i]) - $400000, 6));
  s := s + #13#10;
  Write(s);
end;

procedure ReportDoubleFree(_P: Pointer; _Entry: PEntry);
var
  Cur: array[0..STACK_DEPTH - 1] of Pointer;
begin
  InReport := True;
  CaptureStack(Cur);
  Write(AnsiString('*** DOUBLE FREE of ' + IntToHex(Cardinal(_P), 8) + #13#10));
  PrintStack('CURRENT-FREE (RVA):', Cur);
  PrintStack('ORIGINAL-FREE (RVA):', _Entry.FreeStack);
  Flush(Output);
end;

function DbgGetMem(_Size: Integer): Pointer;
begin
  Result := OldMM.GetMem(_Size);
  if (Result <> nil) then
    Insert(Result).State := ST_ALLOC;
end;

function DbgFreeMem(_P: Pointer): Integer;
var
  e: PEntry;
begin
  if InReport then begin
    Result := OldMM.FreeMem(_P);
    Exit;
  end;
  e := Lookup(_P);
  if e = nil then begin
    Result := OldMM.FreeMem(_P);
    Exit;
  end;
  if e.State = ST_FREED then begin
    ReportDoubleFree(_P, e);
    Result := 0; // swallow to keep running / avoid immediate crash
    Exit;
  end;
  // state = ALLOC
  if not Active then begin
    e.State := ST_EMPTY;
    e.Ptr := nil;
    Result := OldMM.FreeMem(_P);
    Exit;
  end;
  // Active: quarantine
  e.State := ST_FREED;
  CaptureStack(e.FreeStack);
  Result := 0;
end;

function DbgReallocMem(_P: Pointer; _Size: Integer): Pointer;
var
  e: PEntry;
begin
  e := Lookup(_P);
  if (e <> nil) and (e.State = ST_FREED) then begin
    ReportDoubleFree(_P, e);
    Result := nil;
    Exit;
  end;
  if e <> nil then begin
    e.State := ST_EMPTY;
    e.Ptr := nil;
  end;
  Result := OldMM.ReallocMem(_P, _Size);
  if Result <> nil then
    Insert(Result).State := ST_ALLOC;
end;

function DbgAllocMem(_Size: Cardinal): Pointer;
begin
  Result := OldMM.AllocMem(_Size);
  if Result <> nil then
    Insert(Result).State := ST_ALLOC;
end;

function DbgRegisterExpectedMemoryLeak(_P: Pointer): Boolean;
begin
  Result := OldMM.RegisterExpectedMemoryLeak(_P);
end;

function DbgUnregisterExpectedMemoryLeak(_P: Pointer): Boolean;
begin
  Result := OldMM.UnregisterExpectedMemoryLeak(_P);
end;

procedure SetActive(_Active: Boolean);
begin
  Active := _Active;
end;

var
  NewMM: TMemoryManagerEx;

initialization
  Table := VirtualAlloc(nil, TABLE_SIZE * SizeOf(TEntry), MEM_COMMIT or MEM_RESERVE, PAGE_READWRITE);
  GetMemoryManager(OldMM);
  NewMM.GetMem := DbgGetMem;
  NewMM.FreeMem := DbgFreeMem;
  NewMM.ReallocMem := DbgReallocMem;
  NewMM.AllocMem := DbgAllocMem;
  NewMM.RegisterExpectedMemoryLeak := DbgRegisterExpectedMemoryLeak;
  NewMM.UnregisterExpectedMemoryLeak := DbgUnregisterExpectedMemoryLeak;
  SetMemoryManager(NewMM);

end.
Published