OSDN -- Develop and Download Open Source Software
  • R/O
  • SSH
Fork

Delphi-SafeMM3: Commit


Commit MetaInfo

Revision3e634bb7ca3e31f1d0dbd4491b2d33a2e4e8aca8 (tree)
Time2020-12-14 17:29:03
AuthorLevashev Ivan　卜根 <bu_ <gen@octa...>
CommiterLevashev Ivan　卜根 <bu_

Log Message

Open sourcing as is

Change Summary

Incremental Difference

diff -r 000000000000 -r 3e634bb7ca3e LICENSE.txt
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/LICENSE.txt Mon Dec 14 11:29:03 2020 +0300
@@ -0,0 +1,18 @@
1+Copyright 2020 Levashev Ivan Aleksandrovich
2+
3+Licensed under the Apache License, Version 2.0 (the "License");
4+you may not use this file except in compliance with the License.
5+You may obtain a copy of the License at
6+
7+ http://www.apache.org/licenses/LICENSE-2.0
8+
9+Unless required by applicable law or agreed to in writing, software
10+distributed under the License is distributed on an "AS IS" BASIS,
11+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
12+See the License for the specific language governing permissions and
13+limitations under the License.
14+
15+
16+Fragments of code are licensed under GPLv3 with Runtime Exception, as
17+indicated in specific files, in their header comments. COPYING3 and
18+COPYING.RUNTIME are ONLY applicable to these specific files.
diff -r 000000000000 -r 3e634bb7ca3e README.txt
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/README.txt Mon Dec 14 11:29:03 2020 +0300
@@ -0,0 +1,14 @@
1+Memory manager with ability to catch several memory errors: dangling
2+pointers and buffer overflows.
3+
4+SafeMM was for Delphi 7, SafeMM2 was for Delphi XE2. On Delphi 10.2 it was
5+broken again. It was rewritten from scratch.
6+
7+Previously used only internally, provided as is. Maybe it will be of some
8+help.
9+
10+Supported platforms so far: Windows i686 and Windows amd64.
11+
12+See video https://youtu.be/zaOqK7aDcuI
13+
14+2020, Levashev Ivan Aleksandrovich, Saint Petersburg
diff -r 000000000000 -r 3e634bb7ca3e SafeMM3.Install.pas
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/SafeMM3.Install.pas Mon Dec 14 11:29:03 2020 +0300
@@ -0,0 +1,54 @@
1+(*----------------------------------------------------------------------------
2+-- Copyright 2020 Levashev Ivan Aleksandrovich --
3+-- --
4+-- Licensed under the Apache License, Version 2.0 (the "License"); --
5+-- you may not use this file except in compliance with the License. --
6+-- You may obtain a copy of the License at --
7+-- --
8+-- http://www.apache.org/licenses/LICENSE-2.0 --
9+-- --
10+-- Unless required by applicable law or agreed to in writing, software --
11+-- distributed under the License is distributed on an "AS IS" BASIS, --
12+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. --
13+-- See the License for the specific language governing permissions and --
14+-- limitations under the License. --
15+----------------------------------------------------------------------------*)
16+
17+(***************************************************************************\
18+* Отладочный менеджер памяти *
19+*****************************************************************************
20+* - Выделяет под объекты память страницами. *
21+* - При освобождении страницы освобождаются логически, но так, что не может *
22+* тот же виртуальный адрес быть повторно использован. Обращения к *
23+* уничтоженному объекту приводят к A/V сразу на месте без шанса погулять *
24+* по висячим указателям и попортить структуры данных. *
25+* - В силу специфики менеджеров памяти не добавляется в проект. Вместо *
26+* этого в список путей поиска добавляется директория SafeMM3, а в проекте *
27+* перед всеми другими модулями указывается SafeMM3.Install. *
28+* - Принцип действия предполагает постоянный расход виртуальной памяти, так *
29+* что имеет смысл отдавать предпочтение 64разрядным сборкам. *
30+* - Даже на Win64 при полной загрузке АРМ исчерпываются ресурсы. В связи с *
31+* этим применён вероятностный подход, и вероятность задаётся аргументами *
32+* InstallDebugMemoryManager в модуле Install. На слабых рабочих станциях *
33+* придётся уменьшать. *
34+*****************************************************************************
35+* Иван Левашев, май 2020 *
36+****************************************************************************)
37+
38+unit SafeMM3.Install;
39+
40+interface
41+
42+implementation
43+
44+uses
45+ SafeMM3;
46+
47+initialization
48+ InstallDebugMemoryManager
49+ ((* RandomVirtualChance => *) 333,
50+ (* UseGuardPages => *) False,
51+ (* UseDeveloperHintPages => *) False);
52+finalization
53+ // UninstallDebugMemoryManager;
54+end.
diff -r 000000000000 -r 3e634bb7ca3e SafeMM3.pas
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/SafeMM3.pas Mon Dec 14 11:29:03 2020 +0300
@@ -0,0 +1,524 @@
1+(*----------------------------------------------------------------------------
2+-- Copyright 2020 Levashev Ivan Aleksandrovich --
3+-- --
4+-- Licensed under the Apache License, Version 2.0 (the "License"); --
5+-- you may not use this file except in compliance with the License. --
6+-- You may obtain a copy of the License at --
7+-- --
8+-- http://www.apache.org/licenses/LICENSE-2.0 --
9+-- --
10+-- Unless required by applicable law or agreed to in writing, software --
11+-- distributed under the License is distributed on an "AS IS" BASIS, --
12+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. --
13+-- See the License for the specific language governing permissions and --
14+-- limitations under the License. --
15+----------------------------------------------------------------------------*)
16+
17+(***************************************************************************\
18+* Отладочный менеджер памяти *
19+*****************************************************************************
20+* - Выделяет под объекты память страницами. *
21+* - При освобождении страницы освобождаются логически, но так, что не может *
22+* тот же виртуальный адрес быть повторно использован. Обращения к *
23+* уничтоженному объекту приводят к A/V сразу на месте без шанса походить *
24+* по висячим указателям и попортить структуры данных. *
25+* - В силу специфики менеджеров памяти не добавляется в проект. Вместо *
26+* этого в список путей поиска добавляется директория SafeMM3, а в проекте *
27+* перед всеми другими модулями указывается SafeMM3.Install. *
28+* - Принцип действия предполагает постоянный расход виртуальной памяти, так *
29+* что имеет смысл отдавать предпочтение 64разрядным сборкам. *
30+* - Даже на Win64 при полной загрузке АРМ исчерпываются ресурсы. В связи с *
31+* этим применён вероятностный подход, и вероятность задаётся аргументами *
32+* InstallDebugMemoryManager в модуле Install. На слабых рабочих станциях *
33+* придётся уменьшать. *
34+* - TThreadPool.TAbstractWorkerData.FreeInstance не вызывает inherited, а *
35+* напрямую FreeMem, что не вполне корректно и не было совместимо с *
36+* SafeMM3. Для обхода этой проблемы указатели, полученные VirtualAlloc и *
37+* vOldManager.GetMem, стало можно смешивать. *
38+*****************************************************************************
39+* Иван Левашев, май 2020 *
40+****************************************************************************)
41+
42+unit SafeMM3;
43+
44+interface
45+
46+var
47+ vRandomVirtualChance: Integer = 333;
48+
49+function DebugGetMem(Size: NativeInt): Pointer;
50+function DebugFreeMem(P: Pointer): Integer;
51+function DebugReallocMem(P: Pointer; Size: NativeInt): Pointer;
52+function DebugAllocMem(ASize: NativeInt): Pointer;
53+
54+function DebugMaybeVirtualGetMem(Size: NativeInt): PByte;
55+function DebugVirtualGetMem(Size: NativeInt): PByte;
56+function DebugNonVirtualGetMem(Size: NativeInt): PByte;
57+
58+const
59+ DebugMemoryManager: TMemoryManagerEx = (
60+ GetMem: DebugGetMem;
61+ FreeMem: DebugFreeMem;
62+ ReallocMem: DebugReallocMem;
63+ AllocMem: DebugAllocMem;
64+ RegisterExpectedMemoryLeak: nil;
65+ UnregisterExpectedMemoryLeak: nil;
66+ );
67+
68+/// <param name="RandomVirtualChance">
69+/// Шанс в промилле, что объект будет выделен VirtualAlloc
70+/// </param>
71+/// <param name="UseGuardPages">
72+/// Использовать защитные страницы после области выделенной памяти на случай,
73+/// если с объектом пытаются работать как с экземпляром, чьего класса он не
74+/// является
75+/// </param>
76+/// <param name="UseDeveloperHintPages">
77+/// Использовать ли страницы, подсказывающие разработчику, что по некоторому
78+/// адресу был выделен объект. Они расположены перед объектом, и надо
79+/// прокрутить сильно назад, чтоб их увидеть. И это только для уничтоженных
80+/// объектов. И отладчик незакоммиченные страницы может не отображать как ??,
81+/// может отображать как 00, при том, что в CPU подсказка для того же адреса
82+/// может быть [...] = ???? Размер страницы в шестнадцатеричном коде $1000,
83+/// так что насколько далеко прокручивать, должно быть легко посчитать.
84+/// Крутим вверх обзор памяти, пока не стали три последние цифры нулями, а
85+/// выше должна начаться страница, вся заполненная одним и тем же, а именно
86+/// TClass уничтоженного объекта. Можно в Evaluate/Modify запросить
87+/// TClass($....).ClassName
88+/// </param>
89+procedure InstallDebugMemoryManager
90+ (RandomVirtualChance: Integer = 333;
91+ UseGuardPages: Boolean = False;
92+ UseDeveloperHintPages: Boolean = False);
93+procedure UninstallDebugMemoryManager;
94+
95+implementation
96+
97+var
98+ vOldManager: TMemoryManagerEx;
99+ vNewInstanceAddressBegin,
100+ vNewInstanceAddressEnd,
101+ vFreeInstanceAddressBegin,
102+ vFreeInstanceAddressEnd: PByte;
103+ vPageSize, vAllocationGranularity: UInt32;
104+ vGuardSize, vDeveloperHintSize: UInt32; // vPageSize или 0
105+ vUseGuardPages: Boolean = False;
106+ vUseDeveloperHintPages: Boolean = False;
107+
108+type
109+ TSafeMM3Preamble = record
110+ FullSize: NativeInt; // отрицательные значения = обычный менеджер памяти
111+ MagicWord: UInt64; // должно быть последним полем
112+ end;
113+ PSafeMM3Preamble = ^TSafeMM3Preamble;
114+
115+const
116+ cSafeMM3MagicWord = $DEFA15EEDFBE01C0;
117+
118+type
119+ TSystemInfo = record
120+ case Integer of
121+ 0: (
122+ dwOemId: UInt32);
123+ 1: (
124+ wProcessorArchitecture: UInt16;
125+ wReserved: UInt16;
126+ dwPageSize: UInt32;
127+ lpMinimumApplicationAddress: Pointer;
128+ lpMaximumApplicationAddress: Pointer;
129+ dwActiveProcessorMask: ^UInt32;
130+ dwNumberOfProcessors: UInt32;
131+ dwProcessorType: UInt32;
132+ dwAllocationGranularity: UInt32;
133+ wProcessorLevel: UInt16;
134+ wProcessorRevision: UInt16);
135+ end;
136+procedure GetSystemInfo(var SystemInfo: TSystemInfo); stdcall;
137+ external 'kernel32.dll' name 'GetSystemInfo';
138+
139+procedure MeasureSystem;
140+type
141+ TNewInstanceHandler = function: TObject of object;
142+ TFreeInstanceHandler = procedure of object;
143+var
144+ newInstanceMethod: TNewInstanceHandler;
145+ fakeObject: TClass; // отсюда читается VMT
146+ freeInstanceMethod: TFreeInstanceHandler;
147+ systemInfo: TSystemInfo;
148+begin
149+ newInstanceMethod := TObject.NewInstance;
150+ vNewInstanceAddressBegin := TMethod(newInstanceMethod).Code;
151+ vNewInstanceAddressEnd := vNewInstanceAddressBegin + $50; // реальный размер $22
152+ fakeObject := TObject;
153+ freeInstanceMethod := TObject(@fakeObject).FreeInstance;
154+ vFreeInstanceAddressBegin := TMethod(freeInstanceMethod).Code;
155+ vFreeInstanceAddressEnd := vFreeInstanceAddressBegin + $50; // реально $29 (x64)
156+ GetSystemInfo(systemInfo);
157+ vPageSize := systemInfo.dwPageSize;
158+ vAllocationGranularity := systemInfo.dwAllocationGranularity;
159+end;
160+
161+procedure InstallDebugMemoryManager
162+ (RandomVirtualChance: Integer = 333;
163+ UseGuardPages: Boolean = False;
164+ UseDeveloperHintPages: Boolean = False);
165+begin
166+ Assert(GetHeapStatus.TotalAllocated = 0);
167+ GetMemoryManager(vOldManager);
168+ vRandomVirtualChance := RandomVirtualChance;
169+ vUseGuardPages := UseGuardPages;
170+ vUseDeveloperHintPages := UseDeveloperHintPages;
171+ SetMemoryManager(DebugMemoryManager);
172+ MeasureSystem;
173+ if UseGuardPages then begin
174+ vGuardSize := vPageSize;
175+ end
176+ else begin
177+ vGuardSize := 0;
178+ end {if};
179+ if UseDeveloperHintPages then begin
180+ vDeveloperHintSize := vPageSize;
181+ end
182+ else begin
183+ vDeveloperHintSize := 0;
184+ end {if};
185+ Randomize;
186+end;
187+
188+procedure UninstallDebugMemoryManager;
189+begin
190+ SetMemoryManager(vOldManager);
191+end;
192+
193+{$IFDEF WIN64}
194+function GetReturnAddress2: PByte;
195+// Обычный ReturnAddress возвращает адрес в System._GetMem, а нам это не
196+// интересно, нам бы надо на ещё один уровень глубже
197+
198+// В Win32 процедуры сначала копируют esp в ebp, потом уменьшают esp
199+// В Win64 процедуры сначала уменьшают rsp, потом копируют rsp в rbp
200+// Как результат, на Win32 довольно просто пробегать по стеку, а на Win64
201+// по-хорошему нужно активно обращаться к WinAPI вроде RtlLookupFunctionEntry.
202+// Пример есть в ECallStack.TEurekaBaseStackList.Caller
203+
204+// Здесь сделана попытка всё же по-простому узнавать недостающий адрес, опираясь
205+// на информацию об устройстве стека DebugGetMem и System._GetMem и т.п.
206+// функций.
207+
208+// Но из-за этого при обновлении Delphi может ломаться. Данный модуль не для
209+// релизных сборок, а для разработчиков, так что пока и так сойдёт.
210+asm
211+ // mov rax, [rbp+$30]
212+ // mov rax, [rax+$8]
213+ // // System._FreeMem не делает push rbp, вместо этого rbx
214+ // // короче, проще со стека по смещению от rsp достать
215+ mov rax, [rsp+$70]
216+end;
217+{$ENDIF WIN64}
218+{$IFDEF WIN32}
219+function GetReturnAddress2: PByte;
220+asm
221+ mov eax, [esp+$18]
222+end;
223+{$ENDIF}
224+
225+function DebugGetMem(Size: NativeInt): Pointer;
226+var
227+ returnAddress2: PByte;
228+begin
229+ returnAddress2 := GetReturnAddress2;
230+ if (returnAddress2 >= vNewInstanceAddressBegin) and
231+ (returnAddress2 <= vNewInstanceAddressEnd)
232+ then begin
233+ Result := DebugMaybeVirtualGetMem(Size);
234+ end
235+ else begin
236+ Result := DebugNonVirtualGetMem(Size);
237+ end {if};
238+end;
239+
240+function DebugReallocMem(P: Pointer; Size: NativeInt): Pointer;
241+begin
242+ // Методы TObject не вызывают ReallocMem
243+ Dec(PByte(P), SizeOf(TSafeMM3Preamble));
244+ Result := vOldManager.ReallocMem(P, SizeOf(TSafeMM3Preamble) + Size);
245+ if not Assigned(Result) then begin
246+ Exit;
247+ end {if};
248+ PSafeMM3Preamble(Result).FullSize := -(SizeOf(TSafeMM3Preamble) + Size);
249+ Inc(PByte(Result), SizeOf(TSafeMM3Preamble));
250+end;
251+
252+function DebugAllocMem(ASize: NativeInt): Pointer;
253+begin
254+ // Методы TObject не вызывают AllocMem
255+ Result := DebugNonVirtualGetMem(ASize);
256+ if Assigned(Result) then begin
257+ FillChar(Result^, ASize, 0);
258+ end {if};
259+end;
260+
261+function VirtualAlloc
262+ (lpvAddress: Pointer; dwSize: NativeUInt;
263+ flAllocationType, flProtect: UInt32): Pointer; stdcall;
264+ external 'kernel32.dll' name 'VirtualAlloc';
265+function VirtualFree
266+ (lpAddress: Pointer; dwSize: NativeUInt;
267+ dwFreeType: UInt32): LongBool; stdcall;
268+ external 'kernel32.dll' name 'VirtualFree';
269+function VirtualProtect
270+ (lpAddress: Pointer; dwSize: NativeUInt;
271+ flNewProtect: UInt32; var OldProtect: UInt32): LongBool; stdcall;
272+ external 'kernel32.dll' name 'VirtualProtect';
273+
274+const
275+ MEM_COMMIT = $00001000;
276+ MEM_RESERVE = $00002000;
277+ MEM_DECOMMIT = $00004000;
278+ MEM_RELEASE = $00008000;
279+ PAGE_NOACCESS = $01;
280+ PAGE_READONLY = $02;
281+ PAGE_READWRITE = $04;
282+
283+function DebugMaybeVirtualGetMem(Size: NativeInt): PByte;
284+begin
285+ if Random(1000) >= vRandomVirtualChance then begin
286+ // выделение обычным менеджером памяти
287+ Exit(DebugNonVirtualGetMem(Size));
288+ end
289+ else begin
290+ Exit(DebugVirtualGetMem(Size));
291+ end {if};
292+end;
293+
294+threadvar
295+ tvReservedMemory: PByte;
296+ /// <remarks>
297+ /// Округление до dwPageSize
298+ /// </remarks>
299+ tvReservedAmount: NativeInt;
300+
301+/// <summary>
302+/// Данная функция выделяет память обычным VirtualAlloc и сохраняет в
303+/// threadvar, если (а это, скорее всего, так) в блоке
304+/// dwAllocationGranularity ещё осталось пространство. Последующие вызовы по
305+/// возможности отъедают место от уже выделенного блока
306+/// </summary>
307+/// <remarks>
308+/// Для памяти не сделан MEM_COMMIT
309+/// </remarks>
310+function CompactVirtualAlloc(Size: NativeInt): PByte;
311+// VirtualAlloc из WinAPI выделяет память блоками по dwAllocationGranularity
312+// (64кб), а хотелось бы dwPageSize (4кб), ведь это разница на целый порядок
313+// Если поддерживать честный Free, то нужно было бы дополнительные структуры
314+// в памяти устраивать, чтоб распиливать dwAllocationGranularity на dwPageSize
315+// Но менеджер памяти только для отладки, и можно кое-что упростить. FreeMem
316+// реализуется через MEM_DECOMMIT, а для MEM_DECOMMIT принадлежность блоку
317+// MEM_RESERVE не важна. Только для MEM_RELEASE нужно адрес указывать на начало
318+// блока, полученного от VirtualAlloc, и он высвобождается сразу весь. Нет
319+// MEM_RELEASE, нет проблем.
320+
321+var
322+ // округление до dwPageSize
323+ sizeRoundedUpToPageSize, newFreeSpace: NativeInt;
324+
325+ // округление до dwAllocationGranularity
326+ newAllocBlockSize: NativeInt;
327+begin
328+ sizeRoundedUpToPageSize := Size + vPageSize - 1;
329+ sizeRoundedUpToPageSize := sizeRoundedUpToPageSize -
330+ (sizeRoundedUpToPageSize mod vPageSize);
331+
332+ if tvReservedAmount < sizeRoundedUpToPageSize then begin
333+ newAllocBlockSize := sizeRoundedUpToPageSize + vAllocationGranularity - 1;
334+ newAllocBlockSize := newAllocBlockSize -
335+ (newAllocBlockSize mod vAllocationGranularity);
336+
337+ Result := VirtualAlloc
338+ ((* lpvAddress => *) nil,
339+ (* dwSize => *) newAllocBlockSize,
340+ (* flAllocationType => *) MEM_RESERVE,
341+ (* flProtect => *) PAGE_NOACCESS);
342+
343+ if not Assigned(Result) then begin
344+ Exit;
345+ end {if};
346+
347+ // В новом блоке памяти свободного места может быть больше, чем старом
348+
349+ newFreeSpace := newAllocBlockSize - sizeRoundedUpToPageSize;
350+ if newFreeSpace < tvReservedAmount then begin
351+ Exit;
352+ end {if};
353+
354+ // Тогда лучше заменить на новый
355+
356+ tvReservedMemory := Result + sizeRoundedUpToPageSize;
357+ tvReservedAmount := newFreeSpace;
358+ end
359+ else if tvReservedAmount > sizeRoundedUpToPageSize then begin
360+ Result := tvReservedMemory;
361+ Inc(tvReservedMemory, sizeRoundedUpToPageSize);
362+ Dec(tvReservedAmount, sizeRoundedUpToPageSize);
363+ end
364+ else begin
365+ Result := tvReservedMemory;
366+ tvReservedMemory := nil;
367+ tvReservedAmount := 0;
368+ end {if};
369+end;
370+
371+function DebugVirtualGetMem(Size: NativeInt): PByte;
372+var
373+ fullSize: NativeInt;
374+begin
375+ fullSize :=
376+ vDeveloperHintSize + // подсказка разработчику
377+
378+ // здесь неявно присутствует выравнивание по
379+ // границе между страницами
380+
381+ SizeOf(TSafeMM3Preamble) + // преамбула
382+ ((Size + 7) and not 7) + // память объекта округлена по границе 8 байт
383+ vGuardSize; // защитная страница
384+
385+ Result := CompactVirtualAlloc(fullSize);
386+
387+ if not Assigned(Result) then begin
388+ Exit;
389+ end {if};
390+
391+ Inc(Result, vDeveloperHintSize); // у живых объектов подсказка не заполнена
392+
393+ // Выделен цельный диапазон виртуальной памяти без логической.
394+ // Теперь в этом цельном диапазоне нужно выделить страницы кроме отладочных
395+
396+ if not Assigned(VirtualAlloc
397+ ((* lpvAddress => *) Result,
398+ (* dwSize => *) fullSize - vGuardSize - vDeveloperHintSize,
399+ (* flAllocationType => *) MEM_COMMIT,
400+ (* flProtect => *) PAGE_READWRITE))
401+ then begin
402+ Exit(nil);
403+ end {if};
404+
405+ // Теперь сдвигаем Result так, чтоб прижать вплотную к защитной странице
406+
407+ Inc(Result, (vPageSize - fullSize mod vPageSize) mod vPageSize);
408+
409+ // Заполняем преамбулу
410+
411+ PSafeMM3Preamble(Result).FullSize := fullSize;
412+ PSafeMM3Preamble(Result).MagicWord := cSafeMM3MagicWord;
413+
414+ // Готовим окончательный результат
415+
416+ Inc(Result, SizeOf(TSafeMM3Preamble));
417+end;
418+
419+procedure SetupDeveloperHintPage(HintPage: PByte; WasClass: TClass);
420+type
421+ PClass = ^TClass;
422+var
423+ index: Integer;
424+ oldProtect: UInt32;
425+begin
426+ // Сначала нужно эту страницу закоммитить
427+
428+ if not Assigned(VirtualAlloc
429+ ((* lpvAddress => *) HintPage,
430+ (* dwSize => *) vDeveloperHintSize,
431+ (* flAllocationType => *) MEM_COMMIT,
432+ (* flProtect => *) PAGE_READWRITE))
433+ then begin
434+ Exit; // видимо, не будет у разработчика подсказки
435+ end {if};
436+
437+ for index := 0 to vPageSize div SizeOf(TClass) - 1 do begin
438+ PClass(HintPage + SizeOf(TClass) * index)^ := WasClass;
439+ end {loop};
440+
441+ // Для тяжёлых случаев можно ещё в страницу вставить дамп с вершины стека,
442+ // чтоб потом, при A/V, вычислять, кто уничтожил объект
443+
444+ // Закроем доступ на запись
445+
446+ VirtualProtect
447+ ((* lpAddress => *) HintPage,
448+ (* dwSize => *) vDeveloperHintSize,
449+ (* flNewProtect => *) PAGE_READONLY,
450+ (* OldProtect => *) oldProtect);
451+end;
452+
453+function DebugFreeMem(P: Pointer): Integer;
454+var
455+ fullSize: NativeInt;
456+ wasClass: TClass;
457+begin
458+ // возвращаемся к преамбуле
459+ Dec(PByte(P), SizeOf(TSafeMM3Preamble));
460+
461+ if PSafeMM3Preamble(P).MagicWord <> cSafeMM3MagicWord then begin
462+ Exit(1);
463+ end {if};
464+
465+ fullSize := PSafeMM3Preamble(P).FullSize;
466+
467+ if fullSize <= 0 then begin
468+ // память была выделена не через VirtualAlloc
469+
470+ // напоследок испортим байты так, чтобы это не было похоже на хороший
471+ // указатель
472+
473+ FillChar(P^, -fullSize, Byte($FE));
474+
475+ Exit(0); // и если уж портить, то чтоб без переиспользования
476+ // Exit(vOldManager.FreeMem(P));
477+ end {if};
478+
479+ if vUseDeveloperHintPages then begin
480+ // Класс надо успеть сохранить сейчас
481+ wasClass := TObject(PByte(P) + SizeOf(TSafeMM3Preamble)).ClassType;
482+ end {if};
483+
484+ // Возвращаемся к самому началу страницы
485+
486+ Dec(PByte(P), (vPageSize - fullSize mod vPageSize) mod vPageSize);
487+
488+ // Оставляем виртуальные адреса навечно в резерве
489+
490+ if not VirtualFree
491+ ((* lpAddress => *) P,
492+ (* dwSize => *) fullSize - vGuardSize - vDeveloperHintSize,
493+ (* dwFreeType => *) MEM_DECOMMIT)
494+ then begin
495+ Exit(1);
496+ end {if};
497+
498+ if vUseDeveloperHintPages then begin
499+ SetupDeveloperHintPage(PByte(P) - vDeveloperHintSize, wasClass);
500+ end {if};
501+
502+ Exit(0);
503+end;
504+
505+function DebugNonVirtualGetMem(Size: NativeInt): PByte;
506+begin
507+ Result := vOldManager.GetMem(SizeOf(TSafeMM3Preamble) + Size);
508+
509+ if not Assigned(Result) then begin
510+ Exit;
511+ end {if};
512+
513+ // Заполняем преамбулу
514+
515+ PSafeMM3Preamble(Result).FullSize := -(SizeOf(TSafeMM3Preamble) + Size);
516+ PSafeMM3Preamble(Result).MagicWord := cSafeMM3MagicWord;
517+
518+ // Готовим окончательный результат
519+
520+ Inc(Result, SizeOf(TSafeMM3Preamble));
521+end;
522+
523+end.
524+
Show on old repository browser