Eric Grange talks about having an alternative to FreeAndNil that instead of zeroing the object pointer make it another value that signals that the reference is invalid.
http://delphitools.info/2010/02/06/dont-abuse-freeandnil-anymore/#comments
On which i commented:
Alternatively something we do is hook FreeInstance to change the v-table pointer on the heapobject just before the FreeMemory call inside it. This causes all virtual method calls on the now freed object to throw a CalledAMethodOnAFreedObject exception when the memory hasn’t yet been reused or pageprotected. The overhead is neglectible and works without replacing .Free or FreeAndNil calls.
unit ReferenceProtector;
interface
implementation
uses
SysUtils,
Windows;
type
TObjectProc = procedure of Object;
TGlobalProc = procedure;
TMyProc = procedure(Obj: Pointer);
TSmack = record
case Integer of
1:( A: TObjectProc;);
2:( C, D: Pointer;);
3:( F: TGlobalProc; E: Integer;);
4:( G: TMyProc; H: Integer;);
end;
TIntRec = record
case Integer of
1: (A: Pointer);
2: (W, X, Y, Z: Byte);
3: (B: Integer);
end;
var
NewFreeInstance: TSmack;
OldFreeInstance: Pointer;
CleanupInstance: Pointer;
OriginalCode: array[0..5] of Byte;
Freemem: Pointer;
PoisonedVTable: Pointer;
PoisonVTable: array[0..272] of Pointer;
Loaded: Boolean;
procedure RaiseReferenceProtector(Obj: Pointer);
var
s: string;
begin
s := 'ReferenceProtector: Called a virtual method on a free''ed object. '+IntToHex(Integer(Obj), 8);
try
s := s + ' of type ' + TObject(Pointer(Cardinal(Obj)+4)).ClassName + '('+IntToHex(Integer(PPointer(Cardinal(Obj)+4)^), 8)+')';
except
s := s + ' of unknown classtype.'
end;
OutputDebugString(@s[1]);
raise Exception.Create(s);
end;
procedure TObjectFreeInstanceReplacement;
asm
// CleanupInstance;
push ebx
mov ebx, eax
mov ecx, CleanupInstance
call dword ptr ecx
// Poison the vmt
mov eax, ebx
mov ecx, [eax]
mov [eax+4], ecx // delphi garuantees 8 bytes of memory minimum for any allocation
mov ecx, PoisonedVTable
mov [eax], ecx
// _FreeMem(Self);
mov ecx, FreeMem
call dword ptr ecx
pop ebx
end;
procedure SetupEnforce;
var
Proc: TSmack;
FreeInstance: TSmack;
OldFree: ^Byte;
NewFree: TIntRec;
OldProtection, Temp: DWord;
X: TObject;
{$WARN SYMBOL_DEPRECATED OFF}
MemMgr: TMemoryManager;
{$WARN SYMBOL_DEPRECATED ON}
i: Integer;
begin
PoisonedVTable := @PoisonVTable[16];
Proc.g := RaiseReferenceProtector;
for i := 0 to 272 do
PoisonVTable[i] := Proc.C;
X := TObject.Create;
FreeInstance.A := X.FreeInstance;
Proc.A := X.CleanupInstance;
X.Free;
OldFreeInstance := FreeInstance.C;
OldFree := OldFreeInstance;
CleanupInstance := Proc.C;
{$WARN SYMBOL_DEPRECATED OFF}
GetMemoryManager(MemMgr);
{$WARN SYMBOL_DEPRECATED ON}
Freemem := @MemMgr.FreeMem;
NewFreeInstance.F := TObjectFreeInstanceReplacement;
NewFree.A := @NewFreeInstance;
// allow modifying the code section
if VirtualProtect(OldFree, 8, PAGE_EXECUTE_READWRITE, @OldProtection) then
begin
// call
OriginalCode[0] := OldFree^;
OldFree^ := $ff;
Inc(OldFree);
// but no return on stack, indirect from address
OriginalCode[1] := OldFree^;
OldFree^ := $25;
Inc(OldFree);
// and then the address, per byte, wasn't sure about the endianness, below is correct
OriginalCode[2] := OldFree^;
OldFree^ := NewFree.W;
Inc(OldFree);
OriginalCode[3] := OldFree^;
OldFree^ := NewFree.X;
Inc(OldFree);
OriginalCode[4] := OldFree^;
OldFree^ := NewFree.Y;
Inc(OldFree);
OriginalCode[5] := OldFree^;
OldFree^ := NewFree.Z;
// restore old rights to code section
VirtualProtect(OldFree, 8, OldProtection, @Temp);
Loaded := True;
end
else
OutputDebugString('ReferenceProtector: Failed to set the protection of virtual calls to free''ed objects.'#13#10);
end;
procedure UnloadEnforce;
var
OldFree: ^Byte;
OldProtection, Temp: DWord;
begin
if not Loaded then
Exit;
OldFree := OldFreeInstance;
if VirtualProtect(OldFree, 8, PAGE_EXECUTE_READWRITE, @OldProtection) then
begin
OldFree^ := OriginalCode[0];
Inc(OldFree);
OldFree^ := OriginalCode[1];
Inc(OldFree);
OldFree^ := OriginalCode[2];
Inc(OldFree);
OldFree^ := OriginalCode[3];
Inc(OldFree);
OldFree^ := OriginalCode[4];
Inc(OldFree);
OldFree^ := OriginalCode[5];
VirtualProtect(OldFree, 8, OldProtection, @Temp);
Loaded := False;
end
else
OutputDebugString('ReferenceProtector: Failed to reset the protection of virtual calls to free''ed objects.'#13#10);
end;
var
OriginalMemManager: TMemoryManagerEx;
MemManager: TMemoryManagerEx;
type
ECheckingMemoryManagerException = class(Exception);
threadvar
///keep a counter per thread of number of recursive entries into AllocError
AllocErrorCounter: Integer;
procedure AllocError(Size: Integer);
begin
if (AllocErrorCounter = 0) then
begin
Inc(AllocErrorCounter);
try
// Raise an exception that the Exception logger can catch
raise ECheckingMemoryManagerException.Create('Out of memory. Size: ' + IntToStr(Size));
finally
Dec(AllocErrorCounter);
end;
end;
end;
function CheckingGetMem(Size: Integer): Pointer;
begin
Result := OriginalMemManager.GetMem((Size + 7) and $7ffffff8);
if (not Assigned(Result) and (Size <> 0)) or (Size < 0) then
AllocError(Size);
end;
// returns zero'ed memory
function CheckingAllocMem(Size: Cardinal): Pointer;
begin
if Size >= 8 then
begin
Result := OriginalMemManager.AllocMem(Size);
if Assigned(Result) then
Exit;
end
else
begin
if Size > 0 then
begin
Result := OriginalMemManager.AllocMem(8); // so that refprotector works with very small objects
if Assigned(Result) then
Exit;
end
end;
Result := nil;
if Size <> 0 then
AllocError(Size);
end;
initialization
GetMemoryManager(OriginalMemManager);
MemManager := OriginalMemManager;
MemManager.GetMem := CheckingGetMem;
MemManager.AllocMem := CheckingAllocMem;
SetMemoryManager(MemManager);
Loaded := False;
SetupEnforce;
finalization
UnloadEnforce;
SetMemoryManager(OriginalMemManager);
end.