Об объектах-зомби и борьбе с ними

По мотивам - "Сокровенные" заповеди

Процитирую:

"

1. TObjectList. НИКОГДА, кроме случаев совместимости со стандартными библиотеками. Есть Tl3ObjectRefList, Tl3CObjectRefList, Tl3CBaseRefInterfacedList, Tl3SimpleObjectRefList, l3UncomparabeObjectRefList,l3ObjectRefList и т.п. Re: Утечки памяти при работе программ БЧ.

   Достаточно положить один объект в два таких списка (TObjectList) и всё. Костей не соберёшь.

"

Ну и отчасти я подсмотрел у Apple:

http://books.google.ru/books?id=fmCvjdrkoPcC&pg=PA360&lpg=PA360&dq=Mac+Os+Zombie+objects&source=bl&ots=IvOBnMHC0H&sig=ccQTEhGB3RVbOfbaWbGASxuEzus&hl=ru&sa=X&ei=rEBdVKrLOM7WPbz4gPAJ&ved=0CC4Q6AEwAg#v=onepage&q=Mac%20Os%20Zombie%20objects&f=false

http://stackoverflow.com/questions/5386160/how-to-enable-nszombie-in-xcode

http://stackoverflow.com/questions/2190227/how-do-i-set-up-nszombieenabled-in-xcode-4

http://ktatsiu.wordpress.com/2012/04/24/learn-objective-c-putting-zombies-into-your-ios-bag-of-tricks/

Процитирую:

"

What is Zombie?

It is a debugging facility from the Foundation framework that when an object is deallocated, its isa
pointer is modified (from your [super dealloc]) to be that of a runtime generated “zombie” class.

Subsequently messages sent to the zombie object cause logged message and can be put to break when running on debugger.
"

Сразу оговорюсь - я знаю про FastMem. И я конечно же читал про это - Access Violation в деталях

Да и вся речь будет в контексте Delphi без ARC.

И давайте договоримся - "языки не обсуждать". Есть языки лишённые этих проблем, но у них есть свои проблемы. И я знаю -  чём говорю.

Я буду говорить про Delphi и только про Delphi. И без ARC.

И ещё - про потокозащищённость - я тоже пока ничего говорить не буду (это опять же - отдельная тема).

Я тут занимался рефакторингом нашего кода и столкнулся с проблемой зомби-объектов.

(На самом деле там была проблема архитектуры, но это повод для отдельного поста)

Итак.

Что такое зомби-объекты?

Это объекты которые уже убиты (прошёл Destroy или FreeInstance, или - там не зря - позже объясню почему), но на которые есть ссылки у каких-то других объектов.

И самое ужасное, если по этим ссылкам другие объекты пытаются удалить наших зомби.

Почему ужасное?

Ну просто если есть "просто ссылка", то скорее всего при обращении к убитому объекту мы получим AV (если повезёт) ну или "что-то вменяемое" (если не повезёт).

Почему так?

Потому, что если объект уничтожен, то его память отдаётся менеджеру памяти.

И при следующем же распределении нового объекта эта память (если "не повезёт") может быть отдана ему.

И таким образом - ссылка на "зомби" может начать указывать на настоящий живой объект, но другой.

И вызов методов на "зомби"- ссылке - может давать "вменяемые", но "мусорные" результаты (если не повезёт), или AV (если повезёт).

Почему я пишу повезёт?

Потому, что если мы получаем AV, то его достаточно "просто" поправить.

Хотя и не без проблем. Вопрос - времени.

Другое дело - если AV нет и мы получаем какие-то "вменяемые", но "мусорные" результаты.

Их достаточно сложно диагностировать.

А вот если другой объект зовёт Free или Destroy на "зомби"-ссылке, то проблема - усугубляется.

В лучшем случае - мы получим AV.

А вот в худшем случае - получим тот факт, что убьётся новый объект, не имеющий никакого отношения к старому. У и нас появится ещё один зомби-объект.

И процесс может стать "лавинообразным".

Попробую проиллюстрировать проблемы примером:

var
 l_A : TObject;
 l_List1 : TObjectList;
 l_List2 : TObjectList;
begin
 l_A := TObject.Create;
 l_List1 := TObjectList.Create(true);
 l_List2 := TObjectList.Create(true);
 l_List1.Add(l_A);
 l_List2.Add(l_A);
 ...
 FreeAndNil(l_List1);
 // - тут всё хорошо
 ...
 FreeAndNil(l_List2);
 // - тут СКОРЕЕ всего - получим AV
end;

-- это ещё "куда ни шло", такое AV - мы скорее всего рано или поздно найдём.

Но вот другой пример:

var
 l_A : TObject;
 l_B : TObject;
 l_List1 : TObjectList;
 l_List2 : TObjectList;
begin
 l_A := TObject.Create;
 l_List1 := TObjectList.Create(true);
 l_List2 := TObjectList.Create(true);
 l_List1.Add(l_A);
 l_List2.Add(l_A);
 ...
 FreeAndNil(l_List1);
 // - тут всё хорошо
 ...
 l_B := TObject.Create;
 ...
 FreeAndNil(l_List2);
 // - тут СКОРЕЕ всего - мы НЕ получим AV, по причинам описанным выше
end;

Или ещё:

var
 l_A : TObject;
 l_B : TObject;
 l_С : TObject;
 l_List1 : TObjectList;
 l_List2 : TObjectList;
 l_List3 : TObjectList;
begin
 l_A := TObject.Create;
 l_List1 := TObjectList.Create(true);
 l_List2 := TObjectList.Create(true);
 l_List3 := TObjectList.Create(true);
 l_List1.Add(l_A);
 l_List2.Add(l_A);
 l_List3.Add(l_A);
 ...
 FreeAndNil(l_List1);
 // - тут всё хорошо
 ...
 l_B := TObject.Create;
 ...
 FreeAndNil(l_List2);
 // - тут СКОРЕЕ всего - мы НЕ получим AV, по причинам описанным выше
 ...
 l_С := TObject.Create;
 FreeAndNil(l_List3);
 // - тут вообще - "малопонятно", что будет происходить, по причинам описанным выше
end;

(Ну и ещё один "тривиальный" пример из той же серии - http://programmingmindstream.blogspot.ru/2014/11/blog-post_8.html?showComment=1415454485825#c8382170742350856545)

Что же делать?

Один из способов борьбы это - Подсчёт ссылок

Но это далеко не всегда подходит, да и не всегда является панацеей.

Можно пойти другим путём.

Можно подменить методы NewInstance и FreeInstance для "наших" объектов, а желательно для всех.

Посмотрим на код класса TObject:

  TObject = class
    constructor Create;
    procedure Free;
    class function InitInstance(Instance: Pointer): TObject;
    procedure CleanupInstance;
    function ClassType: TClass;
    class function ClassName: ShortString;
    class function ClassNameIs(const Name: string): Boolean;
    class function ClassParent: TClass;
    class function ClassInfo: Pointer;
    class function InstanceSize: Longint;
    class function InheritsFrom(AClass: TClass): Boolean;
    class function MethodAddress(const Name: ShortString): Pointer;
    class function MethodName(Address: Pointer): ShortString;
    function FieldAddress(const Name: ShortString): Pointer;
    function GetInterface(const IID: TGUID; out Obj): Boolean;
    class function GetInterfaceEntry(const IID: TGUID): PInterfaceEntry;
    class function GetInterfaceTable: PInterfaceTable;
    function SafeCallException(ExceptObject: TObject;
      ExceptAddr: Pointer): HResult; virtual;
    procedure AfterConstruction; virtual;
    procedure BeforeDestruction; virtual;
    procedure Dispatch(var Message); virtual;
    procedure DefaultHandler(var Message); virtual;
    class function NewInstance: TObject; virtual;
    procedure FreeInstance; virtual;
    destructor Destroy; virtual;
  end;

Тут приведу ещё одну полезную ссылку - Путешествуя по TObject. Или как оно работает.

И на документацию:

http://docwiki.embarcadero.com/Libraries/XE7/en/System.TObject.NewInstance

"

Description

Allocates memory for an instance of an object type and returns a pointer to that new instance.

All constructors call NewInstance automatically. NewInstance calls InstanceSize to determine how much memory containing a particular instance to allocate from the heap. Do not call NewInstance directly.

Override NewInstance only for special memory allocation requirements. For example, when allocating a large number of identical objects that all need to be in memory at the same time, you can allocate a single block of memory for the entire group, then override NewInstance to use part of that larger block for each instance.

If you override NewInstance to allocate memory, you may need to override FreeInstance to deallocate the memory.

Note: By default, NewInstance calls InitInstance.

"

http://docwiki.embarcadero.com/Libraries/XE7/en/System.TObject.FreeInstance

"

Description

Deallocates memory allocated by a previous call to the NewInstance method.

All destructors call FreeInstance automatically to deallocate memory that was allocated by overriding NewInstance.

Do not call FreeInstance directly. FreeInstance should be overridden if NewInstance was overridden to change the way the object's instance data was allocated.

Like NewInstance, FreeInstance uses the value returned from InstanceSize to deallocate the object's memory.
"

Теперь, как можно отследить проблемы в "нашем объекте"?

Напишем свой базовый TourZombieObject (а лучше бы - примесь, например - RefCounted :-) но об этом - позже):

(потом я расскажу про то как распространить это всё и на TObject)

type
 TourZombieObject = class(TObject)
    class function NewInstance: TObject; override;
    procedure FreeInstance; override;
 end;//TourZombieObject

 // - и его менеджер

 TourZobmieObjectManager = class
  class function GetObjectMem(aClass: TClass): TObject;
  class procedure FreeObjectMem(theObject: TObject);
 end;//TourZobmieObjectManager

class function TourZombieObject.NewInstance: TObject;
begin
 Result := TourZobmieObjectManager.GetObjectMem(Self);
 Result := InitInstance(Result); // - это - ВАЖНО
end;

procedure TourZombieObject.FreeInstance;
begin
 CleanupInstance; // - это - ВАЖНО
 TourZobmieObjectManager.FreeObjectMem(Self);
end;

class function TourZobmieObjectManager.GetObjectMem(aClass: TClass): TObject;
begin
 System.GetMem(Result, aClass.InstanceSize);
 FillChar(Result, aClass.InstanceSize, 0); // - это необязательно, но "для порядку"
end;

class procedure TourZobmieObjectManager.FreeObjectMem(theObject: TObject);
begin
 System.FreeMem(Pointer(theObject));
 // - а вот тут СПЕЦИАЛЬНО ничего не очищаем
end;

-- пока - ничего "необычного" - просто переопределили методы распределения и освобождения памяти объекта.

Теперь какова идея? Как мы будем ловить зомби-объекты?

Мы изменим наш менеджер памяти так, чтобы он распределял память под объект на SizeOf(Integer) больше и туда будем класть признак "разрушённости объекта".

Пока вот так:

class function TourZobmieObjectManager.GetObjectMem(aClass: TClass): TObject;
var
 l_Size : Integer;
begin
 l_Size := aClass.InstanceSize + SizeOf(Integer); // - распределяем на SizeOf(Integer) больше
 System.GetMem(Result, l_Size);
 FillChar(Result, l_Size, 0);
 Result := TObject(PAnsiChar(Result) + SizeOf(Integer)); // - сдвигаем указатель на SizeOf(Integer), слева от него у нас лежит НОЛЬ
end;

class procedure TourZobmieObjectManager.FreeObjectMem(theObject: TObject);
var
 l_P : Pointer;
begin
 l_P := Pointer(theObject); 
 l_P := PAnsiChar(l_P) - SizeOf(Integer); // - сдвигаем указатель обратно на SizeOf(Integer)
 if (PInteger(l_P)^ <> 0) then
 // - тут проверяем наш счётчик,который лежит слева от объекта
 begin
  Assert(false, 'Объект уже был удалён');
  Exit;
 end;//PInteger(l_P)^ <> 0
 Inc(PInteger(l_P)^); // - увеличиваем наш счётчик
 System.FreeMem(l_P);
 // - а вот тут СПЕЦИАЛЬНО ничего не очищаем
end;

-- что мы тут получили?

Тут мы получили - "призрачную" защиту от того, что мы поймаем нашего зомби.

Почему призрачную? А потому, что память всё равно отдаётся менеджеру памяти и что он с ней делает - мы вообще говоря - не знаем.

Но вообще говоря - мы повысили вероятность  найти наших зомби.

Что мы будем делать дальше?

Давайте постараемся "гарантировать" то, что память не будет отдана менеджеру памяти.

Это навскидку сделать - "просто":

class function TourZobmieObjectManager.GetObjectMem(aClass: TClass): TObject;
var
 l_Size : Integer;
begin
 l_Size := aClass.InstanceSize + SizeOf(Integer); // - распределяем на SizeOf(Integer) больше
 System.GetMem(Result, l_Size);
 FillChar(Result, l_Size, 0);
 Result := TObject(PAnsiChar(Result) + SizeOf(Integer)); // - сдвигаем указатель на SizeOf(Integer), слева от него у нас лежит НОЛЬ
end;

class procedure TourZobmieObjectManager.FreeObjectMem(theObject: TObject);
var
 l_P : Pointer;
begin
 l_P := Pointer(theObject); 
 l_P := PAnsiChar(l_P) - SizeOf(Integer); // - сдвигаем указатель обратно на SizeOf(Integer)
 if (PInteger(l_P)^ <> 0) then
 // - тут проверяем наш счётчик,который лежит слева от объекта
 begin
  Assert(false, 'Объект уже был удалён');
  Exit;
 end;//PInteger(l_P)^ <> 0
 Inc(PInteger(l_P)^); // - увеличиваем наш счётчик
 //System.FreeMem(l_P); - просто КОММЕНТИРУЕМ эту строку
 // - а вот тут СПЕЦИАЛЬНО ничего не очищаем
end;

- что мы тут сделали?

Мы перестали возвращать память менеджеру памяти и ещё повысили вероятность найти наших зомби.

Что мы проиграли?

Проиграли мы то, что память приложения будет только расти и "когда-нибудь" - кончится. Так - "много не наотлаживаешься".

Что делать?

Сделаем "промежуточный кеш":

class function TourZobmieObjectManager.GetObjectMem(aClass: TClass): TObject;
var
 l_Size : Integer;
begin
 l_Size := aClass.InstanceSize + SizeOf(Integer); // - распределяем на SizeOf(Integer) больше
 System.GetMem(Result, l_Size);
 FillChar(Result, l_Size, 0);
 Result := TObject(PAnsiChar(Result) + SizeOf(Integer)); // - сдвигаем указатель на SizeOf(Integer), слева от него у нас лежит НОЛЬ
end;

type
 TFreedMemory = class(TList)
  public
   procedure Clear;
 end;//TFreedMemory

procedure TFreedMemory.Clear;
var
 l_Index : Integer;
 l_P : Pointer;
begin
 for l_Index := 0 to Pred(Count) do
 // - тут освобождаем наши куски памяти
 begin
  l_P := Items[l_Index];
  System.FreeMem(l_P);
 end;//for l_Index
 inherited Clear;
end;

var
 g_FreedMemory : TFreedMemory = nil; // - этот объект может быть никогда не будет удалён 
                                     // или будет удалён не вовремя, 
                                     // но пусть пока это вас не смущает
                                     // потом можно будет сделать "нормальный" синглетон

class procedure TourZobmieObjectManager.FreeObjectMem(theObject: TObject);
const
 cOurMagicCount = 1024 * 1204; // - число неосвобождённых кусков, которые мы потерпим
var
 l_P : Pointer;
begin
 l_P := Pointer(theObject); 
 l_P := PAnsiChar(l_P) - SizeOf(Integer); // - сдвигаем указатель обратно на SizeOf(Integer)
 if (g_FreedMemory <> nil) then
 // - временный кеш был создан
 begin
  if (g_FreedMemory.Count >= cOurMagicCount) then 
  // - кеш "типа переполнился", надо его очистить
  begin
   Assert(g_FreedMemory.IndexOf(l_P) < 0, 'Объект уже был удалён'); // - тут "дополнительная проверка"
   g_FreedMemory.Clear; // - Очищаем наши куски памяти и ТЕРЯЕМ возможность для их диагностики
  end;//g_FreedMemory.Count >= cOurMagicCount
 end;//g_FreedMemory <> nil
 if (PInteger(l_P)^ <> 0) then
 // - тут проверяем наш счётчик,который лежит слева от объекта
 begin
  Assert(false, 'Объект уже был удалён');
  Exit;
 end;//PInteger(l_P)^ <> 0
 Inc(PInteger(l_P)^); // - увеличиваем наш счётчик
 if (g_FreedMemory = nil) then
  g_FreedMemory := TFreedMemory.Create;
 g_FreedMemory.Add(l_P); // - добавляем на кусок памяти в наш "временный кеш"
 //System.FreeMem(l_P); - просто КОММЕНТИРУЕМ эту строку
 // - а вот тут СПЕЦИАЛЬНО ничего не очищаем
end;

...
initialization
...
finalization
 if (l_FreedMemory <> nil) then
 begin
  g_FreedMemory.Clear; // - Очищаем наши куски памяти
  FreeAndNil(g_FreedMemory); // - Уничтожаем наш список, НЕ ФАКТ, что вовремя
 end;//l_FreedMemory <> nil

-- что мы тут сделали?

Мы по-прежнему - не отдаём память менеджеру памяти. А складываем её во "временный кеш".

Что нам это даёт?

А даёт это то, что эта память - гарантированно не будет отдана "кому-то другому". А это значит, что мы сможем контроллировать наш "флаг разрушенности".

Но при этом - если наш кеш "переполняется" (g_FreedMemory.Count >= cOurMagicCount), то мы отдаём эту память менеджеру памяти.

Тут мы несколько уменьшаем вероятность нахождения ошибки, но зато наше приложение не будет "пухнуть".

Можно ещё немного видоизменить наш код.

Удалять только один кусок памяти. Первый.

Самый рано распределённый.

Примерно так:

class function TourZobmieObjectManager.GetObjectMem(aClass: TClass): TObject;
var
 l_Size : Integer;
begin
 l_Size := aClass.InstanceSize + SizeOf(Integer); // - распределяем на SizeOf(Integer) больше
 System.GetMem(Result, l_Size);
 FillChar(Result, l_Size, 0);
 Result := TObject(PAnsiChar(Result) + SizeOf(Integer)); // - сдвигаем указатель на SizeOf(Integer), слева от него у нас лежит НОЛЬ
end;

type
 TFreedMemory = class(TList)
  public
   procedure Clear;
   procedure DeleteFirst;
 end;//TFreedMemory

procedure TFreedMemory.Clear;
var
 l_Index : Integer;
 l_P : Pointer;
begin
 for l_Index := 0 to Pred(Count) do
 // - тут освобождаем наши куски памяти
 begin
  l_P := Items[l_Index];
  System.FreeMem(l_P);
 end;//for l_Index
 inherited Clear;
end;

procedure TFreedMemory.DeleteFirst;
var
 l_P : Pointer;
begin
 l_P := Items[0];
 System.FreeMem(l_P);
 Delete(0);
end;

var
 g_FreedMemory : TFreedMemory = nil; // - этот объект может быть никогда не будет удалён 
                                     // или будет удалён не вовремя, 
                                     // но пусть пока это вас не смущает
                                     // потом можно будет сделать "нормальный" синглетон

class procedure TourZobmieObjectManager.FreeObjectMem(theObject: TObject);
const
 cOurMagicCount = 1024 * 1204; // - число неосвобождённых кусков, которые мы потерпим
var
 l_P : Pointer;
begin
 l_P := Pointer(theObject); 
 l_P := PAnsiChar(l_P) - SizeOf(Integer); // - сдвигаем указатель обратно на SizeOf(Integer)
 if (g_FreedMemory <> nil) then
 // - временный кеш был создан
 begin
  if (g_FreedMemory.Count >= cOurMagicCount) then 
  // - кеш "типа переполнился", надо его очистить
  begin
   Assert(g_FreedMemory.Items[0] <> l_P, 'Объект уже был удалён'); // - тут "дополнительная проверка"
   g_FreedMemory.DeleteFirst; // - Очищаем ПЕРВЫЙ кусок памяти и ТЕРЯЕМ возможность для его диагностики
  end;//g_FreedMemory.Count >= cOurMagicCount
 end;//g_FreedMemory <> nil
 if (PInteger(l_P)^ <> 0) then
 // - тут проверяем наш счётчик,который лежит слева от объекта
 begin
  Assert(false, 'Объект уже был удалён');
  Exit;
 end;//PInteger(l_P)^ <> 0
 Inc(PInteger(l_P)^); // - увеличиваем наш счётчик
 if (g_FreedMemory = nil) then
  g_FreedMemory := TFreedMemory.Create;
 g_FreedMemory.Add(l_P); // - добавляем на кусок памяти в наш "временный кеш"
 //System.FreeMem(l_P); - просто КОММЕНТИРУЕМ эту строку
 // - а вот тут СПЕЦИАЛЬНО ничего не очищаем
end;

...
initialization
...
finalization
 if (l_FreedMemory <> nil) then
 begin
  g_FreedMemory.Clear; // - Очищаем наши куски памяти
  FreeAndNil(g_FreedMemory); // - Уничтожаем наш список, НЕ ФАКТ, что вовремя
 end;//l_FreedMemory <> nil

Тут мы повысили вероятность найти ошибку, но согласились с тем, что приложение будет "жрать больше памяти".

Таким образом, что мы получили?

Мы получили то, что если наш объект выглядит так:

type
 TmyObject = class(TourZobmieObject)
 end;//TmyObject

-- то мы сможем диагностировать ошибки его повторного уничтожения.

Причём с точностью до строчки (за счёт Assert).

Что дальше?

Поставим вопрос - а как можно диагностировать все объекты, а не только наследники от TourZobmieObject?

Тут - варианта два:

1. Сделать примесь и подмешивать её к интересующим нас объектам. Я так обычно и делаю. Но это - отдельная тема.
2. Подменить методы TObject.NewInstance и TObject.FreeInstance. Благо они - виртуальные.

Пойдём по второму пути. Благо он - "более универсальный".

Вспомним ссылку - Путешествуя по TObject. Или как оно работает.

Как можно подменить виртуальные метод объекта (procedure FreeInstance; virtual;) - написано тут - Переменные "экземпляра мета-класса в Delphi"

Ключевые слова - VMTOffset и VirtualProtect.

Как можно подменить метод класса (class function NewInstance: TObject; virtual;) - напишу позже.

Какова идея?

А идея в том, чтобы "внедрить" методы TourZobmieObjectManager в класс TObject.

Как это сделать?

Ну примерно так:

unit ourZombieObjectManager;

interface

type
 TourZombieObjectManager = class
  ...
  class procedure HackTObject;
 end;//TourZombieObjectManager

implementation

type
 TourHackZombieObject = class(TObject)
    class function NewInstance: TObject; override;
    procedure FreeInstance; override;
 end;//TourZombieObject

class function TourHackZombieObject.NewInstance: TObject;
begin
 Result := TourZobmieObjectManager.GetObjectMem(Self);
 Result := InitInstance(Result); // - это - ВАЖНО
end;

procedure TourHackZombieObject.FreeInstance;
begin
 CleanupInstance; // - это - ВАЖНО
 TourZobmieObjectManager.FreeObjectMem(Self);
end;

type
 TNI = function () : TObject of object; // - ДА ДА of object - СОВМЕСТИМ с class function
 TFI = procedure () of object;

class procedure TourZombieObjectManager.HackTObject;
var
 l_TObject : TClass;
 l_Head : PPointer;
 l_Old  : DWORD;
 l_OldOld : DWORD;
 l_M : TMethod;
 l_NI : TNI absolute l_M;
 l_FI : TNI absolute l_M;
begin
 l_TObject := TObject;
 l_NI := TourHackZombieObject.NewInstance; 

 // далее подменяем TObject.NewInstance
 asm
  mov edx, VMTOffset TObject.NewInstance
  // или mov edx, vmtNewInstance
  mov eax, l_TObject
  add edx, eax
  mov l_Head, edx
 end;//asm

 // - в l_Head лежит указатель на VMT TObject.NewInstance

 VirtualProtect(l_Head, 4, PAGE_EXECUTE_READWRITE, @l_Old); 
 // - разрешаем писать в VMT
 PPointer(l_Head)^ := l_M.Code; 
 // - подменяем указатель TObject.NewInstance -> TourHackZombieObject.NewInstance
 VirtualProtect(l_Head, 4, l_Old, @l_OldOld);
 // - запрещаем писать в VMT

 l_FI := TourHackZombieObject(nil).FreeInstance; 
 // далее подменяем TObject.FreeInstance
 asm
  mov edx, VMTOffset TObject.FreeInstance
  // или mov edx, vmtFreeInstance
  mov eax, l_TObject
  add edx, eax
  mov l_Head, edx
 end;//asm

 // - в l_Head лежит указатель на VMT TObject.FreeInstance

 VirtualProtect(l_Head, 4, PAGE_EXECUTE_READWRITE, @l_Old);
 // - разрешаем писать в VMT
 PPointer(l_Head)^ := l_M.Code;
 // - подменяем указатель TObject.FreeInstance -> TourHackZombieObject.FreeInstance
 VirtualProtect(l_Head, 4, l_Old, @l_OldOld);
 // - запрещаем писать в VMT

end;

initialiation
 TourZombieObjectManager.HackTObject;

Ну и ещё можно посмотреть вот сюда:

{ Virtual method table entries }

  vmtSelfPtr           = -76;
  vmtIntfTable         = -72;
  vmtAutoTable         = -68;
  vmtInitTable         = -64;
  vmtTypeInfo          = -60;
  vmtFieldTable        = -56;
  vmtMethodTable       = -52;
  vmtDynamicTable      = -48;
  vmtClassName         = -44;
  vmtInstanceSize      = -40;
  vmtParent            = -36;
  vmtSafeCallException = -32 deprecated;  // don't use these constants.
  vmtAfterConstruction = -28 deprecated;  // use VMTOFFSET in asm code instead
  vmtBeforeDestruction = -24 deprecated;
  vmtDispatch          = -20 deprecated;
  vmtDefaultHandler    = -16 deprecated;
  vmtNewInstance       = -12 deprecated;
  vmtFreeInstance      = -8 deprecated;
  vmtDestroy           = -4 deprecated;

  vmtQueryInterface    = 0 deprecated;
  vmtAddRef            = 4 deprecated;
  vmtRelease           = 8 deprecated;
  vmtCreateObject      = 12 deprecated;

И сюда - System.TMethod - http://docwiki.embarcadero.com/Libraries/XE7/en/System.TMethod

-- что мы получили?

А мы получили то, что достаточно лишь первой строчкой включить в проект  uses ourZombieObjectManager - и мы получаем возможность диагностировать повторное уничтожение для всех  объектов.

У меня есть компилируемый код всего этого "хозяйства", как только я доведу его до "продакшн" - я обязательно его выложу.

Надеюсь, что это всё оказалось кому-нибудь полезным.

P.S. Если ешё сделать так:

...
class procedure TourZobmieObjectManager.FreeObjectMem(theObject: TObject);
const
 cOurMagicCount = 1024 * 1204; // - число неосвобождённых кусков, которые мы потерпим
var
 l_P : Pointer;
begin
 l_P := Pointer(theObject);
 PPointer(l_P)^ := nil; // - обнуляем указатель на VMT
 l_P := PAnsiChar(l_P) - SizeOf(Integer); // - сдвигаем указатель обратно на SizeOf(Integer)
 if (g_FreedMemory <> nil) then
 // - временный кеш был создан
 begin
  if (g_FreedMemory.Count >= cOurMagicCount) then 
  // - кеш "типа переполнился", надо его очистить
  begin
   Assert(g_FreedMemory.Items[0] <> l_P, 'Объект уже был удалён'); // - тут "дополнительная проверка"
   g_FreedMemory.DeleteFirst; // - Очищаем ПЕРВЫЙ кусок памяти и ТЕРЯЕМ возможность для его диагностики
  end;//g_FreedMemory.Count >= cOurMagicCount
 end;//g_FreedMemory <> nil
 if (PInteger(l_P)^ <> 0) then
 // - тут проверяем наш счётчик,который лежит слева от объекта
 begin
  Assert(false, 'Объект уже был удалён');
  Exit;
 end;//PInteger(l_P)^ <> 0
 Inc(PInteger(l_P)^); // - увеличиваем наш счётчик
 if (g_FreedMemory = nil) then
  g_FreedMemory := TFreedMemory.Create;
 g_FreedMemory.Add(l_P); // - добавляем на кусок памяти в наш "временный кеш"
 //System.FreeMem(l_P); - просто КОММЕНТИРУЕМ эту строку
 // - а вот тут СПЕЦИАЛЬНО ничего не очищаем
end;
...

А именно:

PPointer(l_P)^ := nil; // - обнуляем указатель на VMT

-- то вероятность нахождения ошибки без вызова деструктора - повысится. Так как мы упадём на вызове любого виртуального метода нашего зомби.