1 (*
2
3 Fast Memory Manager 4.991
4
5 Description:
6 A fast replacement memory manager for Embarcadero Delphi Win32 applications
7 that scales well under multi-threaded usage, is not prone to memory
8 fragmentation, and supports shared memory without the use of external .DLL
9 files.
10
11 Homepage:
12 http://fastmm.sourceforge.net
13
14 Advantages:
15 - Fast
16 - Low overhead. FastMM is designed for an average of 5% and maximum of 10%
17 overhead per block.
18 - Supports up to 3GB of user mode address space under Windows 32-bit and 4GB
19 under Windows 64-bit. Add the "$SetPEFlags $20" option (in curly braces)
20 to your .dpr to enable this.
21 - Highly aligned memory blocks. Can be configured for either 8-byte or 16-byte
22 alignment.
23 - Good scaling under multi-threaded applications
24 - Intelligent reallocations. Avoids slow memory move operations through
25 not performing unneccesary downsizes and by having a minimum percentage
26 block size growth factor when an in-place block upsize is not possible.
27 - Resistant to address space fragmentation
28 - No external DLL required when sharing memory between the application and
29 external libraries (provided both use this memory manager)
30 - Optionally reports memory leaks on program shutdown. (This check can be set
31 to be performed only if Delphi is currently running on the machine, so end
32 users won't be bothered by the error message.)
33 - Supports Delphi 4 (or later), C++ Builder 4 (or later), Kylix 3.
34
35 Usage:
36 Delphi:
37 Place this unit as the very first unit under the "uses" section in your
38 project's .dpr file. When sharing memory between an application and a DLL
39 (e.g. when passing a long string or dynamic array to a DLL function), both the
40 main application and the DLL must be compiled using this memory manager (with
41 the required conditional defines set). There are some conditional defines
42 (inside FastMM4Options.inc) that may be used to tweak the memory manager. To
43 enable support for a user mode address space greater than 2GB you will have to
44 use the EditBin* tool to set the LARGE_ADDRESS_AWARE flag in the EXE header.
45 This informs Windows x64 or Windows 32-bit (with the /3GB option set) that the
46 application supports an address space larger than 2GB (up to 4GB). In Delphi 6
47 and later you can also specify this flag through the compiler directive
48 {$SetPEFlags $20}
49 *The EditBin tool ships with the MS Visual C compiler.
50 C++ Builder 6:
51 Refer to the instructions inside FastMM4BCB.cpp.
52
53 License:
54 This work is copyright Professional Software Development / Pierre le Riche. It
55 is released under a dual license, and you may choose to use it under either the
56 Mozilla Public License 1.1 (MPL 1.1, available from
57 http://www.mozilla.org/MPL/MPL-1.1.html) or the GNU Lesser General Public
58 License 2.1 (LGPL 2.1, available from
59 http://www.opensource.org/licenses/lgpl-license.php). If you find FastMM useful
60 or you would like to support further development, a donation would be much
61 appreciated. My banking details are:
62 Country: South Africa
63 Bank: ABSA Bank Ltd
64 Branch: Somerset West
65 Branch Code: 334-712
66 Account Name: PSD (Distribution)
67 Account No.: 4041827693
68 Swift Code: ABSAZAJJ
69 My PayPal account is:
70 bof@psd.co.za
71
72 Contact Details:
73 My contact details are shown below if you would like to get in touch with me.
74 If you use this memory manager I would like to hear from you: please e-mail me
75 your comments - good and bad.
76 Snailmail:
77 PO Box 2514
78 Somerset West
79 7129
80 South Africa
81 E-mail:
82 plr@psd.co.za
83
84 Support:
85 If you have trouble using FastMM, you are welcome to drop me an e-mail at the
86 address above, or you may post your questions in the BASM newsgroup on the
87 Embarcadero news server (which is where I hang out quite frequently).
88
89 Disclaimer:
90 FastMM has been tested extensively with both single and multithreaded
91 applications on various hardware platforms, but unfortunately I am not in a
92 position to make any guarantees. Use it at your own risk.
93
94 Acknowledgements (for version 4):
95 - Eric Grange for his RecyclerMM on which the earlier versions of FastMM were
96 based. RecyclerMM was what inspired me to try and write my own memory
97 manager back in early 2004.
98 - Primoz Gabrijelcic for helping to track down various bugs.
99 - Dennis Christensen for his tireless efforts with the Fastcode project:
100 helping to develop, optimize and debug the growing Fastcode library.
101 - JiYuan Xie for implementing the leak reporting code for C++ Builder.
102 - Sebastian Zierer for implementing the OS X support.
103 - Pierre Y. for his suggestions regarding the extension of the memory leak
104 checking options.
105 - Hanspeter Widmer for his suggestion to have an option to display install and
106 uninstall debug messages and moving options to a separate file, as well as
107 the new usage tracker.
108 - Anders Isaksson and Greg for finding and identifying the "DelphiIsRunning"
109 bug under Delphi 5.
110 - Francois Malan for various suggestions and bug reports.
111 - Craig Peterson for helping me identify the cache associativity issues that
112 could arise due to medium blocks always being an exact multiple of 256 bytes.
113 Also for various other bug reports and enhancement suggestions.
114 - Jarek Karciarz, Vladimir Ulchenko (Vavan) and Bob Gonder for their help in
115 implementing the BCB support.
116 - Ben Taylor for his suggestion to display the object class of all memory
117 leaks.
118 - Jean Marc Eber and Vincent Mahon (the Memcheck guys) for the call stack
119 trace code and also the method used to catch virtual method calls on freed
120 objects.
121 - Nahan Hyn for the suggestion to be able to enable or disable memory leak
122 reporting through a global variable (the "ManualLeakReportingControl"
123 option.)
124 - Leonel Togniolli for various suggestions with regard to enhancing the bug
125 tracking features of FastMM and other helpful advice.
126 - Joe Bain and Leonel Togniolli for the workaround to QC#10922 affecting
127 compilation under Delphi 2005.
128 - Robert Marquardt for the suggestion to make localisation of FastMM easier by
129 having all string constants together.
130 - Simon Kissel and Fikret Hasovic for their help in implementing Kylix support.
131 - Matthias Thoma, Petr Vones, Robert Rossmair and the rest of the JCL team for
132 their debug info library used in the debug info support DLL and also the
133 code used to check for a valid call site in the "raw" stack trace code.
134 - Andreas Hausladen for the suggestion to use an external DLL to enable the
135 reporting of debug information.
136 - Alexander Tabakov for various good suggestions regarding the debugging
137 facilities of FastMM.
138 - M. Skloff for some useful suggestions and bringing to my attention some
139 compiler warnings.
140 - Martin Aignesberger for the code to use madExcept instead of the JCL library
141 inside the debug info support DLL.
142 - Diederik and Dennis Passmore for the suggestion to be able to register
143 expected leaks.
144 - Dario Tiraboschi and Mark Gebauer for pointing out the problems that occur
145 when range checking and complete boolean evaluation is turned on.
146 - Arthur Hoornweg for notifying me of the image base being incorrect for
147 borlndmm.dll.
148 - Theo Carr-Brion and Hanspeter Widmer for finding the false alarm error
149 message "Block Header Has Been Corrupted" bug in FullDebugMode.
150 - Danny Heijl for reporting the compiler error in "release" mode.
151 - Omar Zelaya for reporting the BCB support regression bug.
152 - Dan Miser for various good suggestions, e.g. not logging expected leaks to
153 file, enhancements the stack trace and messagebox functionality, etc.
154 - Arjen de Ruijter for fixing the bug in GetMemoryLeakType that caused it
155 to not properly detect expected leaks registered by class when in
156 "FullDebugMode".
157 - Aleksander Oven for reporting the installation problem when trying to use
158 FastMM in an application together with libraries that all use runtime
159 packages.
160 - Kristofer Skaug for reporting the bug that sometimes causes the leak report
161 to be shown, even when all the leaks have been registered as expected leaks.
162 Also for some useful enhancement suggestions.
163 - G�nther Schoch for the "RequireDebuggerPresenceForLeakReporting" option.
164 - Jan Schl�ter for the "ForceMMX" option.
165 - Hallvard Vassbotn for various good enhancement suggestions.
166 - Mark Edington for some good suggestions and bug reports.
167 - Paul Ishenin for reporting the compilation error when the NoMessageBoxes
168 option is set and also the missing call stack entries issue when "raw" stack
169 traces are enabled, as well as for the Russian translation.
170 - Cristian Nicola for reporting the compilation bug when the
171 CatchUseOfFreedInterfaces option was enabled (4.40).
172 - Mathias Rauen (madshi) for improving the support for madExcept in the debug
173 info support DLL.
174 - Roddy Pratt for the BCB5 support code.
175 - Rene Mihula for the Czech translation and the suggestion to have dynamic
176 loading of the FullDebugMode DLL as an option.
177 - Artur Redzko for the Polish translation.
178 - Bart van der Werf for helping me solve the DLL unload order problem when
179 using the debug mode borlndmm.dll library, as well as various other
180 suggestions.
181 - JRG ("The Delphi Guy") for the Spanish translation.
182 - Justus Janssen for Delphi 4 support.
183 - Vadim Lopushansky and Charles Vinal for reporting the Delphi 5 compiler
184 error in version 4.50.
185 - Johni Jeferson Capeletto for the Brazilian Portuguese translation.
186 - Kurt Fitzner for reporting the BCB6 compiler error in 4.52.
187 - Michal Niklas for reporting the Kylix compiler error in 4.54.
188 - Thomas Speck and Uwe Queisser for German translations.
189 - Zaenal Mutaqin for the Indonesian translation.
190 - Carlos Macao for the Portuguese translation.
191 - Michael Winter for catching the performance issue when reallocating certain
192 block sizes.
193 - dzmitry[li] for the Belarussian translation.
194 - Marcelo Montenegro for the updated Spanish translation.
195 - Jud Cole for finding and reporting the bug which may trigger a read access
196 violation when upsizing certain small block sizes together with the
197 "UseCustomVariableSizeMoveRoutines" option.
198 - Zdenek Vasku for reporting and fixing the memory manager sharing bug
199 affecting Windows 95/98/Me.
200 - RB Winston for suggesting the improvement to GExperts "backup" support.
201 - Thomas Schulz for reporting the bug affecting large address space support
202 under FullDebugMode, as well as the recursive call bug when attempting to
203 report memory leaks when EnableMemoryLeakReporting is disabled.
204 - Luigi Sandon for the Italian translation.
205 - Werner Bochtler for various suggestions and bug reports.
206 - Markus Beth for suggesting the "NeverSleepOnThreadContention" option.
207 - JiYuan Xie for the Simplified Chinese translation.
208 - Andrey Shtukaturov for the updated Russian translation, as well as the
209 Ukrainian translation.
210 - Dimitry Timokhov for finding two elusive bugs in the memory leak class
211 detection code.
212 - Paulo Moreno for fixing the AllocMem bug in FullDebugMode that prevented
213 large blocks from being cleared.
214 - Vladimir Bochkarev for the suggestion to remove some unnecessary code if the
215 MM sharing mechanism is disabled.
216 - Loris Luise for the version constant suggestion.
217 - J.W. de Bokx for the MessageBox bugfix.
218 - Igor Lindunen for reporting the bug that caused the Align16Bytes option to
219 not work in FullDebugMode.
220 - Ionut Muntean for the Romanian translation.
221 - Florent Ouchet for the French translation.
222 - Marcus M�nnig for the ScanMemoryPoolForCorruptions suggestion and the
223 suggestion to have the option to scan the memory pool before every
224 operation when in FullDebugMode.
225 - Francois Piette for bringing under my attention that
226 ScanMemoryPoolForCorruption was not thread safe.
227 - Michael Rabatscher for reporting some compiler warnings.
228 - QianYuan Wang for the Simplified Chinese translation of FastMM4Options.inc.
229 - Maurizio Lotauro and Christian-W. Budde for reporting some Delphi 5
230 compiler errors.
231 - Patrick van Logchem for the DisableLoggingOfMemoryDumps option.
232 - Norbert Spiegel for the BCB4 support code.
233 - Uwe Schuster for the improved string leak detection code.
234 - Murray McGowan for improvements to the usage tracker.
235 - Michael Hieke for the SuppressFreeMemErrorsInsideException option as well
236 as a bugfix to GetMemoryMap.
237 - Richard Bradbrook for fixing the Windows 95 FullDebugMode support that was
238 broken in version 4.94.
239 - Zach Saw for the suggestion to (optionally) use SwitchToThread when
240 waiting for a lock on a shared resource to be released.
241 - Everyone who have made donations. Thanks!
242 - Any other Fastcoders or supporters that I have forgotten, and also everyone
243 that helped with the older versions.
244
245 Change log:
246 Version 1.00 (28 June 2004):
247 - First version (called PSDMemoryManager). Based on RecyclerMM (free block
248 stack approach) by Eric Grange.
249 Version 2.00 (3 November 2004):
250 - Complete redesign and rewrite from scratch. Name changed to FastMM to
251 reflect this fact. Uses a linked-list approach. Is faster, has less memory
252 overhead, and will now catch most bad pointers on FreeMem calls.
253 Version 3.00 (1 March 2005):
254 - Another rewrite. Reduced the memory overhead by: (a) not having a separate
255 memory area for the linked list of free blocks (uses space inside free
256 blocks themselves) (b) batch managers are allocated as part of chunks (c)
257 block size lookup table size reduced. This should make FastMM more CPU
258 cache friendly.
259 Version 4.00 (7 June 2005):
260 - Yet another rewrite. FastMM4 is in fact three memory managers in one: Small
261 blocks (up to a few KB) are managed through the binning model in the same
262 way as previous versions, medium blocks (from a few KB up to approximately
263 256K) are allocated in a linked-list fashion, and large blocks are grabbed
264 directly from the system through VirtualAlloc. This 3-layered design allows
265 very fast operation with the most frequently used block sizes (small
266 blocks), while also minimizing fragmentation and imparting significant
267 overhead savings with blocks larger than a few KB.
268 Version 4.01 (8 June 2005):
269 - Added the options "RequireDebugInfoForLeakReporting" and
270 "RequireIDEPresenceForLeakReporting" as suggested by Pierre Y.
271 - Fixed the "DelphiIsRunning" function not working under Delphi 5, and
272 consequently no leak checking. (Reported by Anders Isaksson and Greg.)
273 Version 4.02 (8 June 2005):
274 - Fixed the compilation error when both the "AssumeMultiThreaded" and
275 "CheckHeapForCorruption options were set. (Reported by Francois Malan.)
276 Version 4.03 (9 June 2005):
277 - Added descriptive error messages when FastMM4 cannot be installed because
278 another MM has already been installed or memory has already been allocated.
279 Version 4.04 (13 June 2005):
280 - Added a small fixed offset to the size of medium blocks (previously always
281 exact multiples of 256 bytes). This makes performance problems due to CPU
282 cache associativity limitations much less likely. (Reported by Craig
283 Peterson.)
284 Version 4.05 (17 June 2005):
285 - Added the Align16Bytes option. Disable this option to drop the 16 byte
286 alignment restriction and reduce alignment to 8 bytes for the smallest
287 block sizes. Disabling Align16Bytes should lower memory consumption at the
288 cost of complicating the use of aligned SSE move instructions. (Suggested
289 by Craig Peterson.)
290 - Added a support unit for C++ Builder 6 - Add FastMM4BCB.cpp and
291 FastMM4.pas to your BCB project to use FastMM instead of the RTL MM. Memory
292 leak checking is not supported because (unfortunately) once an MM is
293 installed under BCB you cannot uninstall it... at least not without
294 modifying the RTL code in exit.c or patching the RTL code runtime. (Thanks
295 to Jarek Karciarz, Vladimir Ulchenko and Bob Gonder.)
296 Version 4.06 (22 June 2005):
297 - Displays the class of all leaked objects on the memory leak report and also
298 tries to identify leaked long strings. Previously it only displayed the
299 sizes of all leaked blocks. (Suggested by Ben Taylor.)
300 - Added support for displaying the sizes of medium and large block memory
301 leaks. Previously it only displayed details for small block leaks.
302 Version 4.07 (22 June 2005):
303 - Fixed the detection of the class of leaked objects not working under
304 Windows 98/Me.
305 Version 4.08 (27 June 2005):
306 - Added a BorlndMM.dpr project to allow you to build a borlndmm.dll that uses
307 FastMM4 instead of the default memory manager. You may replace the old
308 DLL in the Delphi \Bin directory to make the IDE use this memory manager
309 instead.
310 Version 4.09 (30 June 2005):
311 - Included a patch fix for the bug affecting replacement borlndmm.dll files
312 with Delphi 2005 (QC#14007). Compile the patch, close Delphi, and run it
313 once to patch your vclide90.bpl. You will now be able to use the
314 replacement borlndmm.dll to speed up the Delphi 2005 IDE as well.
315 Version 4.10 (7 July 2005):
316 - Due to QC#14070 ("Delphi IDE attempts to free memory after the shutdown
317 code of borlndmm.dll has been called"), FastMM cannot be uninstalled
318 safely when used inside a replacement borlndmm.dll for the IDE. Added a
319 conditional define "NeverUninstall" for this purpose.
320 - Added the "FullDebugMode" option to pad all blocks with a header and footer
321 to help you catch memory overwrite bugs in your applications. All blocks
322 returned to freemem are also zeroed out to help catch bugs involving the
323 use of previously freed blocks. Also catches attempts at calling virtual
324 methods of freed objects provided the block in question has not been reused
325 since the object was freed. Displays stack traces on error to aid debugging.
326 - Added the "LogErrorsToFile" option to log all errors to a text file in the
327 same folder as the application.
328 - Added the "ManualLeakReportingControl" option (suggested by Nahan Hyn) to
329 enable control over whether the memory leak report should be done or not
330 via a global variable.
331 Version 4.11 (7 July 2005):
332 - Fixed a compilation error under Delphi 2005 due to QC#10922. (Thanks to Joe
333 Bain and Leonel Togniolli.)
334 - Fixed leaked object classes not displaying in the leak report in
335 "FullDebugMode".
336 Version 4.12 (8 July 2005):
337 - Moved all the string constants to one place to make it easier to do
338 translations into other languages. (Thanks to Robert Marquardt.)
339 - Added support for Kylix. Some functionality is currently missing: No
340 support for detecting the object class on leaks and also no MM sharing.
341 (Thanks to Simon Kissel and Fikret Hasovic).
342 Version 4.13 (11 July 2005):
343 - Added the FastMM_DebugInfo.dll support library to display debug info for
344 stack traces.
345 - Stack traces for the memory leak report is now logged to the log file in
346 "FullDebugMode".
347 Version 4.14 (14 July 2005):
348 - Fixed string leaks not being detected as such in "FullDebugMode". (Thanks
349 to Leonel Togniolli.)
350 - Fixed the compilation error in "FullDebugMode" when "LogErrorsToFile" is
351 not set. (Thanks to Leonel Togniolli.)
352 - Added a "Release" option to allow the grouping of various options and to
353 make it easier to make debug and release builds. (Thanks to Alexander
354 Tabakov.)
355 - Added a "HideMemoryLeakHintMessage" option to not display the hint below
356 the memory leak message. (Thanks to Alexander Tabakov.)
357 - Changed the fill character for "FullDebugMode" from zero to $80 to be able
358 to differentiate between invalid memory accesses using nil pointers to
359 invalid memory accesses using fields of freed objects. FastMM tries to
360 reserve the 64K block starting at $80800000 at startup to ensure that an
361 A/V will occur when this block is accessed. (Thanks to Alexander Tabakov.)
362 - Fixed some compiler warnings. (Thanks to M. Skloff)
363 - Fixed some display bugs in the memory leak report. (Thanks to Leonel
364 Togniolli.)
365 - Added a "LogMemoryLeakDetailToFile" option. Some applications leak a lot of
366 memory and can make the log file grow very large very quickly.
367 - Added the option to use madExcept instead of the JCL Debug library in the
368 debug info support DLL. (Thanks to Martin Aignesberger.)
369 - Added procedures "GetMemoryManagerState" and "GetMemoryMap" to retrieve
370 statistics about the current state of the memory manager and memory pool.
371 (A usage tracker form together with a demo is also available.)
372 Version 4.15 (14 July 2005):
373 - Fixed a false 4GB(!) memory leak reported in some instances.
374 Version 4.16 (15 July 2005):
375 - Added the "CatchUseOfFreedInterfaces" option to catch the use of interfaces
376 of freed objects. This option is not compatible with checking that a freed
377 block has not been modified, so enable this option only when hunting an
378 invalid interface reference. (Only relevant if "FullDebugMode" is set.)
379 - During shutdown FastMM now checks that all free blocks have not been
380 modified since being freed. (Only when "FullDebugMode" is set and
381 "CatchUseOfFreedInterfaces" is disabled.)
382 Version 4.17 (15 July 2005):
383 - Added the AddExpectedMemoryLeaks and RemoveExpectedMemoryLeaks procedures to
384 register/unregister expected leaks, thus preventing the leak report from
385 displaying if only expected leaks occurred. (Thanks to Diederik and Dennis
386 Passmore for the suggestion.) (Note: these functions were renamed in later
387 versions.)
388 - Fixed the "LogMemoryLeakDetailToFile" not logging memory leak detail to file
389 as it is supposed to. (Thanks to Leonel Togniolli.)
390 Version 4.18 (18 July 2005):
391 - Fixed some issues when range checking or complete boolean evaluation is
392 switched on. (Thanks to Dario Tiraboschi and Mark Gebauer.)
393 - Added the "OutputInstallUninstallDebugString" option to display a message when
394 FastMM is installed or uninstalled. (Thanks to Hanspeter Widmer.)
395 - Moved the options to a separate include file. (Thanks to Hanspeter Widmer.)
396 - Moved message strings to a separate file for easy translation.
397 Version 4.19 (19 July 2005):
398 - Fixed Kylix support that was broken in 4.14.
399 Version 4.20 (20 July 2005):
400 - Fixed a false memory overwrite report at shutdown in "FullDebugMode". If you
401 consistently got a "Block Header Has Been Corrupted" error message during
402 shutdown at address $xxxx0070 then it was probably a false alarm. (Thanks to
403 Theo Carr-Brion and Hanspeter Widmer.}
404 Version 4.21 (27 July 2005):
405 - Minor change to the block header flags to make it possible to immediately
406 tell whether a medium block is being used as a small block pool or not.
407 (Simplifies the leak checking and status reporting code.)
408 - Expanded the functionality around the management of expected memory leaks.
409 - Added the "ClearLogFileOnStartup" option. Deletes the log file during
410 initialization. (Thanks to M. Skloff.)
411 - Changed "OutputInstallUninstallDebugString" to use OutputDebugString instead
412 of MessageBox. (Thanks to Hanspeter Widmer.)
413 Version 4.22 (1 August 2005):
414 - Added a FastAllocMem function that avoids an unnecessary FillChar call with
415 large blocks.
416 - Changed large block resizing behavior to be a bit more conservative. Large
417 blocks will be downsized if the new size is less than half of the old size
418 (the threshold was a quarter previously).
419 Version 4.23 (6 August 2005):
420 - Fixed BCB6 support (Thanks to Omar Zelaya).
421 - Renamed "OutputInstallUninstallDebugString" to "UseOutputDebugString", and
422 added debug string output on memory leak or error detection.
423 Version 4.24 (11 August 2005):
424 - Added the "NoMessageBoxes" option to suppress the display of message boxes,
425 which is useful for services that should not be interrupted. (Thanks to Dan
426 Miser).
427 - Changed the stack trace code to return the line number of the caller and not
428 the line number of the return address. (Thanks to Dan Miser).
429 Version 4.25 (15 August 2005):
430 - Fixed GetMemoryLeakType not detecting expected leaks registered by class
431 when in "FullDebugMode". (Thanks to Arjen de Ruijter).
432 Version 4.26 (18 August 2005):
433 - Added a "UseRuntimePackages" option that allows FastMM to be used in a main
434 application together with DLLs that all use runtime packages. (Thanks to
435 Aleksander Oven.)
436 Version 4.27 (24 August 2005):
437 - Fixed a bug that sometimes caused the leak report to be shown even though all
438 leaks were registered as expected leaks. (Thanks to Kristofer Skaug.)
439 Version 4.29 (30 September 2005):
440 - Added the "RequireDebuggerPresenceForLeakReporting" option to only display
441 the leak report if the application is run inside the IDE. (Thanks to G�nther
442 Schoch.)
443 - Added the "ForceMMX" option, which when disabled will check the CPU for
444 MMX compatibility before using MMX. (Thanks to Jan Schl�ter.)
445 - Added the module name to the title of error dialogs to more easily identify
446 which application caused the error. (Thanks to Kristofer Skaug.)
447 - Added an ASCII dump to the "FullDebugMode" memory dumps. (Thanks to Hallvard
448 Vassbotn.)
449 - Added the option "HideExpectedLeaksRegisteredByPointer" to suppress the
450 display and logging of expected memory leaks that were registered by pointer.
451 (Thanks to Dan Miser.) Leaks registered by size or class are often ambiguous,
452 so these expected leaks are always logged to file (in FullDebugMode) and are
453 never hidden from the leak display (only displayed if there is at least one
454 unexpected leak).
455 - Added a procedure "GetRegisteredMemoryLeaks" to return a list of all
456 registered memory leaks. (Thanks to Dan Miser.)
457 - Added the "RawStackTraces" option to perform "raw" stack traces, negating
458 the need for stack frames. This will usually result in more complete stack
459 traces in FullDebugMode error reports, but it is significantly slower.
460 (Thanks to Hallvard Vassbotn, Dan Miser and the JCL team.)
461 Version 4.31 (2 October 2005):
462 - Fixed the crash bug when both "RawStackTraces" and "FullDebugMode" were
463 enabled. (Thanks to Dan Miser and Mark Edington.)
464 Version 4.33 (6 October 2005):
465 - Added a header corruption check to all memory blocks that are identified as
466 leaks in FullDebugMode. This allows better differentiation between memory
467 pool corruption bugs and actual memory leaks.
468 - Fixed the stack overflow bug when using "RawStackTraces".
469 Version 4.35 (6 October 2005):
470 - Fixed a compilation error when the "NoMessageBoxes" option is set. (Thanks
471 to Paul Ishenin.)
472 - Before performing a "raw" stack trace, FastMM now checks whether exception
473 handling is in place. If exception handling is not in place FastMM falls
474 back to stack frame tracing. (Exception handling is required to handle the
475 possible A/Vs when reading invalid call addresses. Exception handling is
476 usually always available except when SysUtils hasn't been initialized yet or
477 after SysUtils has been finalized.)
478 Version 4.37 (8 October 2005):
479 - Fixed the missing call stack trace entry issue when dynamically loading DLLs.
480 (Thanks to Paul Ishenin.)
481 Version 4.39 (12 October 2005):
482 - Restored the performance with "RawStackTraces" enabled back to the level it
483 was in 4.35.
484 - Fixed the stack overflow error when using "RawStackTraces" that I thought I
485 had fixed in 4.31, but unfortunately didn't. (Thanks to Craig Peterson.)
486 Version 4.40 (13 October 2005):
487 - Improved "RawStackTraces" to have less incorrect extra entries. (Thanks to
488 Craig Peterson.)
489 - Added the Russian (by Paul Ishenin) and Afrikaans translations of
490 FastMM4Messages.pas.
491 Version 4.42 (13 October 2005):
492 - Fixed the compilation error when "CatchUseOfFreedInterfaces" is enabled.
493 (Thanks to Cristian Nicola.)
494 Version 4.44 (25 October 2005):
495 - Implemented a FastGetHeapStatus function in analogy with GetHeapStatus.
496 (Suggested by Cristian Nicola.)
497 - Shifted more of the stack trace code over to the support dll to allow third
498 party vendors to make available their own stack tracing and stack trace
499 logging facilities.
500 - Mathias Rauen (madshi) improved the support for madExcept in the debug info
501 support DLL. Thanks!
502 - Added support for BCB5. (Thanks to Roddy Pratt.)
503 - Added the Czech translation by Rene Mihula.
504 - Added the "DetectMMOperationsAfterUninstall" option. This will catch
505 attempts to use the MM after FastMM has been uninstalled, and is useful for
506 debugging.
507 Version 4.46 (26 October 2005):
508 - Renamed FastMM_DebugInfo.dll to FastMM_FullDebugMode.dll and made the
509 dependency on this library a static one. This solves a DLL unload order
510 problem when using FullDebugMode together with the replacement
511 borlndmm.dll. (Thanks to Bart van der Werf.)
512 - Added the Polish translation by Artur Redzko.
513 Version 4.48 (10 November 2005):
514 - Fixed class detection for objects leaked in dynamically loaded DLLs that
515 were relocated.
516 - Fabio Dell'Aria implemented support for EurekaLog in the FullDebugMode
517 support DLL. Thanks!
518 - Added the Spanish translation by JRG ("The Delphi Guy").
519 Version 4.49 (10 November 2005):
520 - Implemented support for installing replacement AllocMem and leak
521 registration mechanisms for Delphi/BCB versions that support it.
522 - Added support for Delphi 4. (Thanks to Justus Janssen.)
523 Version 4.50 (5 December 2005):
524 - Renamed the ReportMemoryLeaks global variable to ReportMemoryLeaksOnShutdown
525 to be more consistent with the Delphi 2006 memory manager.
526 - Improved the handling of large blocks. Large blocks can now consist of
527 several consecutive segments allocated through VirtualAlloc. This
528 significantly improves speed when frequently resizing large blocks, since
529 these blocks can now often be upsized in-place.
530 Version 4.52 (7 December 2005):
531 - Fixed the compilation error with Delphi 5. (Thanks to Vadim Lopushansky and
532 Charles Vinal for reporting the error.)
533 Version 4.54 (15 December 2005):
534 - Added the Brazilian Portuguese translation by Johni Jeferson Capeletto.
535 - Fixed the compilation error with BCB6. (Thanks to Kurt Fitzner.)
536 Version 4.56 (20 December 2005):
537 - Fixed the Kylix compilation problem. (Thanks to Michal Niklas.)
538 Version 4.58 (1 February 2006):
539 - Added the German translations by Thomas Speck and Uwe Queisser.
540 - Added the Indonesian translation by Zaenal Mutaqin.
541 - Added the Portuguese translation by Carlos Macao.
542 Version 4.60 (21 February 2006):
543 - Fixed a performance issue due to an unnecessary block move operation when
544 allocating a block in the range 1261-1372 bytes and then reallocating it in
545 the range 1373-1429 bytes twice. (Thanks to Michael Winter.)
546 - Added the Belarussian translation by dzmitry[li].
547 - Added the updated Spanish translation by Marcelo Montenegro.
548 - Added a new option "EnableSharingWithDefaultMM". This option allows FastMM
549 to be shared with the default MM of Delphi 2006. It is on by default, but
550 MM sharing has to be enabled otherwise it has no effect (refer to the
551 documentation for the "ShareMM" and "AttemptToUseSharedMM" options).
552 Version 4.62 (22 February 2006):
553 - Fixed a possible read access violation in the MoveX16LP routine when the
554 UseCustomVariableSizeMoveRoutines option is enabled. (Thanks to Jud Cole for
555 some great detective work in finding this bug.)
556 - Improved the downsizing behaviour of medium blocks to better correlate with
557 the reallocation behaviour of small blocks. This change reduces the number
558 of transitions between small and medium block types when reallocating blocks
559 in the 0.7K to 2.6K range. It cuts down on the number of memory move
560 operations and improves performance.
561 Version 4.64 (31 March 2006):
562 - Added the following functions for use with FullDebugMode (and added the
563 exports to the replacement BorlndMM.dll): SetMMLogFileName,
564 GetCurrentAllocationGroup, PushAllocationGroup, PopAllocationGroup and
565 LogAllocatedBlocksToFile. The purpose of these functions are to allow you to
566 identify and log related memory leaks while your application is still
567 running.
568 - Fixed a bug in the memory manager sharing mechanism affecting Windows
569 95/98/ME. (Thanks to Zdenek Vasku.)
570 Version 4.66 (9 May 2006):
571 - Added a hint comment in this file so that FastMM4Messages.pas will also be
572 backed up by GExperts. (Thanks to RB Winston.)
573 - Fixed a bug affecting large address space (> 2GB) support under
574 FullDebugMode. (Thanks to Thomas Schulz.)
575 Version 4.68 (3 July 2006):
576 - Added the Italian translation by Luigi Sandon.
577 - If FastMM is used inside a DLL it will now use the name of the DLL as base
578 for the log file name. (Previously it always used the name of the main
579 application executable file.)
580 - Fixed a rare A/V when both the FullDebugMode and RawStackTraces options were
581 enabled. (Thanks to Primoz Gabrijelcic.)
582 - Added the "NeverSleepOnThreadContention" option. This option may improve
583 performance if the ratio of the the number of active threads to the number
584 of CPU cores is low (typically < 2). This option is only useful for 4+ CPU
585 systems, it almost always hurts performance on single and dual CPU systems.
586 (Thanks to Werner Bochtler and Markus Beth.)
587 Version 4.70 (4 August 2006):
588 - Added the Simplified Chinese translation by JiYuan Xie.
589 - Added the updated Russian as well as the Ukrainian translation by Andrey
590 Shtukaturov.
591 - Fixed two bugs in the leak class detection code that would sometimes fail
592 to detect the class of leaked objects and strings, and report them as
593 'unknown'. (Thanks to Dimitry Timokhov)
594 Version 4.72 (24 September 2006):
595 - Fixed a bug that caused AllocMem to not clear blocks > 256K in
596 FullDebugMode. (Thanks to Paulo Moreno.)
597 Version 4.74 (9 November 2006):
598 - Fixed a bug in the segmented large block functionality that could lead to
599 an application freeze when upsizing blocks greater than 256K in a
600 multithreaded application (one of those "what the heck was I thinking?"
601 type bugs).
602 Version 4.76 (12 January 2007):
603 - Changed the RawStackTraces code in the FullDebugMode DLL
604 to prevent it from modifying the Windows "GetLastError" error code.
605 (Thanks to Primoz Gabrijelcic.)
606 - Fixed a threading issue when the "CheckHeapForCorruption" option was
607 enabled, but the "FullDebugMode" option was disabled. (Thanks to Primoz
608 Gabrijelcic.)
609 - Removed some unnecessary startup code when the MM sharing mechanism is
610 disabled. (Thanks to Vladimir Bochkarev.)
611 - In FullDebugMode leaked blocks would sometimes be reported as belonging to
612 the class "TFreedObject" if they were allocated but never used. Such blocks
613 will now be reported as "unknown". (Thanks to Francois Malan.)
614 - In recent versions the replacement borlndmm.dll created a log file (when
615 enabled) that used the "borlndmm" prefix instead of the application name.
616 It is now fixed to use the application name, however if FastMM is used
617 inside other DLLs the name of those DLLs will be used. (Thanks to Bart van
618 der Werf.)
619 - Added a "FastMMVersion" constant. (Suggested by Loris Luise.)
620 - Fixed an issue with error message boxes not displaying under certain
621 configurations. (Thanks to J.W. de Bokx.)
622 - FastMM will now display only one error message at a time. If many errors
623 occur in quick succession, only the first error will be shown (but all will
624 be logged). This avoids a stack overflow with badly misbehaved programs.
625 (Thanks to Bart van der Werf.)
626 - Added a LoadDebugDLLDynamically option to be used in conjunction with
627 FullDebugMode. In this mode FastMM_FullDebugMode.dll is loaded dynamically.
628 If the DLL cannot be found, stack traces will not be available. (Thanks to
629 Rene Mihula.)
630 Version 4.78 (1 March 2007):
631 - The MB_DEFAULT_DESKTOP_ONLY constant that is used when displaying messages
632 boxes since 4.76 is not defined under Kylix, and the source would thus not
633 compile. That constant is now defined. (Thanks to Werner Bochtler.)
634 - Moved the medium block locking code that was duplicated in several places
635 to a subroutine to reduce code size. (Thanks to Hallvard Vassbotn.)
636 - Fixed a bug in the leak registration code that sometimes caused registered
637 leaks to be reported erroneously. (Thanks to Primoz Gabrijelcic.)
638 - Added the NoDebugInfo option (on by default) that suppresses the generation
639 of debug info for the FastMM4.pas unit. This will prevent the integrated
640 debugger from stepping into the memory manager. (Thanks to Primoz
641 Gabrijelcic.)
642 - Increased the default stack trace depth in FullDebugMode from 9 to 10 to
643 ensure that the Align16Bytes setting works in FullDebugMode. (Thanks to
644 Igor Lindunen.)
645 - Updated the Czech translation. (Thanks to Rene Mihula.)
646 Version 4.84 (7 July 2008):
647 - Added the Romanian translation. (Thanks to Ionut Muntean.)
648 - Optimized the GetMemoryMap procedure to improve speed.
649 - Added the GetMemoryManagerUsageSummary function that returns a summary of
650 the GetMemoryManagerState call. (Thanks to Hallvard Vassbotn.)
651 - Added the French translation. (Thanks to Florent Ouchet.)
652 - Added the "AlwaysAllocateTopDown" FullDebugMode option to help with
653 catching bad pointer arithmetic code in an address space > 2GB. This option
654 is enabled by default.
655 - Added the "InstallOnlyIfRunningInIDE" option. Enable this option to
656 only install FastMM as the memory manager when the application is run
657 inside the Delphi IDE. This is useful when you want to deploy the same EXE
658 that you use for testing, but only want the debugging features active on
659 development machines. When this option is enabled and the application is
660 not being run inside the IDE, then the default Delphi memory manager will
661 be used (which, since Delphi 2006, is FastMM without FullDebugMode.) This
662 option is off by default.
663 - Added the "FullDebugModeInIDE" option. This is a convenient shorthand for
664 enabling FullDebugMode, InstallOnlyIfRunningInIDE and
665 LoadDebugDLLDynamically. This causes FastMM to be used in FullDebugMode
666 when the application is being debugged on development machines, and the
667 default memory manager when the same executable is deployed. This allows
668 the debugging and deployment of an application without having to compile
669 separate executables. This option is off by default.
670 - Added a ScanMemoryPoolForCorruptions procedure that checks the entire
671 memory pool for corruptions and raises an exception if one is found. It can
672 be called at any time, but is only available in FullDebugMode. (Thanks to
673 Marcus M�nnig.)
674 - Added a global variable "FullDebugModeScanMemoryPoolBeforeEveryOperation".
675 When this variable is set to true and FullDebugMode is enabled, then the
676 entire memory pool is checked for consistency before every GetMem, FreeMem
677 and ReallocMem operation. An "Out of Memory" error is raised if a
678 corruption is found (and this variable is set to false to prevent recursive
679 errors). This obviously incurs a massive performance hit, so enable it only
680 when hunting for elusive memory corruption bugs. (Thanks to Marcus M�nnig.)
681 - Fixed a bug in AllocMem that caused the FPU stack to be shifted by one
682 position.
683 - Changed the default for option "EnableMMX" to false, since using MMX may
684 cause unexpected behaviour in code that passes parameters on the FPU stack
685 (like some "compiler magic" routines, e.g. VarFromReal).
686 - Removed the "EnableSharingWithDefaultMM" option. This is now the default
687 behaviour and cannot be disabled. (FastMM will always try to share memory
688 managers between itself and the default memory manager when memory manager
689 sharing is enabled.)
690 - Introduced a new memory manager sharing mechanism based on memory mapped
691 files. This solves compatibility issues with console and service
692 applications. This sharing mechanism currently runs in parallel with the
693 old mechanism, but the old mechanism can be disabled by undefining
694 "EnableBackwardCompatibleMMSharing" in FastMM4Options.inc.
695 - Fixed the recursive call error when the EnableMemoryLeakReporting option
696 is disabled and an attempt is made to register a memory leak under Delphi
697 2006 or later. (Thanks to Thomas Schulz.)
698 - Added a global variable "SuppressMessageBoxes" to enable or disable
699 messageboxes at runtime. (Thanks to Craig Peterson.)
700 - Added the leak reporting code for C++ Builder, as well as various other
701 C++ Builder bits written by JiYuan Xie. (Thank you!)
702 - Added the new Usage Tracker written by Hanspeter Widmer. (Thank you!)
703 Version 4.86 (31 July 2008):
704 - Tweaked the string detection algorithm somewhat to be less strict, and
705 allow non-class leaks to be more often categorized as strings.
706 - Fixed a compilation error under Delphi 5.
707 - Made LogAllocatedBlocksToFile and ScanMemoryPoolForCorruptions thread
708 safe. (Thanks to Francois Piette.)
709 Version 4.88 (13 August 2008):
710 - Fixed compiler warnings in NoOpRegisterExpectedMemoryLeak and
711 NoOpUnRegisterExpectedMemoryLeak. (Thanks to Michael Rabatscher.)
712 - Added the Simplified Chinese translation of FastMM4Options.inc by
713 QianYuan Wang. (Thank you!)
714 - Included the updated C++ Builder files with support for BCB6 without
715 update 4 applied. (Submitted by JiYuan Xie. Thanks!)
716 - Fixed a compilation error under Delphi 5.
717 - Made LogAllocatedBlocksToFile and ScanMemoryPoolForCorruptions thread
718 safe - for real this time. (Thanks to Francois Piette.)
719 Version 4.90 (9 September 2008):
720 - Added logging of the thread ID when capturing and displaying stack
721 traces. (Suggested by Allen Bauer and Mark Edington.)
722 - Fixed a Delphi 5 compiler error under FullDebugMode. (Thanks to Maurizio
723 Lotauro and Christian-W. Budde.)
724 - Changed a default setting in FastMM4Options.inc: RawStackTraces is now
725 off by default due to the high number of support requests I receive with
726 regards to the false postives it may cause. I recommend compiling debug
727 builds of applications with the "Stack Frames" option enabled.
728 - Fixed a compilation error under Kylix. (Thanks to Werner Bochtler.)
729 - Official support for Delphi 2009.
730 Version 4.92 (25 November 2008):
731 - Added the DisableLoggingOfMemoryDumps option under FullDebugMode. When
732 this option is set, memory dumps will not be logged for memory leaks or
733 errors. (Thanks to Patrick van Logchem.)
734 - Exposed the class and string type detection code in the interface section
735 for use in application code (if required). (Requested by Patrick van
736 Logchem.)
737 - Fixed a bug in SetMMLogFileName that could cause the log file name to be
738 set incorrectly.
739 - Added BCB4 support. (Thanks to Norbert Spiegel.)
740 - Included the updated Czech translation by Rene Mihula.
741 - When FastMM raises an error due to a freed block being modified, it now
742 logs detail about which bytes in the block were modified.
743 Version 4.94 (28 August 2009):
744 - Added the DoNotInstallIfDLLMissing option that prevents FastMM from
745 installing itself if the FastMM_FullDebugMode.dll library is not
746 available. (Only applicable when FullDebugMode and LoadDebugDLLDynamically
747 are both enabled.) This is useful when the same executable will be used for
748 both debugging and deployment - when the debug support DLL is available
749 FastMM will be installed in FullDebugMode, and otherwise the default memory
750 manager will be used.
751 - Added the FullDebugModeWhenDLLAvailable option that combines the
752 FullDebugMode, LoadDebugDLLDynamically and DoNotInstallIfDLLMissing options.
753 - Re-enabled RawStackTraces by default. The frame based stack traces (even
754 when compiling with stack frames enabled) are generally too incomplete.
755 - Improved the speed of large block operations under FullDebugMode: Since
756 large blocks are never reused, there is no point in clearing them before
757 and after use (so it does not do that anymore).
758 - If an error occurs in FullDebugMode and FastMM is unable to append to the
759 log file, it will attempt to write to a log file of the same name in the
760 "My Documents" folder. This feature is helpful when the executable resides
761 in a read-only location and the default log file, which is derived from the
762 executable name, would thus not be writeable.
763 - Added support for controlling the error log file location through an
764 environment variable. If the 'FastMMLogFilePath' environment variable is
765 set then any generated error logs will be written to the specified folder
766 instead of the default location (which is the same folder as the
767 application).
768 - Improved the call instruction detection code in the FastMM_FullDebugMode
769 library. (Thanks to the JCL team.)
770 - Improved the string leak detection and reporting code. (Thanks to Uwe
771 Schuster.)
772 - New FullDebugMode feature: Whenever FreeMem or ReallocMem is called, FastMM
773 will check that the block was actually allocated through the same FastMM
774 instance. This is useful for tracking down memory manager sharing issues.
775 - Compatible with Delphi 2010.
776 Version 4.96 (31 August 2010):
777 - Reduced the minimum block size to 4 bytes from the previous value of 12
778 bytes (only applicable to 8 byte alignment). This reduces memory usage if
779 the application allocates many blocks <= 4 bytes in size.
780 - Added colour-coded change indication to the FastMM usage tracker, making
781 it easier to spot changes in the memory usage grid. (Thanks to Murray
782 McGowan.)
783 - Added the SuppressFreeMemErrorsInsideException FullDebugMode option: If
784 FastMM encounters a problem with a memory block inside the FullDebugMode
785 FreeMem handler then an "invalid pointer operation" exception will usually
786 be raised. If the FreeMem occurs while another exception is being handled
787 (perhaps in the try.. finally code) then the original exception will be
788 lost. With this option set FastMM will ignore errors inside FreeMem when an
789 exception is being handled, thus allowing the original exception to
790 propagate. This option is on by default. (Thanks to Michael Hieke.)
791 - Fixed Windows 95 FullDebugMode support that was broken in 4.94. (Thanks to
792 Richard Bradbrook.)
793 - Fixed a bug affecting GetMemoryMap performance and accuracy of measurements
794 above 2GB if a large address space is not enabled for the project. (Thanks
795 to Michael Hieke.)
796 - Added the FullDebugModeRegisterAllAllocsAsExpectedMemoryLeak boolean flag.
797 When set, all allocations are automatically registered as expected memory
798 leaks. Only available in FullDebugMode. (Thanks to Brian Cook.)
799 - Compatible with Delphi XE.
800 Version 4.97 (30 September 2010):
801 - Fixed a crash bug (that crept in in 4.96) that may manifest itself when
802 resizing a block to 4 bytes or less.
803 - Added the UseSwitchToThread option. Set this option to call SwitchToThread
804 instead of sitting in a "busy waiting" loop when a thread contention
805 occurs. This is used in conjunction with the NeverSleepOnThreadContention
806 option, and has no effect unless NeverSleepOnThreadContention is also
807 defined. This option may improve performance with many CPU cores and/or
808 threads of different priorities. Note that the SwitchToThread API call is
809 only available on Windows 2000 and later. (Thanks to Zach Saw.)
810 Version 4.98 (23 September 2011):
811 - Added the FullDebugModeCallBacks define which adds support for memory
812 manager event callbacks. This allows the application to be notified of
813 memory allocations, frees and reallocations as they occur. (Thanks to
814 Jeroen Pluimers.)
815 - Added security options ClearMemoryBeforeReturningToOS and
816 AlwaysClearFreedMemory to force the clearing of memory blocks after being
817 freed. This could possibly provide some protection against information
818 theft, but at a significant performance penalty. (Thanks to Andrey
819 Sozonov.)
820 - Shifted the code in the initialization section to a procedure
821 RunInitializationCode. This allows the startup code to be called before
822 InitUnits, which is required by some software protection tools.
823 - Added support for Delphi XE2 (Windows 32-bit and Windows 64-bit platforms
824 only).
825 Version 4.99 (6 November 2011):
826 - Fixed crashes in the 64-bit BASM codepath when more than 4GB of memory is
827 allocated.
828 - Fixed bad record alignment under 64-bit that affected performance.
829 - Fixed compilation errors with some older compilers.
830 Version 4.991 (3 September 2012)
831 - Added the LogMemoryManagerStateToFile call. This call logs a summary of
832 the memory manager state to file: The total allocated memory, overhead,
833 efficiency, and a breakdown of allocated memory by class and string type.
834 This call may be useful to catch objects that do not necessarily leak, but
835 do linger longer than they should.
836 - OS X support added by Sebastian Zierer
837 - Compatible with Delphi XE3
838
839 *)
840
841 unit FastMM4;
842
843 interface
844
845 {$Include FastMM4Options.inc}
846
847 {$RANGECHECKS OFF}
848 {$BOOLEVAL OFF}
849 {$OVERFLOWCHECKS OFF}
850 {$OPTIMIZATION ON}
851 {$TYPEDADDRESS OFF}
852 {$LONGSTRINGS ON}
853
854 {Compiler version defines}
855 {$ifndef BCB}
856 {$ifdef ver120}
857 {$define Delphi4or5}
858 {$endif}
859 {$ifdef ver130}
860 {$define Delphi4or5}
861 {$endif}
862 {$ifdef ver140}
863 {$define Delphi6}
864 {$endif}
865 {$ifdef ver150}
866 {$define Delphi7}
867 {$endif}
868 {$ifdef ver170}
869 {$define Delphi2005}
870 {$endif}
871 {$else}
872 {for BCB4, use the Delphi 5 codepath}
873 {$ifdef ver120}
874 {$define Delphi4or5}
875 {$define BCB4}
876 {$endif}
877 {for BCB5, use the Delphi 5 codepath}
878 {$ifdef ver130}
879 {$define Delphi4or5}
880 {$endif}
881 {$endif}
882 {$ifdef ver180}
883 {$define BDS2006}
884 {$endif}
885 {$define 32Bit}
886 {$ifndef Delphi4or5}
887 {$if SizeOf(Pointer) = 8}
888 {$define 64Bit}
889 {$undef 32Bit}
890 {$ifend}
891 {$if CompilerVersion >= 23}
892 {$define XE2AndUp}
893 {$ifend}
894 {$define BCB6OrDelphi6AndUp}
895 {$ifndef BCB}
896 {$define Delphi6AndUp}
897 {$endif}
898 {$ifndef Delphi6}
899 {$define BCB6OrDelphi7AndUp}
900 {$ifndef BCB}
901 {$define Delphi7AndUp}
902 {$endif}
903 {$ifndef BCB}
904 {$ifndef Delphi7}
905 {$ifndef Delphi2005}
906 {$define BDS2006AndUp}
907 {$endif}
908 {$endif}
909 {$endif}
910 {$endif}
911 {$endif}
912
913 {$ifdef 64Bit}
914 {Under 64 bit memory blocks must always be 16-byte aligned}
915 {$define Align16Bytes}
916 {No need for MMX under 64-bit, since SSE2 is available}
917 {$undef EnableMMX}
918 {There is little need for raw stack traces under 64-bit, since frame based
919 stack traces are much more accurate than under 32-bit. (And frame based
920 stack tracing is much faster.)}
921 {$undef RawStackTraces}
922 {$endif}
923
924 {IDE debug mode always enables FullDebugMode and dynamic loading of the FullDebugMode DLL.}
925 {$ifdef FullDebugModeInIDE}
926 {$define InstallOnlyIfRunningInIDE}
927 {$define FullDebugMode}
928 {$define LoadDebugDLLDynamically}
929 {$endif}
930
931 {Install in FullDebugMode only when the DLL is available?}
932 {$ifdef FullDebugModeWhenDLLAvailable}
933 {$define FullDebugMode}
934 {$define LoadDebugDLLDynamically}
935 {$define DoNotInstallIfDLLMissing}
936 {$endif}
937
938 {$ifdef Linux}
939 {$define POSIX}
940 {$endif}
941
942 {Some features not currently supported under Kylix / OS X}
943 {$ifdef POSIX}
944 {$undef FullDebugMode}
945 {$undef LogErrorsToFile}
946 {$undef LogMemoryLeakDetailToFile}
947 {$undef ShareMM}
948 {$undef AttemptToUseSharedMM}
949 {$undef RequireIDEPresenceForLeakReporting}
950 {$undef UseOutputDebugString}
951 {$ifdef PIC}
952 {BASM version does not support position independent code}
953 {$undef ASMVersion}
954 {$endif}
955 {$endif}
956
957 {Do we require debug info for leak checking?}
958 {$ifdef RequireDebugInfoForLeakReporting}
959 {$ifopt D-}
960 {$undef EnableMemoryLeakReporting}
961 {$endif}
962 {$endif}
963
964 {Enable heap checking and leak reporting in full debug mode}
965 {$ifdef FullDebugMode}
966 {$STACKFRAMES ON}
967 {$define CheckHeapForCorruption}
968 {$ifndef CatchUseOfFreedInterfaces}
969 {$define CheckUseOfFreedBlocksOnShutdown}
970 {$endif}
971 {$else}
972 {Error logging requires FullDebugMode}
973 {$undef LogErrorsToFile}
974 {$undef CatchUseOfFreedInterfaces}
975 {$undef RawStackTraces}
976 {$undef AlwaysAllocateTopDown}
977 {$endif}
978
979 {Set defines for security options}
980 {$ifdef FullDebugMode}
981 {In FullDebugMode small and medium blocks are always cleared when calling
982 FreeMem. Large blocks are always returned to the OS immediately.}
983 {$ifdef ClearMemoryBeforeReturningToOS}
984 {$define ClearLargeBlocksBeforeReturningToOS}
985 {$endif}
986 {$ifdef AlwaysClearFreedMemory}
987 {$define ClearLargeBlocksBeforeReturningToOS}
988 {$endif}
989 {$else}
990 {If memory blocks are cleared in FreeMem then they do not need to be cleared
991 before returning the memory to the OS.}
992 {$ifdef AlwaysClearFreedMemory}
993 {$define ClearSmallAndMediumBlocksInFreeMem}
994 {$define ClearLargeBlocksBeforeReturningToOS}
995 {$else}
996 {$ifdef ClearMemoryBeforeReturningToOS}
997 {$define ClearMediumBlockPoolsBeforeReturningToOS}
998 {$define ClearLargeBlocksBeforeReturningToOS}
999 {$endif}
1000 {$endif}
1001 {$endif}
1002
1003 {Only the Pascal version supports extended heap corruption checking.}
1004 {$ifdef CheckHeapForCorruption}
1005 {$undef ASMVersion}
1006 {$endif}
1007
1008 {For BASM bits that are not implemented in 64-bit.}
1009 {$ifdef 32Bit}
1010 {$ifdef ASMVersion}
1011 {$define Use32BitAsm}
1012 {$endif}
1013 {$endif}
1014
1015 {$ifdef UseRuntimePackages}
1016 {$define AssumeMultiThreaded}
1017 {$endif}
1018
1019 {$ifdef BCB6OrDelphi6AndUp}
1020 {$WARN SYMBOL_PLATFORM OFF}
1021 {$WARN SYMBOL_DEPRECATED OFF}
1022 {$endif}
1023
1024 {Leak detail logging requires error logging}
1025 {$ifndef LogErrorsToFile}
1026 {$undef LogMemoryLeakDetailToFile}
1027 {$undef ClearLogFileOnStartup}
1028 {$endif}
1029
1030 {$ifndef EnableMemoryLeakReporting}
1031 {Manual leak reporting control requires leak reporting to be enabled}
1032 {$undef ManualLeakReportingControl}
1033 {$endif}
1034
1035 {$ifndef EnableMMX}
1036 {$undef ForceMMX}
1037 {$endif}
1038
1039 {Are any of the MM sharing options enabled?}
1040 {$ifdef ShareMM}
1041 {$define MMSharingEnabled}
1042 {$endif}
1043 {$ifdef AttemptToUseSharedMM}
1044 {$define MMSharingEnabled}
1045 {$endif}
1046
1047 {Instruct GExperts to back up the messages file as well.}
1048 {#BACKUP FastMM4Messages.pas}
1049
1050 {Should debug info be disabled?}
1051 {$ifdef NoDebugInfo}
1052 {$DEBUGINFO OFF}
1053 {$endif}
1054
1055 {$ifdef BCB}
1056 {$ifdef borlndmmdll}
1057 {$OBJEXPORTALL OFF}
1058 {$endif}
1059 {$ifndef PatchBCBTerminate}
1060 {Cannot uninstall safely under BCB}
1061 {$define NeverUninstall}
1062 {Disable memory leak reporting}
1063 {$undef EnableMemoryLeakReporting}
1064 {$endif}
1065 {$endif}
1066
1067 {-------------------------Public constants-----------------------------}
1068 const
1069 {The current version of FastMM}
1070 FastMMVersion = '4.991';
1071 {The number of small block types}
1072 {$ifdef Align16Bytes}
1073 NumSmallBlockTypes = 46;
1074 {$else}
1075 NumSmallBlockTypes = 56;
1076 {$endif}
1077
1078 {----------------------------Public types------------------------------}
1079 type
1080
1081 {Make sure all the required types are available}
1082 {$ifdef BCB6OrDelphi6AndUp}
1083 {$if CompilerVersion < 20}
1084 PByte = PAnsiChar;
1085 {NativeInt didn't exist or was broken before Delphi 2009.}
1086 NativeInt = Integer;
1087 {$ifend}
1088 {$if CompilerVersion < 21}
1089 {NativeUInt didn't exist or was broken before Delphi 2010.}
1090 NativeUInt = Cardinal;
1091 {$ifend}
1092 {$if CompilerVersion < 22}
1093 {PNativeUInt didn't exist before Delphi XE.}
1094 PNativeUInt = ^Cardinal;
1095 {$ifend}
1096 {$if CompilerVersion < 23}
1097 {IntPtr and UIntPtr didn't exist before Delphi XE2.}
1098 IntPtr = Integer;
1099 UIntPtr = Cardinal;
1100 {$ifend}
1101 {$else}
1102 PByte = PAnsiChar;
1103 NativeInt = Integer;
1104 NativeUInt = Cardinal;
1105 PNativeUInt = ^Cardinal;
1106 IntPtr = Integer;
1107 UIntPtr = Cardinal;
1108 {$endif}
1109
1110 TSmallBlockTypeState = record
1111 {The internal size of the block type}
1112 InternalBlockSize: Cardinal;
1113 {Useable block size: The number of non-reserved bytes inside the block.}
1114 UseableBlockSize: Cardinal;
1115 {The number of allocated blocks}
1116 AllocatedBlockCount: NativeUInt;
1117 {The total address space reserved for this block type (both allocated and
1118 free blocks)}
1119 ReservedAddressSpace: NativeUInt;
1120 end;
1121 TSmallBlockTypeStates = array[0..NumSmallBlockTypes - 1] of TSmallBlockTypeState;
1122
1123 TMemoryManagerState = record
1124 {Small block type states}
1125 SmallBlockTypeStates: TSmallBlockTypeStates;
1126 {Medium block stats}
1127 AllocatedMediumBlockCount: Cardinal;
1128 TotalAllocatedMediumBlockSize: NativeUInt;
1129 ReservedMediumBlockAddressSpace: NativeUInt;
1130 {Large block stats}
1131 AllocatedLargeBlockCount: Cardinal;
1132 TotalAllocatedLargeBlockSize: NativeUInt;
1133 ReservedLargeBlockAddressSpace: NativeUInt;
1134 end;
1135
1136 TMemoryManagerUsageSummary = record
1137 {The total number of bytes allocated by the application.}
1138 AllocatedBytes: NativeUInt;
1139 {The total number of address space bytes used by control structures, or
1140 lost due to fragmentation and other overhead.}
1141 OverheadBytes: NativeUInt;
1142 {The efficiency of the memory manager expressed as a percentage. This is
1143 100 * AllocatedBytes / (AllocatedBytes + OverheadBytes).}
1144 EfficiencyPercentage: Double;
1145 end;
1146
1147 {Memory map}
1148 TChunkStatus = (csUnallocated, csAllocated, csReserved, csSysAllocated,
1149 csSysReserved);
1150 TMemoryMap = array[0..65535] of TChunkStatus;
1151
1152 {$ifdef EnableMemoryLeakReporting}
1153 {List of registered leaks}
1154 TRegisteredMemoryLeak = record
1155 LeakAddress: Pointer;
1156 LeakedClass: TClass;
1157 {$ifdef CheckCppObjectTypeEnabled}
1158 LeakedCppTypeIdPtr: Pointer;
1159 {$endif}
1160 LeakSize: NativeInt;
1161 LeakCount: Integer;
1162 end;
1163 TRegisteredMemoryLeaks = array of TRegisteredMemoryLeak;
1164 {$endif}
1165
1166 {Used by the DetectStringData routine to detect whether a leaked block
1167 contains string data.}
1168 TStringDataType = (stUnknown, stAnsiString, stUnicodeString);
1169
1170 {The callback procedure for WalkAllocatedBlocks.}
1171 TWalkAllocatedBlocksCallback = procedure(APBlock: Pointer; ABlockSize: NativeInt; AUserData: Pointer);
1172
1173 {--------------------------Public variables----------------------------}
1174 var
1175 {If this variable is set to true and FullDebugMode is enabled, then the
1176 entire memory pool is checked for consistency before every memory
1177 operation. Note that this incurs a massive performance hit on top of
1178 the already significant FullDebugMode overhead, so enable this option
1179 only when absolutely necessary.}
1180 FullDebugModeScanMemoryPoolBeforeEveryOperation: Boolean = False;
1181 FullDebugModeRegisterAllAllocsAsExpectedMemoryLeak: Boolean = False;
1182 {$ifdef ManualLeakReportingControl}
1183 {Variable is declared in system.pas in newer Delphi versions.}
1184 {$ifndef BDS2006AndUp}
1185 ReportMemoryLeaksOnShutdown: Boolean;
1186 {$endif}
1187 {$endif}
1188 {If set to True, disables the display of all messageboxes}
1189 SuppressMessageBoxes: Boolean;
1190
1191 {-------------------------Public procedures----------------------------}
1192 {Executes the code normally run in the initialization section. Running it
1193 earlier may be required with e.g. some software protection tools.}
1194 procedure RunInitializationCode;
1195 {Installation procedures must be exposed for the BCB helper unit FastMM4BCB.cpp}
1196 {$ifdef BCB}
1197 procedure InitializeMemoryManager;
CheckCanInstallMemoryManagernull1198 function CheckCanInstallMemoryManager: Boolean;
1199 procedure InstallMemoryManager;
1200
1201 {$ifdef FullDebugMode}
1202 (*$HPPEMIT '#define FullDebugMode' *)
1203
1204 {$ifdef ClearLogFileOnStartup}
1205 (*$HPPEMIT ' #define ClearLogFileOnStartup' *)
1206 procedure DeleteEventLog;
1207 {$endif}
1208
1209 {$ifdef LoadDebugDLLDynamically}
1210 (*$HPPEMIT ' #define LoadDebugDLLDynamically' *)
1211 {$endif}
1212
1213 {$ifdef RawStackTraces}
1214 (*$HPPEMIT ' #define RawStackTraces' *)
1215 {$endif}
1216
1217 {$endif}
1218
1219 {$ifdef PatchBCBTerminate}
1220 (*$HPPEMIT ''#13#10 *)
1221 (*$HPPEMIT '#define PatchBCBTerminate' *)
1222
1223 {$ifdef EnableMemoryLeakReporting}
1224 (*$HPPEMIT ''#13#10 *)
1225 (*$HPPEMIT '#define EnableMemoryLeakReporting' *)
1226 {$endif}
1227
1228 {$ifdef DetectMMOperationsAfterUninstall}
1229 (*$HPPEMIT ''#13#10 *)
1230 (*$HPPEMIT '#define DetectMMOperationsAfterUninstall' *)
1231 {$endif}
1232
1233 {Called in FastMM4BCB.cpp, should contain codes of original "finalization" section}
1234 procedure FinalizeMemoryManager;
1235
1236 {For completion of "RequireDebuggerPresenceForLeakReporting" checking in "FinalizeMemoryManager"}
1237 var
1238 pCppDebugHook: ^Integer = nil; //PInteger not defined in BCB5
1239
1240 {$ifdef CheckCppObjectTypeEnabled}
1241 (*$HPPEMIT ''#13#10 *)
1242 (*$HPPEMIT '#define CheckCppObjectTypeEnabled' *)
1243
1244 type
Pointernull1245 TGetCppVirtObjSizeByTypeIdPtrFunc = function(APointer: Pointer): Cardinal;
Pointernull1246 TGetCppVirtObjTypeIdPtrFunc = function(APointer: Pointer; ASize: Cardinal): Pointer;
Pointernull1247 TGetCppVirtObjTypeNameFunc = function(APointer: Pointer; ASize: Cardinal): PAnsiChar;
1248 TGetCppVirtObjTypeNameByTypeIdPtrFunc = function (APointer: Pointer): PAnsiChar;
VTablePtrnull1249 TGetCppVirtObjTypeNameByVTablePtrFunc = function(AVTablePtr: Pointer; AVTablePtrOffset: Cardinal): PAnsiChar;
1250 var
1251 {Return virtual object's size from typeId pointer}
1252 GetCppVirtObjSizeByTypeIdPtrFunc: TGetCppVirtObjSizeByTypeIdPtrFunc = nil;
1253 {Retrieve virtual object's typeId pointer}
1254 GetCppVirtObjTypeIdPtrFunc: TGetCppVirtObjTypeIdPtrFunc = nil;
1255 {Retrieve virtual object's type name}
1256 GetCppVirtObjTypeNameFunc: TGetCppVirtObjTypeNameFunc = nil;
1257 {Return virtual object's type name from typeId pointer}
1258 GetCppVirtObjTypeNameByTypeIdPtrFunc: TGetCppVirtObjTypeNameByTypeIdPtrFunc = nil;
1259 {Retrieve virtual object's typeId pointer from it's virtual table pointer}
1260 GetCppVirtObjTypeNameByVTablePtrFunc: TGetCppVirtObjTypeNameByVTablePtrFunc = nil;
1261 {$endif}
1262 {$endif}
1263 {$endif}
1264
1265 {$ifndef FullDebugMode}
1266 {The standard memory manager functions}
FastGetMemnull1267 function FastGetMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer;
FastFreeMemnull1268 function FastFreeMem(APointer: Pointer): Integer;
FastReallocMemnull1269 function FastReallocMem(APointer: Pointer; ANewSize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer;
FastAllocMemnull1270 function FastAllocMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Cardinal{$endif}): Pointer;
1271 {$else}
1272 {The FullDebugMode memory manager functions}
DebugGetMemnull1273 function DebugGetMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer;
DebugFreeMemnull1274 function DebugFreeMem(APointer: Pointer): Integer;
DebugReallocMemnull1275 function DebugReallocMem(APointer: Pointer; ANewSize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer;
DebugAllocMemnull1276 function DebugAllocMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Cardinal{$endif}): Pointer;
1277 {Scans the memory pool for any corruptions. If a corruption is encountered an "Out of Memory" exception is
1278 raised.}
1279 procedure ScanMemoryPoolForCorruptions;
1280 {Specify the full path and name for the filename to be used for logging memory
1281 errors, etc. If ALogFileName is nil or points to an empty string it will
1282 revert to the default log file name.}
1283 procedure SetMMLogFileName(ALogFileName: PAnsiChar = nil);
1284 {Returns the current "allocation group". Whenever a GetMem request is serviced
1285 in FullDebugMode, the current "allocation group" is stored in the block header.
1286 This may help with debugging. Note that if a block is subsequently reallocated
1287 that it keeps its original "allocation group" and "allocation number" (all
1288 allocations are also numbered sequentially).}
GetCurrentAllocationGroupnull1289 function GetCurrentAllocationGroup: Cardinal;
1290 {Allocation groups work in a stack like fashion. Group numbers are pushed onto
1291 and popped off the stack. Note that the stack size is limited, so every push
1292 should have a matching pop.}
1293 procedure PushAllocationGroup(ANewCurrentAllocationGroup: Cardinal);
1294 procedure PopAllocationGroup;
1295 {Logs detail about currently allocated memory blocks for the specified range of
1296 allocation groups. if ALastAllocationGroupToLog is less than
1297 AFirstAllocationGroupToLog or it is zero, then all allocation groups are
1298 logged. This routine also checks the memory pool for consistency at the same
1299 time, raising an "Out of Memory" error if the check fails.}
1300 procedure LogAllocatedBlocksToFile(AFirstAllocationGroupToLog, ALastAllocationGroupToLog: Cardinal);
1301 {$endif}
1302
1303 {Releases all allocated memory (use with extreme care)}
1304 procedure FreeAllMemory;
1305
1306 {Returns summarised information about the state of the memory manager. (For
1307 backward compatibility.)}
FastGetHeapStatusnull1308 function FastGetHeapStatus: THeapStatus;
1309 {Returns statistics about the current state of the memory manager}
1310 procedure GetMemoryManagerState(var AMemoryManagerState: TMemoryManagerState);
1311 {Returns a summary of the information returned by GetMemoryManagerState}
1312 procedure GetMemoryManagerUsageSummary(
1313 var AMemoryManagerUsageSummary: TMemoryManagerUsageSummary);
1314 {$ifndef POSIX}
1315 {Gets the state of every 64K block in the 4GB address space}
1316 procedure GetMemoryMap(var AMemoryMap: TMemoryMap);
1317 {$endif}
1318
1319 {$ifdef EnableMemoryLeakReporting}
1320 {Registers expected memory leaks. Returns true on success. The list of leaked
1321 blocks is limited, so failure is possible if the list is full.}
RegisterExpectedMemoryLeaknull1322 function RegisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; overload;
RegisterExpectedMemoryLeaknull1323 function RegisterExpectedMemoryLeak(ALeakedObjectClass: TClass; ACount: Integer = 1): Boolean; overload;
RegisterExpectedMemoryLeaknull1324 function RegisterExpectedMemoryLeak(ALeakedBlockSize: NativeInt; ACount: Integer = 1): Boolean; overload;
1325 {$ifdef CheckCppObjectTypeEnabled}
1326 {Registers expected memory leaks by virtual object's typeId pointer.
1327 Usage: RegisterExpectedMemoryLeak(typeid(ACppObject).tpp, Count);}
RegisterExpectedMemoryLeaknull1328 function RegisterExpectedMemoryLeak(ALeakedCppVirtObjTypeIdPtr: Pointer; ACount: Integer): boolean; overload;
1329 {$endif}
1330 {Removes expected memory leaks. Returns true on success.}
UnregisterExpectedMemoryLeaknull1331 function UnregisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; overload;
UnregisterExpectedMemoryLeaknull1332 function UnregisterExpectedMemoryLeak(ALeakedObjectClass: TClass; ACount: Integer = 1): Boolean; overload;
UnregisterExpectedMemoryLeaknull1333 function UnregisterExpectedMemoryLeak(ALeakedBlockSize: NativeInt; ACount: Integer = 1): Boolean; overload;
1334 {$ifdef CheckCppObjectTypeEnabled}
1335 {Usage: UnregisterExpectedMemoryLeak(typeid(ACppObject).tpp, Count);}
UnregisterExpectedMemoryLeaknull1336 function UnregisterExpectedMemoryLeak(ALeakedCppVirtObjTypeIdPtr: Pointer; ACount: Integer): boolean; overload;
1337 {$endif}
1338 {Returns a list of all expected memory leaks}
GetRegisteredMemoryLeaksnull1339 function GetRegisteredMemoryLeaks: TRegisteredMemoryLeaks;
1340 {$endif}
1341
1342 {Returns the class for a memory block. Returns nil if it is not a valid class.
1343 Used by the leak detection code.}
DetectClassInstancenull1344 function DetectClassInstance(APointer: Pointer): TClass;
1345 {Detects the probable string data type for a memory block. Used by the leak
1346 classification code when a block cannot be identified as a known class
1347 instance.}
DetectStringDatanull1348 function DetectStringData(APMemoryBlock: Pointer;
1349 AAvailableSpaceInBlock: NativeInt): TStringDataType;
1350 {Walks all allocated blocks, calling ACallBack for each. Passes the user block size and AUserData to the callback.
1351 Important note: All block types will be locked during the callback, so the memory manager cannot be used inside it.}
1352 procedure WalkAllocatedBlocks(ACallBack: TWalkAllocatedBlocksCallback; AUserData: Pointer);
1353 {Writes a log file containing a summary of the memory mananger state and a summary of allocated blocks grouped by
1354 class. The file will be saved in UTF-8 encoding (in supported Delphi versions). Returns True on success. }
LogMemoryManagerStateToFilenull1355 function LogMemoryManagerStateToFile(const AFileName: string; const AAdditionalDetails: string = ''): Boolean;
1356
1357 {$ifdef FullDebugMode}
1358 {-------------FullDebugMode constants---------------}
1359 const
1360 {The stack trace depth. (Must be an *uneven* number to ensure that the
1361 Align16Bytes option works in FullDebugMode.)}
1362 StackTraceDepth = 11;
1363 {The number of entries in the allocation group stack}
1364 AllocationGroupStackSize = 1000;
1365 {The number of fake VMT entries - used to track virtual method calls on
1366 freed objects. Do not change this value without also updating TFreedObject.GetVirtualMethodIndex}
1367 MaxFakeVMTEntries = 200;
1368 {The pattern used to fill unused memory}
1369 DebugFillByte = $80;
1370 {$ifdef 32Bit}
1371 DebugFillPattern = $01010101 * Cardinal(DebugFillByte);
1372 {The address that is reserved so that accesses to the address of the fill
1373 pattern will result in an A/V. (Not used under 64-bit, since the upper half
1374 of the address space is always reserved by the OS.)}
1375 DebugReservedAddress = $01010000 * Cardinal(DebugFillByte);
1376 {$else}
1377 DebugFillPattern = $8080808080808080;
1378 {$endif}
1379
1380 {-------------------------FullDebugMode structures--------------------}
1381 type
1382 PStackTrace = ^TStackTrace;
1383 TStackTrace = array[0..StackTraceDepth - 1] of NativeUInt;
1384
1385 TBlockOperation = (boBlockCheck, boGetMem, boFreeMem, boReallocMem);
1386
1387 {The header placed in front of blocks in FullDebugMode (just after the
1388 standard header). Must be a multiple of 16 bytes in size otherwise the
1389 Align16Bytes option will not work. Current size = 128 bytes under 32-bit,
1390 and 240 bytes under 64-bit.}
1391 PFullDebugBlockHeader = ^TFullDebugBlockHeader;
1392 TFullDebugBlockHeader = record
1393 {Space used by the medium block manager for previous/next block management.
1394 If a medium block is binned then these two fields will be modified.}
1395 Reserved1: Pointer;
1396 Reserved2: Pointer;
1397 {Is the block currently allocated? If it is allocated this will be the
1398 address of the getmem routine through which it was allocated, otherwise it
1399 will be nil.}
1400 AllocatedByRoutine: Pointer;
1401 {The allocation group: Can be used in the debugging process to group
1402 related memory leaks together}
1403 AllocationGroup: Cardinal;
1404 {The allocation number: All new allocations are numbered sequentially. This
1405 number may be useful in memory leak analysis. If it reaches 4G it wraps
1406 back to 0.}
1407 AllocationNumber: Cardinal;
1408 {The call stack when the block was allocated}
1409 AllocationStackTrace: TStackTrace;
1410 {The thread that allocated the block}
1411 AllocatedByThread: Cardinal;
1412 {The thread that freed the block}
1413 FreedByThread: Cardinal;
1414 {The call stack when the block was freed}
1415 FreeStackTrace: TStackTrace;
1416 {The user requested size for the block. 0 if this is the first time the
1417 block is used.}
1418 UserSize: NativeUInt;
1419 {The object class this block was used for the previous time it was
1420 allocated. When a block is freed, the pointer that would normally be in the
1421 space of the class pointer is copied here, so if it is detected that
1422 the block was used after being freed we have an idea what class it is.}
1423 PreviouslyUsedByClass: NativeUInt;
1424 {The sum of all the dwords(32-bit)/qwords(64-bit) in this structure
1425 excluding the initial two reserved fields and this field.}
1426 HeaderCheckSum: NativeUInt;
1427 end;
1428 {The NativeUInt following the user area of the block is the inverse of
1429 HeaderCheckSum. This is used to catch buffer overrun errors.}
1430
1431 {The class used to catch attempts to execute a virtual method of a freed
1432 object}
1433 TFreedObject = class
1434 public
1435 procedure GetVirtualMethodIndex;
1436 procedure VirtualMethodError;
1437 {$ifdef CatchUseOfFreedInterfaces}
1438 procedure InterfaceError;
1439 {$endif}
1440 end;
1441
1442 {$ifdef FullDebugModeCallBacks}
1443 {FullDebugMode memory manager event callbacks. Note that APHeaderFreedBlock in the TOnDebugFreeMemFinish
1444 will not be valid for large (>260K) blocks.}
1445 TOnDebugGetMemFinish = procedure(APHeaderNewBlock: PFullDebugBlockHeader; ASize: NativeInt);
1446 TOnDebugFreeMemStart = procedure(APHeaderBlockToFree: PFullDebugBlockHeader);
1447 TOnDebugFreeMemFinish = procedure(APHeaderFreedBlock: PFullDebugBlockHeader; AResult: Integer);
1448 TOnDebugReallocMemStart = procedure(APHeaderBlockToReallocate: PFullDebugBlockHeader; ANewSize: NativeInt);
1449 TOnDebugReallocMemFinish = procedure(APHeaderReallocatedBlock: PFullDebugBlockHeader; ANewSize: NativeInt);
1450
1451 var
1452 {Note: FastMM will not catch exceptions inside these hooks, so make sure your hook code runs without
1453 exceptions.}
1454 OnDebugGetMemFinish: TOnDebugGetMemFinish = nil;
1455 OnDebugFreeMemStart: TOnDebugFreeMemStart = nil;
1456 OnDebugFreeMemFinish: TOnDebugFreeMemFinish = nil;
1457 OnDebugReallocMemStart: TOnDebugReallocMemStart = nil;
1458 OnDebugReallocMemFinish: TOnDebugReallocMemFinish = nil;
1459 {$endif}
1460 {$endif}
1461
1462 implementation
1463
1464 uses
1465 {$ifndef POSIX}
1466 Windows,
1467 {$ifdef FullDebugMode}
1468 {$ifdef Delphi4or5}
1469 ShlObj,
1470 {$else}
1471 SHFolder,
1472 {$endif}
1473 {$endif}
1474 {$else}
1475 {$ifdef MACOS}
1476 Posix.Stdlib, Posix.Unistd, Posix.Fcntl,
1477 {$ELSE}
1478 Libc,
1479 {$endif}
1480 {$endif}
1481 FastMM4Messages;
1482
1483 {Fixed size move procedures. The 64-bit versions assume 16-byte alignment.}
1484 procedure Move4(const ASource; var ADest; ACount: NativeInt); forward;
1485 procedure Move12(const ASource; var ADest; ACount: NativeInt); forward;
1486 procedure Move20(const ASource; var ADest; ACount: NativeInt); forward;
1487 procedure Move28(const ASource; var ADest; ACount: NativeInt); forward;
1488 procedure Move36(const ASource; var ADest; ACount: NativeInt); forward;
1489 procedure Move44(const ASource; var ADest; ACount: NativeInt); forward;
1490 procedure Move52(const ASource; var ADest; ACount: NativeInt); forward;
1491 procedure Move60(const ASource; var ADest; ACount: NativeInt); forward;
1492 procedure Move68(const ASource; var ADest; ACount: NativeInt); forward;
1493 {$ifdef 64Bit}
1494 {These are not needed and thus unimplemented under 32-bit}
1495 procedure Move8(const ASource; var ADest; ACount: NativeInt); forward;
1496 procedure Move24(const ASource; var ADest; ACount: NativeInt); forward;
1497 procedure Move40(const ASource; var ADest; ACount: NativeInt); forward;
1498 procedure Move56(const ASource; var ADest; ACount: NativeInt); forward;
1499 {$endif}
1500
1501 {$ifdef DetectMMOperationsAfterUninstall}
1502 {Invalid handlers to catch MM operations after uninstall}
1503 function InvalidFreeMem(APointer: Pointer): Integer; forward;
1504 function InvalidGetMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer; forward;
1505 function InvalidReallocMem(APointer: Pointer; ANewSize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer; forward;
1506 function InvalidAllocMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Cardinal{$endif}): Pointer; forward;
1507 function InvalidRegisterAndUnRegisterMemoryLeak(APointer: Pointer): Boolean; forward;
1508 {$endif}
1509
1510 {-------------------------Private constants----------------------------}
1511 const
1512 {The size of a medium block pool. This is allocated through VirtualAlloc and
1513 is used to serve medium blocks. The size must be a multiple of 16 and at
1514 least 4 bytes less than a multiple of 4K (the page size) to prevent a
1515 possible read access violation when reading past the end of a memory block
1516 in the optimized move routine (MoveX16LP). In Full Debug mode we leave a
1517 trailing 256 bytes to be able to safely do a memory dump.}
1518 MediumBlockPoolSize = 20 * 64 * 1024{$ifndef FullDebugMode} - 16{$else} - 256{$endif};
1519 {The granularity of small blocks}
1520 {$ifdef Align16Bytes}
1521 SmallBlockGranularity = 16;
1522 {$else}
1523 SmallBlockGranularity = 8;
1524 {$endif}
1525 {The granularity of medium blocks. Newly allocated medium blocks are
1526 a multiple of this size plus MediumBlockSizeOffset, to avoid cache line
1527 conflicts}
1528 MediumBlockGranularity = 256;
1529 MediumBlockSizeOffset = 48;
1530 {The granularity of large blocks}
1531 LargeBlockGranularity = 65536;
1532 {The maximum size of a small block. Blocks Larger than this are either
1533 medium or large blocks.}
1534 MaximumSmallBlockSize = 2608;
1535 {The smallest medium block size. (Medium blocks are rounded up to the nearest
1536 multiple of MediumBlockGranularity plus MediumBlockSizeOffset)}
1537 MinimumMediumBlockSize = 11 * 256 + MediumBlockSizeOffset;
1538 {The number of bins reserved for medium blocks}
1539 MediumBlockBinsPerGroup = 32;
1540 MediumBlockBinGroupCount = 32;
1541 MediumBlockBinCount = MediumBlockBinGroupCount * MediumBlockBinsPerGroup;
1542 {The maximum size allocatable through medium blocks. Blocks larger than this
1543 fall through to VirtualAlloc ( = large blocks).}
1544 MaximumMediumBlockSize = MinimumMediumBlockSize + (MediumBlockBinCount - 1) * MediumBlockGranularity;
1545 {The target number of small blocks per pool. The actual number of blocks per
1546 pool may be much greater for very small sizes and less for larger sizes. The
1547 cost of allocating the small block pool is amortized across all the small
1548 blocks in the pool, however the blocks may not all end up being used so they
1549 may be lying idle.}
1550 TargetSmallBlocksPerPool = 48;
1551 {The minimum number of small blocks per pool. Any available medium block must
1552 have space for roughly this many small blocks (or more) to be useable as a
1553 small block pool.}
1554 MinimumSmallBlocksPerPool = 12;
1555 {The lower and upper limits for the optimal small block pool size}
1556 OptimalSmallBlockPoolSizeLowerLimit = 29 * 1024 - MediumBlockGranularity + MediumBlockSizeOffset;
1557 OptimalSmallBlockPoolSizeUpperLimit = 64 * 1024 - MediumBlockGranularity + MediumBlockSizeOffset;
1558 {The maximum small block pool size. If a free block is this size or larger
1559 then it will be split.}
1560 MaximumSmallBlockPoolSize = OptimalSmallBlockPoolSizeUpperLimit + MinimumMediumBlockSize;
1561 {-------------Block type flags--------------}
1562 {The lower 3 bits in the dword header of small blocks (4 bits in medium and
1563 large blocks) are used as flags to indicate the state of the block}
1564 {Set if the block is not in use}
1565 IsFreeBlockFlag = 1;
1566 {Set if this is a medium block}
1567 IsMediumBlockFlag = 2;
1568 {Set if it is a medium block being used as a small block pool. Only valid if
1569 IsMediumBlockFlag is set.}
1570 IsSmallBlockPoolInUseFlag = 4;
1571 {Set if it is a large block. Only valid if IsMediumBlockFlag is not set.}
1572 IsLargeBlockFlag = 4;
1573 {Is the medium block preceding this block available? (Only used by medium
1574 blocks)}
1575 PreviousMediumBlockIsFreeFlag = 8;
1576 {Is this large block segmented? I.e. is it actually built up from more than
1577 one chunk allocated through VirtualAlloc? (Only used by large blocks.)}
1578 LargeBlockIsSegmented = 8;
1579 {The flags masks for small blocks}
1580 DropSmallFlagsMask = -8;
1581 ExtractSmallFlagsMask = 7;
1582 {The flags masks for medium and large blocks}
1583 DropMediumAndLargeFlagsMask = -16;
1584 ExtractMediumAndLargeFlagsMask = 15;
1585 {-------------Block resizing constants---------------}
1586 SmallBlockDownsizeCheckAdder = 64;
1587 SmallBlockUpsizeAdder = 32;
1588 {When a medium block is reallocated to a size smaller than this, then it must
1589 be reallocated to a small block and the data moved. If not, then it is
1590 shrunk in place down to MinimumMediumBlockSize. Currently the limit is set
1591 at a quarter of the minimum medium block size.}
1592 MediumInPlaceDownsizeLimit = MinimumMediumBlockSize div 4;
1593 {-------------Memory leak reporting constants---------------}
1594 ExpectedMemoryLeaksListSize = 64 * 1024;
1595 {-------------Other constants---------------}
1596 {$ifndef NeverSleepOnThreadContention}
1597 {Sleep time when a resource (small/medium/large block manager) is in use}
1598 InitialSleepTime = 0;
1599 {Used when the resource is still in use after the first sleep}
1600 AdditionalSleepTime = 1;
1601 {$endif}
1602 {Hexadecimal characters}
1603 HexTable: array[0..15] of AnsiChar = ('0', '1', '2', '3', '4', '5', '6', '7',
1604 '8', '9', 'A', 'B', 'C', 'D', 'E', 'F');
1605 {Copyright message - not used anywhere in the code}
1606 Copyright: AnsiString = 'FastMM4 (c) 2004 - 2011 Pierre le Riche / Professional Software Development';
1607 {$ifdef FullDebugMode}
1608 {Virtual Method Called On Freed Object Errors}
1609 StandardVirtualMethodNames: array[1 + vmtParent div SizeOf(Pointer) .. vmtDestroy div SizeOf(Pointer)] of PAnsiChar = (
1610 {$ifdef BCB6OrDelphi6AndUp}
1611 {$if RTLVersion >= 20}
1612 'Equals',
1613 'GetHashCode',
1614 'ToString',
1615 {$ifend}
1616 {$endif}
1617 'SafeCallException',
1618 'AfterConstruction',
1619 'BeforeDestruction',
1620 'Dispatch',
1621 'DefaultHandler',
1622 'NewInstance',
1623 'FreeInstance',
1624 'Destroy');
1625 {The name of the FullDebugMode support DLL. The support DLL implements stack
1626 tracing and the conversion of addresses to unit and line number information.}
1627 {$ifdef 32Bit}
1628 FullDebugModeLibraryName = FullDebugModeLibraryName32Bit;
1629 {$else}
1630 FullDebugModeLibraryName = FullDebugModeLibraryName64Bit;
1631 {$endif}
1632 {$endif}
1633
1634 {-------------------------Private types----------------------------}
1635 type
1636
1637 {$ifdef Delphi4or5}
1638 {Delphi 5 Compatibility}
1639 PCardinal = ^Cardinal;
1640 PPointer = ^Pointer;
1641 {$endif}
1642 {$ifdef BCB4}
1643 {Define some additional types for BCB4}
1644 PInteger = ^Integer;
1645 {$endif}
1646
1647 {Move procedure type}
1648 TMoveProc = procedure(const ASource; var ADest; ACount: NativeInt);
1649
1650 {Registers structure (for GetCPUID)}
1651 TRegisters = record
1652 RegEAX, RegEBX, RegECX, RegEDX: Integer;
1653 end;
1654
1655 {The layout of a string allocation. Used to detect string leaks.}
1656 PStrRec = ^StrRec;
1657 StrRec = packed record
1658 {$ifdef 64Bit}
1659 _Padding: Integer;
1660 {$endif}
1661 {$ifdef BCB6OrDelphi6AndUp}
1662 {$if RTLVersion >= 20}
1663 codePage: Word;
1664 elemSize: Word;
1665 {$ifend}
1666 {$endif}
1667 refCnt: Integer;
1668 length: Integer;
1669 end;
1670
1671 {$ifdef EnableMemoryLeakReporting}
1672 {Different kinds of memory leaks}
1673 TMemoryLeakType = (mltUnexpectedLeak, mltExpectedLeakRegisteredByPointer,
1674 mltExpectedLeakRegisteredByClass, mltExpectedLeakRegisteredBySize);
1675 {$endif}
1676
1677 {---------------Small block structures-------------}
1678
1679 {Pointer to the header of a small block pool}
1680 PSmallBlockPoolHeader = ^TSmallBlockPoolHeader;
1681
1682 {Small block type (Size = 32 bytes for 32-bit, 64 bytes for 64-bit).}
1683 PSmallBlockType = ^TSmallBlockType;
1684 TSmallBlockType = record
1685 {True = Block type is locked}
1686 BlockTypeLocked: Boolean;
1687 {Bitmap indicating which of the first 8 medium block groups contain blocks
1688 of a suitable size for a block pool.}
1689 AllowedGroupsForBlockPoolBitmap: Byte;
1690 {The block size for this block type}
1691 BlockSize: Word;
1692 {The minimum and optimal size of a small block pool for this block type}
1693 MinimumBlockPoolSize: Word;
1694 OptimalBlockPoolSize: Word;
1695 {The first partially free pool for the given small block. This field must
1696 be at the same offset as TSmallBlockPoolHeader.NextPartiallyFreePool.}
1697 NextPartiallyFreePool: PSmallBlockPoolHeader;
1698 {The last partially free pool for the small block type. This field must
1699 be at the same offset as TSmallBlockPoolHeader.PreviousPartiallyFreePool.}
1700 PreviousPartiallyFreePool: PSmallBlockPoolHeader;
1701 {The offset of the last block that was served sequentially. The field must
1702 be at the same offset as TSmallBlockPoolHeader.FirstFreeBlock.}
1703 NextSequentialFeedBlockAddress: Pointer;
1704 {The last block that can be served sequentially.}
1705 MaxSequentialFeedBlockAddress: Pointer;
1706 {The pool that is current being used to serve blocks in sequential order}
1707 CurrentSequentialFeedPool: PSmallBlockPoolHeader;
1708 {$ifdef UseCustomFixedSizeMoveRoutines}
1709 {The fixed size move procedure used to move data for this block size when
1710 it is upsized. When a block is downsized (which usually does not occur
1711 that often) the variable size move routine is used.}
1712 UpsizeMoveProcedure: TMoveProc;
1713 {$else}
1714 Reserved1: Pointer;
1715 {$endif}
1716 {$ifdef 64Bit}
1717 {Pad to 64 bytes for 64-bit}
1718 Reserved2: Pointer;
1719 {$endif}
1720 end;
1721
1722 {Small block pool (Size = 32 bytes for 32-bit, 48 bytes for 64-bit).}
1723 TSmallBlockPoolHeader = record
1724 {BlockType}
1725 BlockType: PSmallBlockType;
1726 {$ifdef 32Bit}
1727 {Align the next fields to the same fields in TSmallBlockType and pad this
1728 structure to 32 bytes for 32-bit}
1729 Reserved1: Cardinal;
1730 {$endif}
1731 {The next and previous pool that has free blocks of this size. Do not
1732 change the position of these two fields: They must be at the same offsets
1733 as the fields in TSmallBlockType of the same name.}
1734 NextPartiallyFreePool: PSmallBlockPoolHeader;
1735 PreviousPartiallyFreePool: PSmallBlockPoolHeader;
1736 {Pointer to the first free block inside this pool. This field must be at
1737 the same offset as TSmallBlockType.NextSequentialFeedBlockAddress.}
1738 FirstFreeBlock: Pointer;
1739 {The number of blocks allocated in this pool.}
1740 BlocksInUse: Cardinal;
1741 {Padding}
1742 Reserved2: Cardinal;
1743 {The pool pointer and flags of the first block}
1744 FirstBlockPoolPointerAndFlags: NativeUInt;
1745 end;
1746
1747 {Small block layout:
1748 At offset -SizeOf(Pointer) = Flags + address of the small block pool.
1749 At offset BlockSize - SizeOf(Pointer) = Flags + address of the small block
1750 pool for the next small block.
1751 }
1752
1753 {------------------------Medium block structures------------------------}
1754
1755 {The medium block pool from which medium blocks are drawn. Size = 16 bytes
1756 for 32-bit and 32 bytes for 64-bit.}
1757 PMediumBlockPoolHeader = ^TMediumBlockPoolHeader;
1758 TMediumBlockPoolHeader = record
1759 {Points to the previous and next medium block pools. This circular linked
1760 list is used to track memory leaks on program shutdown.}
1761 PreviousMediumBlockPoolHeader: PMediumBlockPoolHeader;
1762 NextMediumBlockPoolHeader: PMediumBlockPoolHeader;
1763 {Padding}
1764 Reserved1: NativeUInt;
1765 {The block size and flags of the first medium block in the block pool}
1766 FirstMediumBlockSizeAndFlags: NativeUInt;
1767 end;
1768
1769 {Medium block layout:
1770 Offset: -2 * SizeOf(Pointer) = Previous Block Size (only if the previous block is free)
1771 Offset: -SizeOf(Pointer) = This block size and flags
1772 Offset: 0 = User data / Previous Free Block (if this block is free)
1773 Offset: SizeOf(Pointer) = Next Free Block (if this block is free)
1774 Offset: BlockSize - 2*SizeOf(Pointer) = Size of this block (if this block is free)
1775 Offset: BlockSize - SizeOf(Pointer) = Size of the next block and flags
1776
1777 {A medium block that is unused}
1778 PMediumFreeBlock = ^TMediumFreeBlock;
1779 TMediumFreeBlock = record
1780 PreviousFreeBlock: PMediumFreeBlock;
1781 NextFreeBlock: PMediumFreeBlock;
1782 end;
1783
1784 {-------------------------Large block structures------------------------}
1785
1786 {Large block header record (Size = 16 for 32-bit, 32 for 64-bit)}
1787 PLargeBlockHeader = ^TLargeBlockHeader;
1788 TLargeBlockHeader = record
1789 {Points to the previous and next large blocks. This circular linked
1790 list is used to track memory leaks on program shutdown.}
1791 PreviousLargeBlockHeader: PLargeBlockHeader;
1792 NextLargeBlockHeader: PLargeBlockHeader;
1793 {The user allocated size of the Large block}
1794 UserAllocatedSize: NativeUInt;
1795 {The size of this block plus the flags}
1796 BlockSizeAndFlags: NativeUInt;
1797 end;
1798
1799 {-------------------------Expected Memory Leak Structures--------------------}
1800 {$ifdef EnableMemoryLeakReporting}
1801
1802 {The layout of an expected leak. All fields may not be specified, in which
1803 case it may be harder to determine which leaks are expected and which are
1804 not.}
1805 PExpectedMemoryLeak = ^TExpectedMemoryLeak;
1806 PPExpectedMemoryLeak = ^PExpectedMemoryLeak;
1807 TExpectedMemoryLeak = record
1808 {Linked list pointers}
1809 PreviousLeak, NextLeak: PExpectedMemoryLeak;
1810 {Information about the expected leak}
1811 LeakAddress: Pointer;
1812 LeakedClass: TClass;
1813 {$ifdef CheckCppObjectTypeEnabled}
1814 LeakedCppTypeIdPtr: Pointer;
1815 {$endif}
1816 LeakSize: NativeInt;
1817 LeakCount: Integer;
1818 end;
1819
1820 TExpectedMemoryLeaks = record
1821 {The number of entries used in the expected leaks buffer}
1822 EntriesUsed: Integer;
1823 {Freed entries}
1824 FirstFreeSlot: PExpectedMemoryLeak;
1825 {Entries with the address specified}
1826 FirstEntryByAddress: PExpectedMemoryLeak;
1827 {Entries with no address specified, but with the class specified}
1828 FirstEntryByClass: PExpectedMemoryLeak;
1829 {Entries with only size specified}
1830 FirstEntryBySizeOnly: PExpectedMemoryLeak;
1831 {The expected leaks buffer (Need to leave space for this header)}
1832 ExpectedLeaks: array[0..(ExpectedMemoryLeaksListSize - 64) div SizeOf(TExpectedMemoryLeak) - 1] of TExpectedMemoryLeak;
1833 end;
1834 PExpectedMemoryLeaks = ^TExpectedMemoryLeaks;
1835
1836 {$endif}
1837
1838 {-------------------------Private constants----------------------------}
1839 const
1840 {$ifndef BCB6OrDelphi7AndUp}
1841 reOutOfMemory = 1;
1842 reInvalidPtr = 2;
1843 {$endif}
1844 {The size of the block header in front of small and medium blocks}
1845 BlockHeaderSize = SizeOf(Pointer);
1846 {The size of a small block pool header}
1847 SmallBlockPoolHeaderSize = SizeOf(TSmallBlockPoolHeader);
1848 {The size of a medium block pool header}
1849 MediumBlockPoolHeaderSize = SizeOf(TMediumBlockPoolHeader);
1850 {The size of the header in front of Large blocks}
1851 LargeBlockHeaderSize = SizeOf(TLargeBlockHeader);
1852 {$ifdef FullDebugMode}
1853 {We need space for the header, the trailer checksum and the trailing block
1854 size (only used by freed medium blocks).}
1855 FullDebugBlockOverhead = SizeOf(TFullDebugBlockHeader) + SizeOf(NativeUInt) + SizeOf(Pointer);
1856 {$endif}
1857
1858 {-------------------------Private variables----------------------------}
1859 var
1860 {-----------------Small block management------------------}
1861 {The small block types. Sizes include the leading header. Sizes are
1862 picked to limit maximum wastage to about 10% or 256 bytes (whichever is
1863 less) where possible.}
1864 SmallBlockTypes: array[0..NumSmallBlockTypes - 1] of TSmallBlockType =(
1865 {8/16 byte jumps}
1866 {$ifndef Align16Bytes}
1867 (BlockSize: 8 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: Move4{$endif}),
1868 {$endif}
1869 (BlockSize: 16 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: {$ifdef 32Bit}Move12{$else}Move8{$endif}{$endif}),
1870 {$ifndef Align16Bytes}
1871 (BlockSize: 24 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: Move20{$endif}),
1872 {$endif}
1873 (BlockSize: 32 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: {$ifdef 32Bit}Move28{$else}Move24{$endif}{$endif}),
1874 {$ifndef Align16Bytes}
1875 (BlockSize: 40 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: Move36{$endif}),
1876 {$endif}
1877 (BlockSize: 48 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: {$ifdef 32Bit}Move44{$else}Move40{$endif}{$endif}),
1878 {$ifndef Align16Bytes}
1879 (BlockSize: 56 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: Move52{$endif}),
1880 {$endif}
1881 (BlockSize: 64 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: {$ifdef 32Bit}Move60{$else}Move56{$endif}{$endif}),
1882 {$ifndef Align16Bytes}
1883 (BlockSize: 72 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: Move68{$endif}),
1884 {$endif}
1885 (BlockSize: 80),
1886 {$ifndef Align16Bytes}
1887 (BlockSize: 88),
1888 {$endif}
1889 (BlockSize: 96),
1890 {$ifndef Align16Bytes}
1891 (BlockSize: 104),
1892 {$endif}
1893 (BlockSize: 112),
1894 {$ifndef Align16Bytes}
1895 (BlockSize: 120),
1896 {$endif}
1897 (BlockSize: 128),
1898 {$ifndef Align16Bytes}
1899 (BlockSize: 136),
1900 {$endif}
1901 (BlockSize: 144),
1902 {$ifndef Align16Bytes}
1903 (BlockSize: 152),
1904 {$endif}
1905 (BlockSize: 160),
1906 {16 byte jumps}
1907 (BlockSize: 176),
1908 (BlockSize: 192),
1909 (BlockSize: 208),
1910 (BlockSize: 224),
1911 (BlockSize: 240),
1912 (BlockSize: 256),
1913 (BlockSize: 272),
1914 (BlockSize: 288),
1915 (BlockSize: 304),
1916 (BlockSize: 320),
1917 {32 byte jumps}
1918 (BlockSize: 352),
1919 (BlockSize: 384),
1920 (BlockSize: 416),
1921 (BlockSize: 448),
1922 (BlockSize: 480),
1923 {48 byte jumps}
1924 (BlockSize: 528),
1925 (BlockSize: 576),
1926 (BlockSize: 624),
1927 (BlockSize: 672),
1928 {64 byte jumps}
1929 (BlockSize: 736),
1930 (BlockSize: 800),
1931 {80 byte jumps}
1932 (BlockSize: 880),
1933 (BlockSize: 960),
1934 {96 byte jumps}
1935 (BlockSize: 1056),
1936 (BlockSize: 1152),
1937 {112 byte jumps}
1938 (BlockSize: 1264),
1939 (BlockSize: 1376),
1940 {128 byte jumps}
1941 (BlockSize: 1504),
1942 {144 byte jumps}
1943 (BlockSize: 1648),
1944 {160 byte jumps}
1945 (BlockSize: 1808),
1946 {176 byte jumps}
1947 (BlockSize: 1984),
1948 {192 byte jumps}
1949 (BlockSize: 2176),
1950 {208 byte jumps}
1951 (BlockSize: 2384),
1952 {224 byte jumps}
1953 (BlockSize: MaximumSmallBlockSize),
1954 {The last block size occurs three times. If, during a GetMem call, the
1955 requested block size is already locked by another thread then up to two
1956 larger block sizes may be used instead. Having the last block size occur
1957 three times avoids the need to have a size overflow check.}
1958 (BlockSize: MaximumSmallBlockSize),
1959 (BlockSize: MaximumSmallBlockSize));
1960 {Size to small block type translation table}
1961 AllocSize2SmallBlockTypeIndX4: array[0..(MaximumSmallBlockSize - 1) div SmallBlockGranularity] of Byte;
1962 {-----------------Medium block management------------------}
1963 {A dummy medium block pool header: Maintains a circular list of all medium
1964 block pools to enable memory leak detection on program shutdown.}
1965 MediumBlockPoolsCircularList: TMediumBlockPoolHeader;
1966 {Are medium blocks locked?}
1967 MediumBlocksLocked: Boolean;
1968 {The sequential feed medium block pool.}
1969 LastSequentiallyFedMediumBlock: Pointer;
1970 MediumSequentialFeedBytesLeft: Cardinal;
1971 {The medium block bins are divided into groups of 32 bins. If a bit
1972 is set in this group bitmap, then at least one bin in the group has free
1973 blocks.}
1974 MediumBlockBinGroupBitmap: Cardinal;
1975 {The medium block bins: total of 32 * 32 = 1024 bins of a certain
1976 minimum size.}
1977 MediumBlockBinBitmaps: array[0..MediumBlockBinGroupCount - 1] of Cardinal;
1978 {The medium block bins. There are 1024 LIFO circular linked lists each
1979 holding blocks of a specified minimum size. The sizes vary in size from
1980 MinimumMediumBlockSize to MaximumMediumBlockSize. The bins are treated as
1981 type TMediumFreeBlock to avoid pointer checks.}
1982 MediumBlockBins: array[0..MediumBlockBinCount - 1] of TMediumFreeBlock;
1983 {-----------------Large block management------------------}
1984 {Are large blocks locked?}
1985 LargeBlocksLocked: Boolean;
1986 {A dummy large block header: Maintains a list of all allocated large blocks
1987 to enable memory leak detection on program shutdown.}
1988 LargeBlocksCircularList: TLargeBlockHeader;
1989 {-------------------------Expected Memory Leak Structures--------------------}
1990 {$ifdef EnableMemoryLeakReporting}
1991 {The expected memory leaks}
1992 ExpectedMemoryLeaks: PExpectedMemoryLeaks;
1993 ExpectedMemoryLeaksListLocked: Boolean;
1994 {$endif}
1995 {---------------------Full Debug Mode structures--------------------}
1996 {$ifdef FullDebugMode}
1997 {The allocation group stack}
1998 AllocationGroupStack: array[0..AllocationGroupStackSize - 1] of Cardinal;
1999 {The allocation group stack top (it is an index into AllocationGroupStack)}
2000 AllocationGroupStackTop: Cardinal;
2001 {The last allocation number used}
2002 CurrentAllocationNumber: Cardinal;
2003 {This is a count of the number of threads currently inside any of the
2004 FullDebugMode GetMem, Freemem or ReallocMem handlers. If this value
2005 is negative then a block scan is in progress and no thread may
2006 allocate, free or reallocate any block or modify any FullDebugMode
2007 block header or footer.}
2008 ThreadsInFullDebugModeRoutine: Integer;
2009 {The current log file name}
2010 MMLogFileName: array[0..1023] of AnsiChar;
2011 {The 64K block of reserved memory used to trap invalid memory accesses using
2012 fields in a freed object.}
2013 ReservedBlock: Pointer;
2014 {The virtual method index count - used to get the virtual method index for a
2015 virtual method call on a freed object.}
2016 VMIndex: Integer;
2017 {The fake VMT used to catch virtual method calls on freed objects.}
2018 FreedObjectVMT: packed record
2019 VMTData: array[vmtSelfPtr .. vmtParent + SizeOf(Pointer) - 1] of byte;
2020 VMTMethods: array[SizeOf(Pointer) + vmtParent .. vmtParent + MaxFakeVMTEntries * SizeOf(Pointer) + SizeOf(Pointer) - 1] of Byte;
2021 end;
2022 {$ifdef CatchUseOfFreedInterfaces}
2023 VMTBadInterface: array[0..MaxFakeVMTEntries - 1] of Pointer;
2024 {$endif}
2025 {$endif}
2026 {--------------Other info--------------}
2027 {The memory manager that was replaced}
2028 OldMemoryManager: {$ifndef BDS2006AndUp}TMemoryManager{$else}TMemoryManagerEx{$endif};
2029 {The replacement memory manager}
2030 NewMemoryManager: {$ifndef BDS2006AndUp}TMemoryManager{$else}TMemoryManagerEx{$endif};
2031 {$ifdef DetectMMOperationsAfterUninstall}
2032 {Invalid handlers to catch MM operations after uninstall}
2033 InvalidMemoryManager: {$ifndef BDS2006AndUp}TMemoryManager{$else}TMemoryManagerEx{$endif} = (
2034 GetMem: InvalidGetMem;
2035 FreeMem: InvalidFreeMem;
2036 ReallocMem: InvalidReallocMem
2037 {$ifdef BDS2006AndUp};
2038 AllocMem: InvalidAllocMem;
2039 RegisterExpectedMemoryLeak: InvalidRegisterAndUnRegisterMemoryLeak;
2040 UnRegisterExpectedMemoryLeak: InvalidRegisterAndUnRegisterMemoryLeak;
2041 {$endif}
2042 );
2043 {$endif}
2044
2045 {$ifdef MMSharingEnabled}
2046 {A string uniquely identifying the current process (for sharing the memory
2047 manager between DLLs and the main application)}
2048 MappingObjectName: array[0..25] of AnsiChar = ('L', 'o', 'c', 'a', 'l', '\',
2049 'F', 'a', 's', 't', 'M', 'M', '_', 'P', 'I', 'D', '_', '?', '?', '?', '?',
2050 '?', '?', '?', '?', #0);
2051 {$ifdef EnableBackwardCompatibleMMSharing}
2052 UniqueProcessIDString: array[1..20] of AnsiChar = ('?', '?', '?', '?', '?',
2053 '?', '?', '?', '_', 'P', 'I', 'D', '_', 'F', 'a', 's', 't', 'M', 'M', #0);
2054 UniqueProcessIDStringBE: array[1..23] of AnsiChar = ('?', '?', '?', '?', '?',
2055 '?', '?', '?', '_', 'P', 'I', 'D', '_', 'F', 'a', 's', 't', 'M', 'M', '_',
2056 'B', 'E', #0);
2057 {The handle of the MM window}
2058 MMWindow: HWND;
2059 {The handle of the MM window (for default MM of Delphi 2006 compatibility)}
2060 MMWindowBE: HWND;
2061 {$endif}
2062 {The handle of the memory mapped file}
2063 MappingObjectHandle: NativeUInt;
2064 {$endif}
2065 {Has FastMM been installed?}
2066 FastMMIsInstalled: Boolean;
2067 {Is the MM in place a shared memory manager?}
2068 IsMemoryManagerOwner: Boolean;
2069 {Must MMX be used for move operations?}
2070 {$ifdef EnableMMX}
2071 {$ifndef ForceMMX}
2072 UseMMX: Boolean;
2073 {$endif}
2074 {$endif}
2075 {Is a MessageBox currently showing? If so, do not show another one.}
2076 ShowingMessageBox: Boolean;
2077 {True if RunInitializationCode has been called already.}
2078 InitializationCodeHasRun: Boolean = False;
2079
2080 {----------------Utility Functions------------------}
2081
2082 {A copy of StrLen in order to avoid the SysUtils unit, which would have
2083 introduced overhead like exception handling code.}
StrLennull2084 function StrLen(const AStr: PAnsiChar): NativeUInt;
2085 {$ifndef Use32BitAsm}
2086 begin
2087 Result := 0;
2088 while AStr[Result] <> #0 do
2089 Inc(Result);
2090 end;
2091 {$else}
2092 asm
2093 {Check the first byte}
2094 cmp byte ptr [eax], 0
2095 je @ZeroLength
2096 {Get the negative of the string start in edx}
2097 mov edx, eax
2098 neg edx
2099 {Word align}
2100 add eax, 1
2101 and eax, -2
2102 @ScanLoop:
2103 mov cx, [eax]
2104 add eax, 2
2105 test cl, ch
2106 jnz @ScanLoop
2107 test cl, cl
2108 jz @ReturnLess2
2109 test ch, ch
2110 jnz @ScanLoop
2111 lea eax, [eax + edx - 1]
2112 ret
2113 @ReturnLess2:
2114 lea eax, [eax + edx - 2]
2115 ret
2116 @ZeroLength:
2117 xor eax, eax
2118 end;
2119 {$endif}
2120
2121 {$ifdef EnableMMX}
2122 {$ifndef ForceMMX}
2123 {Returns true if the CPUID instruction is supported}
CPUID_Supportednull2124 function CPUID_Supported: Boolean;
2125 asm
2126 pushfd
2127 pop eax
2128 mov edx, eax
2129 xor eax, $200000
2130 push eax
2131 popfd
2132 pushfd
2133 pop eax
2134 xor eax, edx
2135 setnz al
2136 end;
2137
2138 {Gets the CPUID}
GetCPUIDnull2139 function GetCPUID(AInfoRequired: Integer): TRegisters;
2140 asm
2141 push ebx
2142 push esi
2143 mov esi, edx
2144 {cpuid instruction}
2145 {$ifdef Delphi4or5}
2146 db $0f, $a2
2147 {$else}
2148 cpuid
2149 {$endif}
2150 {Save registers}
2151 mov TRegisters[esi].RegEAX, eax
2152 mov TRegisters[esi].RegEBX, ebx
2153 mov TRegisters[esi].RegECX, ecx
2154 mov TRegisters[esi].RegEDX, edx
2155 pop esi
2156 pop ebx
2157 end;
2158
2159 {Returns true if the CPU supports MMX}
MMX_Supportednull2160 function MMX_Supported: Boolean;
2161 var
2162 LReg: TRegisters;
2163 begin
2164 if CPUID_Supported then
2165 begin
2166 {Get the CPUID}
2167 LReg := GetCPUID(1);
2168 {Bit 23 must be set for MMX support}
2169 Result := LReg.RegEDX and $800000 <> 0;
2170 end
2171 else
2172 Result := False;
2173 end;
2174 {$endif}
2175 {$endif}
2176
2177 {Compare [AAddress], CompareVal:
2178 If Equal: [AAddress] := NewVal and result = CompareVal
2179 If Unequal: Result := [AAddress]}
LockCmpxchgnull2180 function LockCmpxchg(CompareVal, NewVal: Byte; AAddress: PByte): Byte;
2181 asm
2182 {$ifdef 32Bit}
2183 {On entry:
2184 al = CompareVal,
2185 dl = NewVal,
2186 ecx = AAddress}
2187 {$ifndef LINUX}
2188 lock cmpxchg [ecx], dl
2189 {$else}
2190 {Workaround for Kylix compiler bug}
2191 db $F0, $0F, $B0, $11
2192 {$endif}
2193 {$else}
2194 {On entry:
2195 cl = CompareVal
2196 dl = NewVal
2197 r8 = AAddress}
2198 .noframe
2199 mov rax, rcx
2200 lock cmpxchg [r8], dl
2201 {$endif}
2202 end;
2203
2204 {$ifndef ASMVersion}
2205 {Gets the first set bit in the 32-bit number, returning the bit index}
FindFirstSetBitnull2206 function FindFirstSetBit(ACardinal: Cardinal): Cardinal;
2207 asm
2208 {$ifdef 64Bit}
2209 .noframe
2210 mov rax, rcx
2211 {$endif}
2212 bsf eax, eax
2213 end;
2214 {$endif}
2215
2216 {$ifdef MACOS}
2217
StrLCopynull2218 function StrLCopy(Dest: PAnsiChar; const Source: PAnsiChar; MaxLen: Cardinal): PAnsiChar;
2219 var
2220 Len: Cardinal;
2221 begin
2222 Result := Dest;
2223 Len := StrLen(Source);
2224 if Len > MaxLen then
2225 Len := MaxLen;
2226 Move(Source^, Dest^, Len * SizeOf(AnsiChar));
2227 Dest[Len] := #0;
2228 end;
2229
GetModuleFileNamenull2230 function GetModuleFileName(Module: HMODULE; Buffer: PAnsiChar; BufLen: Integer): Integer;
2231 const
2232 CUnknown: AnsiString = 'unknown';
2233 var
2234 tmp: array[0..512] of Char;
2235 begin
2236 if FastMMIsInstalled then
2237 begin
2238 Result := System.GetModuleFileName(Module, tmp, BufLen);
2239 StrLCopy(Buffer, PAnsiChar(AnsiString(tmp)), BufLen);
2240 end
2241 else
2242 begin
2243 Result := Length(CUnknown);
2244 StrLCopy(Buffer, Pointer(CUnknown), Result + 1);
2245 end;
2246 end;
2247
2248 const
2249 INVALID_HANDLE_VALUE = THandle(-1);
2250
FileCreatenull2251 function FileCreate(const FileName: string): THandle;
2252 begin
2253 Result := THandle(__open(PAnsiChar(UTF8String(FileName)), O_RDWR or O_CREAT or O_TRUNC or O_EXCL, FileAccessRights));
2254 end;
2255
2256 {$endif}
2257
2258 {Writes the module filename to the specified buffer and returns the number of
2259 characters written.}
AppendModuleFileNamenull2260 function AppendModuleFileName(ABuffer: PAnsiChar): Integer;
2261 var
2262 LModuleHandle: HModule;
2263 begin
2264 {Get the module handle}
2265 {$ifndef borlndmmdll}
2266 if IsLibrary then
2267 LModuleHandle := HInstance
2268 else
2269 {$endif}
2270 LModuleHandle := 0;
2271 {Get the module name}
2272 {$ifndef POSIX}
2273 Result := GetModuleFileNameA(LModuleHandle, ABuffer, 512);
2274 {$else}
2275 Result := GetModuleFileName(LModuleHandle, ABuffer, 512);
2276 {$endif}
2277 end;
2278
2279 {Copies the name of the module followed by the given string to the buffer,
2280 returning the pointer following the buffer.}
AppendStringToModuleNamenull2281 function AppendStringToModuleName(AString, ABuffer: PAnsiChar): PAnsiChar;
2282 var
2283 LModuleNameLength: Cardinal;
2284 LCopyStart: PAnsiChar;
2285 begin
2286 {Get the name of the application}
2287 LModuleNameLength := AppendModuleFileName(ABuffer);
2288 {Replace the last few characters}
2289 if LModuleNameLength > 0 then
2290 begin
2291 {Find the last backslash}
2292 LCopyStart := PAnsiChar(PByte(ABuffer) + LModuleNameLength - 1);
2293 LModuleNameLength := 0;
2294 while (UIntPtr(LCopyStart) >= UIntPtr(ABuffer))
2295 and (LCopyStart^ <> '\') do
2296 begin
2297 Inc(LModuleNameLength);
2298 Dec(LCopyStart);
2299 end;
2300 {Copy the name to the start of the buffer}
2301 Inc(LCopyStart);
2302 System.Move(LCopyStart^, ABuffer^, LModuleNameLength);
2303 Inc(ABuffer, LModuleNameLength);
2304 ABuffer^ := ':';
2305 Inc(ABuffer);
2306 ABuffer^ := ' ';
2307 Inc(ABuffer);
2308 end;
2309 {Append the string}
2310 while AString^ <> #0 do
2311 begin
2312 ABuffer^ := AString^;
2313 Inc(ABuffer);
2314 {Next char}
2315 Inc(AString);
2316 end;
2317 ABuffer^ := #0;
2318 Result := ABuffer;
2319 end;
2320
2321 {----------------Faster Move Procedures-------------------}
2322
2323 {Fixed size move operations ignore the size parameter. All moves are assumed to
2324 be non-overlapping.}
2325
2326 procedure Move4(const ASource; var ADest; ACount: NativeInt);
2327 asm
2328 {$ifdef 32Bit}
2329 mov eax, [eax]
2330 mov [edx], eax
2331 {$else}
2332 .noframe
2333 mov eax, [rcx]
2334 mov [rdx], eax
2335 {$endif}
2336 end;
2337
2338 {$ifdef 64Bit}
2339 procedure Move8(const ASource; var ADest; ACount: NativeInt);
2340 asm
2341 mov rax, [rcx]
2342 mov [rdx], rax
2343 end;
2344 {$endif}
2345
2346 procedure Move12(const ASource; var ADest; ACount: NativeInt);
2347 asm
2348 {$ifdef 32Bit}
2349 mov ecx, [eax]
2350 mov [edx], ecx
2351 mov ecx, [eax + 4]
2352 mov eax, [eax + 8]
2353 mov [edx + 4], ecx
2354 mov [edx + 8], eax
2355 {$else}
2356 .noframe
2357 mov rax, [rcx]
2358 mov ecx, [rcx + 8]
2359 mov [rdx], rax
2360 mov [rdx + 8], ecx
2361 {$endif}
2362 end;
2363
2364 procedure Move20(const ASource; var ADest; ACount: NativeInt);
2365 asm
2366 {$ifdef 32Bit}
2367 mov ecx, [eax]
2368 mov [edx], ecx
2369 mov ecx, [eax + 4]
2370 mov [edx + 4], ecx
2371 mov ecx, [eax + 8]
2372 mov [edx + 8], ecx
2373 mov ecx, [eax + 12]
2374 mov eax, [eax + 16]
2375 mov [edx + 12], ecx
2376 mov [edx + 16], eax
2377 {$else}
2378 .noframe
2379 movdqa xmm0, [rcx]
2380 mov ecx, [rcx + 16]
2381 movdqa [rdx], xmm0
2382 mov [rdx + 16], ecx
2383 {$endif}
2384 end;
2385
2386 {$ifdef 64Bit}
2387 procedure Move24(const ASource; var ADest; ACount: NativeInt);
2388 asm
2389 movdqa xmm0, [rcx]
2390 mov r8, [rcx + 16]
2391 movdqa [rdx], xmm0
2392 mov [rdx + 16], r8
2393 end;
2394 {$endif}
2395
2396 procedure Move28(const ASource; var ADest; ACount: NativeInt);
2397 asm
2398 {$ifdef 32Bit}
2399 mov ecx, [eax]
2400 mov [edx], ecx
2401 mov ecx, [eax + 4]
2402 mov [edx + 4], ecx
2403 mov ecx, [eax + 8]
2404 mov [edx + 8], ecx
2405 mov ecx, [eax + 12]
2406 mov [edx + 12], ecx
2407 mov ecx, [eax + 16]
2408 mov [edx + 16], ecx
2409 mov ecx, [eax + 20]
2410 mov eax, [eax + 24]
2411 mov [edx + 20], ecx
2412 mov [edx + 24], eax
2413 {$else}
2414 .noframe
2415 movdqa xmm0, [rcx]
2416 mov r8, [rcx + 16]
2417 mov ecx, [rcx + 24]
2418 movdqa [rdx], xmm0
2419 mov [rdx + 16], r8
2420 mov [rdx + 24], ecx
2421 {$endif}
2422 end;
2423
2424 procedure Move36(const ASource; var ADest; ACount: NativeInt);
2425 asm
2426 {$ifdef 32Bit}
2427 fild qword ptr [eax]
2428 fild qword ptr [eax + 8]
2429 fild qword ptr [eax + 16]
2430 fild qword ptr [eax + 24]
2431 mov ecx, [eax + 32]
2432 mov [edx + 32], ecx
2433 fistp qword ptr [edx + 24]
2434 fistp qword ptr [edx + 16]
2435 fistp qword ptr [edx + 8]
2436 fistp qword ptr [edx]
2437 {$else}
2438 .noframe
2439 movdqa xmm0, [rcx]
2440 movdqa xmm1, [rcx + 16]
2441 mov ecx, [rcx + 32]
2442 movdqa [rdx], xmm0
2443 movdqa [rdx + 16], xmm1
2444 mov [rdx + 32], ecx
2445 {$endif}
2446 end;
2447
2448 {$ifdef 64Bit}
2449 procedure Move40(const ASource; var ADest; ACount: NativeInt);
2450 asm
2451 movdqa xmm0, [rcx]
2452 movdqa xmm1, [rcx + 16]
2453 mov r8, [rcx + 32]
2454 movdqa [rdx], xmm0
2455 movdqa [rdx + 16], xmm1
2456 mov [rdx + 32], r8
2457 end;
2458 {$endif}
2459
2460 procedure Move44(const ASource; var ADest; ACount: NativeInt);
2461 asm
2462 {$ifdef 32Bit}
2463 fild qword ptr [eax]
2464 fild qword ptr [eax + 8]
2465 fild qword ptr [eax + 16]
2466 fild qword ptr [eax + 24]
2467 fild qword ptr [eax + 32]
2468 mov ecx, [eax + 40]
2469 mov [edx + 40], ecx
2470 fistp qword ptr [edx + 32]
2471 fistp qword ptr [edx + 24]
2472 fistp qword ptr [edx + 16]
2473 fistp qword ptr [edx + 8]
2474 fistp qword ptr [edx]
2475 {$else}
2476 .noframe
2477 movdqa xmm0, [rcx]
2478 movdqa xmm1, [rcx + 16]
2479 mov r8, [rcx + 32]
2480 mov ecx, [rcx + 40]
2481 movdqa [rdx], xmm0
2482 movdqa [rdx + 16], xmm1
2483 mov [rdx + 32], r8
2484 mov [rdx + 40], ecx
2485 {$endif}
2486 end;
2487
2488 procedure Move52(const ASource; var ADest; ACount: NativeInt);
2489 asm
2490 {$ifdef 32Bit}
2491 fild qword ptr [eax]
2492 fild qword ptr [eax + 8]
2493 fild qword ptr [eax + 16]
2494 fild qword ptr [eax + 24]
2495 fild qword ptr [eax + 32]
2496 fild qword ptr [eax + 40]
2497 mov ecx, [eax + 48]
2498 mov [edx + 48], ecx
2499 fistp qword ptr [edx + 40]
2500 fistp qword ptr [edx + 32]
2501 fistp qword ptr [edx + 24]
2502 fistp qword ptr [edx + 16]
2503 fistp qword ptr [edx + 8]
2504 fistp qword ptr [edx]
2505 {$else}
2506 .noframe
2507 movdqa xmm0, [rcx]
2508 movdqa xmm1, [rcx + 16]
2509 movdqa xmm2, [rcx + 32]
2510 mov ecx, [rcx + 48]
2511 movdqa [rdx], xmm0
2512 movdqa [rdx + 16], xmm1
2513 movdqa [rdx + 32], xmm2
2514 mov [rdx + 48], ecx
2515 {$endif}
2516 end;
2517
2518 {$ifdef 64Bit}
2519 procedure Move56(const ASource; var ADest; ACount: NativeInt);
2520 asm
2521 movdqa xmm0, [rcx]
2522 movdqa xmm1, [rcx + 16]
2523 movdqa xmm2, [rcx + 32]
2524 mov r8, [rcx + 48]
2525 movdqa [rdx], xmm0
2526 movdqa [rdx + 16], xmm1
2527 movdqa [rdx + 32], xmm2
2528 mov [rdx + 48], r8
2529 end;
2530 {$endif}
2531
2532 procedure Move60(const ASource; var ADest; ACount: NativeInt);
2533 asm
2534 {$ifdef 32Bit}
2535 fild qword ptr [eax]
2536 fild qword ptr [eax + 8]
2537 fild qword ptr [eax + 16]
2538 fild qword ptr [eax + 24]
2539 fild qword ptr [eax + 32]
2540 fild qword ptr [eax + 40]
2541 fild qword ptr [eax + 48]
2542 mov ecx, [eax + 56]
2543 mov [edx + 56], ecx
2544 fistp qword ptr [edx + 48]
2545 fistp qword ptr [edx + 40]
2546 fistp qword ptr [edx + 32]
2547 fistp qword ptr [edx + 24]
2548 fistp qword ptr [edx + 16]
2549 fistp qword ptr [edx + 8]
2550 fistp qword ptr [edx]
2551 {$else}
2552 .noframe
2553 movdqa xmm0, [rcx]
2554 movdqa xmm1, [rcx + 16]
2555 movdqa xmm2, [rcx + 32]
2556 mov r8, [rcx + 48]
2557 mov ecx, [rcx + 56]
2558 movdqa [rdx], xmm0
2559 movdqa [rdx + 16], xmm1
2560 movdqa [rdx + 32], xmm2
2561 mov [rdx + 48], r8
2562 mov [rdx + 56], ecx
2563 {$endif}
2564 end;
2565
2566 procedure Move68(const ASource; var ADest; ACount: NativeInt);
2567 asm
2568 {$ifdef 32Bit}
2569 fild qword ptr [eax]
2570 fild qword ptr [eax + 8]
2571 fild qword ptr [eax + 16]
2572 fild qword ptr [eax + 24]
2573 fild qword ptr [eax + 32]
2574 fild qword ptr [eax + 40]
2575 fild qword ptr [eax + 48]
2576 fild qword ptr [eax + 56]
2577 mov ecx, [eax + 64]
2578 mov [edx + 64], ecx
2579 fistp qword ptr [edx + 56]
2580 fistp qword ptr [edx + 48]
2581 fistp qword ptr [edx + 40]
2582 fistp qword ptr [edx + 32]
2583 fistp qword ptr [edx + 24]
2584 fistp qword ptr [edx + 16]
2585 fistp qword ptr [edx + 8]
2586 fistp qword ptr [edx]
2587 {$else}
2588 .noframe
2589 movdqa xmm0, [rcx]
2590 movdqa xmm1, [rcx + 16]
2591 movdqa xmm2, [rcx + 32]
2592 movdqa xmm3, [rcx + 48]
2593 mov ecx, [rcx + 64]
2594 movdqa [rdx], xmm0
2595 movdqa [rdx + 16], xmm1
2596 movdqa [rdx + 32], xmm2
2597 movdqa [rdx + 48], xmm3
2598 mov [rdx + 64], ecx
2599 {$endif}
2600 end;
2601
2602 {Variable size move procedure: Rounds ACount up to the next multiple of 16 less
2603 SizeOf(Pointer). Important note: Always moves at least 16 - SizeOf(Pointer)
2604 bytes (the minimum small block size with 16 byte alignment), irrespective of
2605 ACount.}
2606 procedure MoveX16LP(const ASource; var ADest; ACount: NativeInt);
2607 asm
2608 {$ifdef 32Bit}
2609 {Make the counter negative based: The last 12 bytes are moved separately}
2610 sub ecx, 12
2611 add eax, ecx
2612 add edx, ecx
2613 {$ifdef EnableMMX}
2614 {$ifndef ForceMMX}
2615 cmp UseMMX, True
2616 jne @FPUMove
2617 {$endif}
2618 {Make the counter negative based: The last 12 bytes are moved separately}
2619 neg ecx
2620 jns @MMXMoveLast12
2621 @MMXMoveLoop:
2622 {Move a 16 byte block}
2623 {$ifdef Delphi4or5}
2624 {Delphi 5 compatibility}
2625 db $0f, $6f, $04, $01
2626 db $0f, $6f, $4c, $01, $08
2627 db $0f, $7f, $04, $11
2628 db $0f, $7f, $4c, $11, $08
2629 {$else}
2630 movq mm0, [eax + ecx]
2631 movq mm1, [eax + ecx + 8]
2632 movq [edx + ecx], mm0
2633 movq [edx + ecx + 8], mm1
2634 {$endif}
2635 {Are there another 16 bytes to move?}
2636 add ecx, 16
2637 js @MMXMoveLoop
2638 @MMXMoveLast12:
2639 {Do the last 12 bytes}
2640 {$ifdef Delphi4or5}
2641 {Delphi 5 compatibility}
2642 db $0f, $6f, $04, $01
2643 {$else}
2644 movq mm0, [eax + ecx]
2645 {$endif}
2646 mov eax, [eax + ecx + 8]
2647 {$ifdef Delphi4or5}
2648 {Delphi 5 compatibility}
2649 db $0f, $7f, $04, $11
2650 {$else}
2651 movq [edx + ecx], mm0
2652 {$endif}
2653 mov [edx + ecx + 8], eax
2654 {Exit MMX state}
2655 {$ifdef Delphi4or5}
2656 {Delphi 5 compatibility}
2657 db $0f, $77
2658 {$else}
2659 emms
2660 {$endif}
2661 {$ifndef ForceMMX}
2662 ret
2663 {$endif}
2664 {$endif}
2665 {FPU code is only used if MMX is not forced}
2666 {$ifndef ForceMMX}
2667 @FPUMove:
2668 neg ecx
2669 jns @FPUMoveLast12
2670 @FPUMoveLoop:
2671 {Move a 16 byte block}
2672 fild qword ptr [eax + ecx]
2673 fild qword ptr [eax + ecx + 8]
2674 fistp qword ptr [edx + ecx + 8]
2675 fistp qword ptr [edx + ecx]
2676 {Are there another 16 bytes to move?}
2677 add ecx, 16
2678 js @FPUMoveLoop
2679 @FPUMoveLast12:
2680 {Do the last 12 bytes}
2681 fild qword ptr [eax + ecx]
2682 fistp qword ptr [edx + ecx]
2683 mov eax, [eax + ecx + 8]
2684 mov [edx + ecx + 8], eax
2685 {$endif}
2686 {$else}
2687 .noframe
2688 {Make the counter negative based: The last 8 bytes are moved separately}
2689 sub r8, 8
2690 add rcx, r8
2691 add rdx, r8
2692 neg r8
2693 jns @MoveLast12
2694 @MoveLoop:
2695 {Move a 16 byte block}
2696 movdqa xmm0, [rcx + r8]
2697 movdqa [rdx + r8], xmm0
2698 {Are there another 16 bytes to move?}
2699 add r8, 16
2700 js @MoveLoop
2701 @MoveLast12:
2702 {Do the last 8 bytes}
2703 mov r9, [rcx + r8]
2704 mov [rdx + r8], r9
2705 {$endif}
2706 end;
2707
2708 {Variable size move procedure: Rounds ACount up to the next multiple of 8 less
2709 SizeOf(Pointer). Important note: Always moves at least 8 - SizeOf(Pointer)
2710 bytes (the minimum small block size with 8 byte alignment), irrespective of
2711 ACount.}
2712 procedure MoveX8LP(const ASource; var ADest; ACount: NativeInt);
2713 asm
2714 {$ifdef 32Bit}
2715 {Make the counter negative based: The last 4 bytes are moved separately}
2716 sub ecx, 4
2717 {4 bytes or less? -> Use the Move4 routine.}
2718 jle @FourBytesOrLess
2719 add eax, ecx
2720 add edx, ecx
2721 neg ecx
2722 {$ifdef EnableMMX}
2723 {$ifndef ForceMMX}
2724 cmp UseMMX, True
2725 jne @FPUMoveLoop
2726 {$endif}
2727 @MMXMoveLoop:
2728 {Move an 8 byte block}
2729 {$ifdef Delphi4or5}
2730 {Delphi 5 compatibility}
2731 db $0f, $6f, $04, $01
2732 db $0f, $7f, $04, $11
2733 {$else}
2734 movq mm0, [eax + ecx]
2735 movq [edx + ecx], mm0
2736 {$endif}
2737 {Are there another 8 bytes to move?}
2738 add ecx, 8
2739 js @MMXMoveLoop
2740 {Exit MMX state}
2741 {$ifdef Delphi4or5}
2742 {Delphi 5 compatibility}
2743 db $0f, $77
2744 {$else}
2745 emms
2746 {$endif}
2747 {Do the last 4 bytes}
2748 mov eax, [eax + ecx]
2749 mov [edx + ecx], eax
2750 ret
2751 {$endif}
2752 {FPU code is only used if MMX is not forced}
2753 {$ifndef ForceMMX}
2754 @FPUMoveLoop:
2755 {Move an 8 byte block}
2756 fild qword ptr [eax + ecx]
2757 fistp qword ptr [edx + ecx]
2758 {Are there another 8 bytes to move?}
2759 add ecx, 8
2760 js @FPUMoveLoop
2761 {Do the last 4 bytes}
2762 mov eax, [eax + ecx]
2763 mov [edx + ecx], eax
2764 ret
2765 {$endif}
2766 @FourBytesOrLess:
2767 {Four or less bytes to move}
2768 mov eax, [eax]
2769 mov [edx], eax
2770 {$else}
2771 .noframe
2772 {Make the counter negative based}
2773 add rcx, r8
2774 add rdx, r8
2775 neg r8
2776 @MoveLoop:
2777 {Move an 8 byte block}
2778 mov r9, [rcx + r8]
2779 mov [rdx + r8], r9
2780 {Are there another 8 bytes to move?}
2781 add r8, 8
2782 js @MoveLoop
2783 {$endif}
2784 end;
2785
2786 {----------------Windows Emulation Functions for Kylix / OS X Support-----------------}
2787
2788 {$ifdef POSIX}
2789
2790 const
2791 {Messagebox constants}
2792 MB_OK = 0;
2793 MB_ICONERROR = $10;
2794 MB_TASKMODAL = $2000;
2795 MB_DEFAULT_DESKTOP_ONLY = $20000;
2796 {Virtual memory constants}
2797 MEM_COMMIT = $1000;
2798 MEM_RELEASE = $8000;
2799 MEM_TOP_DOWN = $100000;
2800 PAGE_READWRITE = 4;
2801
2802 procedure MessageBoxA(hWnd: Cardinal; AMessageText, AMessageTitle: PAnsiChar; uType: Cardinal); stdcall;
2803 begin
2804 if FastMMIsInstalled then
2805 writeln(AMessageText)
2806 else
2807 __write(STDERR_FILENO, AMessageText, StrLen(AMessageText));
2808 end;
2809
VirtualAllocnull2810 function VirtualAlloc(lpvAddress: Pointer; dwSize, flAllocationType, flProtect: Cardinal): Pointer; stdcall;
2811 begin
2812 Result := valloc(dwSize);
2813 end;
2814
VirtualFreenull2815 function VirtualFree(lpAddress: Pointer; dwSize, dwFreeType: Cardinal): LongBool; stdcall;
2816 begin
2817 free(lpAddress);
2818 Result := True;
2819 end;
2820
WriteFilenull2821 function WriteFile(hFile: THandle; const Buffer; nNumberOfBytesToWrite: Cardinal;
2822 var lpNumberOfBytesWritten: Cardinal; lpOverlapped: Pointer): Boolean; stdcall;
2823 begin
2824 lpNumberOfBytesWritten := __write(hFile, @Buffer, nNumberOfBytesToWrite);
2825 if lpNumberOfBytesWritten = Cardinal(-1) then
2826 begin
2827 lpNumberOfBytesWritten := 0;
2828 Result := False;
2829 end
2830 else
2831 Result := True;
2832 end;
2833
2834 {$ifndef NeverSleepOnThreadContention}
2835 procedure Sleep(dwMilliseconds: Cardinal); stdcall;
2836 begin
2837 {Convert to microseconds (more or less)}
2838 usleep(dwMilliseconds shl 10);
2839 end;
2840 {$endif}
2841 {$endif}
2842
2843 {-----------------Debugging Support Functions and Procedures------------------}
2844
2845 {$ifdef FullDebugMode}
2846
2847 {Returns the current thread ID}
GetThreadIDnull2848 function GetThreadID: Cardinal;
2849 {$ifdef 32Bit}
2850 asm
2851 mov eax, FS:[$24]
2852 end;
2853 {$else}
2854 begin
2855 Result := GetCurrentThreadId;
2856 end;
2857 {$endif}
2858
2859 {Fills a block of memory with the given dword (32-bit) or qword (64-bit).
2860 Always fills a multiple of SizeOf(Pointer) bytes}
2861 procedure DebugFillMem(var AAddress; AByteCount: NativeInt; AFillValue: NativeUInt);
2862 asm
2863 {$ifdef 32Bit}
2864 {On Entry:
2865 eax = AAddress
2866 edx = AByteCount
2867 ecx = AFillValue}
2868 add eax, edx
2869 neg edx
2870 jns @Done
2871 @FillLoop:
2872 mov [eax + edx], ecx
2873 add edx, 4
2874 js @FillLoop
2875 @Done:
2876 {$else}
2877 {On Entry:
2878 rcx = AAddress
2879 rdx = AByteCount
2880 r8 = AFillValue}
2881 add rcx, rdx
2882 neg rdx
2883 jns @Done
2884 @FillLoop:
2885 mov [rcx + rdx], r8
2886 add rdx, 8
2887 js @FillLoop
2888 @Done:
2889 {$endif}
2890 end;
2891
2892 {$ifndef LoadDebugDLLDynamically}
2893
2894 {The stack trace procedure. The stack trace module is external since it may
2895 raise handled access violations that result in the creation of exception
2896 objects and the stack trace code is not re-entrant.}
2897 procedure GetStackTrace(AReturnAddresses: PNativeUInt;
2898 AMaxDepth, ASkipFrames: Cardinal); external FullDebugModeLibraryName
2899 name {$ifdef RawStackTraces}'GetRawStackTrace'{$else}'GetFrameBasedStackTrace'{$endif};
2900
2901 {The exported procedure in the FastMM_FullDebugMode.dll library used to convert
2902 the return addresses of a stack trace to a text string.}
LogStackTracenull2903 function LogStackTrace(AReturnAddresses: PNativeUInt;
2904 AMaxDepth: Cardinal; ABuffer: PAnsiChar): PAnsiChar; external FullDebugModeLibraryName
2905 name 'LogStackTrace';
2906
2907 {$else}
2908
2909 {Default no-op stack trace and logging handlers}
2910 procedure NoOpGetStackTrace(AReturnAddresses: PNativeUInt;
2911 AMaxDepth, ASkipFrames: Cardinal);
2912 begin
2913 DebugFillMem(AReturnAddresses^, AMaxDepth * SizeOf(Pointer), 0);
2914 end;
2915
NoOpLogStackTracenull2916 function NoOpLogStackTrace(AReturnAddresses: PNativeUInt;
2917 AMaxDepth: Cardinal; ABuffer: PAnsiChar): PAnsiChar;
2918 begin
2919 Result := ABuffer;
2920 end;
2921
2922 var
2923
2924 {Handle to the FullDebugMode DLL}
2925 FullDebugModeDLL: HMODULE;
2926
2927 GetStackTrace: procedure (AReturnAddresses: PNativeUInt;
2928 AMaxDepth, ASkipFrames: Cardinal) = NoOpGetStackTrace;
2929
2930 LogStackTrace: function (AReturnAddresses: PNativeUInt;
2931 AMaxDepth: Cardinal; ABuffer: PAnsiChar): PAnsiChar = NoOpLogStackTrace;
2932
2933 {$endif}
2934
2935 {$endif}
2936
2937 {$ifndef POSIX}
DelphiIsRunningnull2938 function DelphiIsRunning: Boolean;
2939 begin
2940 Result := FindWindowA('TAppBuilder', nil) <> 0;
2941 end;
2942 {$endif}
2943
2944 {Converts an unsigned integer to string at the buffer location, returning the
2945 new buffer position. Note: The 32-bit asm version only supports numbers up to
2946 2^31 - 1.}
NativeUIntToStrBufnull2947 function NativeUIntToStrBuf(ANum: NativeUInt; APBuffer: PAnsiChar): PAnsiChar;
2948 {$ifndef Use32BitAsm}
2949 const
2950 MaxDigits = 20;
2951 var
2952 LDigitBuffer: array[0..MaxDigits - 1] of AnsiChar;
2953 LCount: Cardinal;
2954 LDigit: NativeUInt;
2955 begin
2956 {Generate the digits in the local buffer}
2957 LCount := 0;
2958 repeat
2959 LDigit := ANum;
2960 ANum := ANum div 10;
2961 LDigit := LDigit - ANum * 10;
2962 Inc(LCount);
2963 LDigitBuffer[MaxDigits - LCount] := AnsiChar(Ord('0') + LDigit);
2964 until ANum = 0;
2965 {Copy the digits to the output buffer and advance it}
2966 System.Move(LDigitBuffer[MaxDigits - LCount], APBuffer^, LCount);
2967 Result := APBuffer + LCount;
2968 end;
2969 {$else}
2970 asm
2971 {On entry: eax = ANum, edx = ABuffer}
2972 push edi
2973 mov edi, edx //Pointer to the first character in edi
2974 {Calculate leading digit: divide the number by 1e9}
2975 add eax, 1 //Increment the number
2976 mov edx, $89705F41 //1e9 reciprocal
2977 mul edx //Multplying with reciprocal
2978 shr eax, 30 //Save fraction bits
2979 mov ecx, edx //First digit in bits <31:29>
2980 and edx, $1FFFFFFF //Filter fraction part edx<28:0>
2981 shr ecx, 29 //Get leading digit into accumulator
2982 lea edx, [edx + 4 * edx] //Calculate ...
2983 add edx, eax //... 5*fraction
2984 mov eax, ecx //Copy leading digit
2985 or eax, '0' //Convert digit to ASCII
2986 mov [edi], al //Store digit out to memory
2987 {Calculate digit #2}
2988 mov eax, edx //Point format such that 1.0 = 2^28
2989 cmp ecx, 1 //Any non-zero digit yet ?
2990 sbb edi, -1 //Yes->increment ptr, No->keep old ptr
2991 shr eax, 28 //Next digit
2992 and edx, $0fffffff //Fraction part edx<27:0>
2993 or ecx, eax //Accumulate next digit
2994 or eax, '0' //Convert digit to ASCII
2995 mov [edi], al //Store digit out to memory
2996 {Calculate digit #3}
2997 lea eax, [edx * 4 + edx] //5*fraction, new digit eax<31:27>
2998 lea edx, [edx * 4 + edx] //5*fraction, new fraction edx<26:0>
2999 cmp ecx, 1 //Any non-zero digit yet ?
3000 sbb edi, -1 //Yes->increment ptr, No->keep old ptr
3001 shr eax, 27 //Next digit
3002 and edx, $07ffffff //Fraction part
3003 or ecx, eax //Accumulate next digit
3004 or eax, '0' //Convert digit to ASCII
3005 mov [edi], al //Store digit out to memory
3006 {Calculate digit #4}
3007 lea eax, [edx * 4 + edx] //5*fraction, new digit eax<31:26>
3008 lea edx, [edx * 4 + edx] //5*fraction, new fraction edx<25:0>
3009 cmp ecx, 1 //Any non-zero digit yet ?
3010 sbb edi, -1 //Yes->increment ptr, No->keep old ptr
3011 shr eax, 26 //Next digit
3012 and edx, $03ffffff //Fraction part
3013 or ecx, eax //Accumulate next digit
3014 or eax, '0' //Convert digit to ASCII
3015 mov [edi], al //Store digit out to memory
3016 {Calculate digit #5}
3017 lea eax, [edx * 4 + edx] //5*fraction, new digit eax<31:25>
3018 lea edx, [edx * 4 + edx] //5*fraction, new fraction edx<24:0>
3019 cmp ecx, 1 //Any non-zero digit yet ?
3020 sbb edi, -1 //Yes->increment ptr, No->keep old ptr
3021 shr eax, 25 //Next digit
3022 and edx, $01ffffff //Fraction part
3023 or ecx, eax //Accumulate next digit
3024 or eax, '0' //Convert digit to ASCII
3025 mov [edi], al //Store digit out to memory
3026 {Calculate digit #6}
3027 lea eax, [edx * 4 + edx] //5*fraction, new digit eax<31:24>
3028 lea edx, [edx * 4 + edx] //5*fraction, new fraction edx<23:0>
3029 cmp ecx, 1 //Any non-zero digit yet ?
3030 sbb edi, -1 //Yes->increment ptr, No->keep old ptr
3031 shr eax, 24 //Next digit
3032 and edx, $00ffffff //Fraction part
3033 or ecx, eax //Accumulate next digit
3034 or eax, '0' //Convert digit to ASCII
3035 mov [edi], al //Store digit out to memory
3036 {Calculate digit #7}
3037 lea eax, [edx * 4 + edx] //5*fraction, new digit eax<31:23>
3038 lea edx, [edx * 4 + edx] //5*fraction, new fraction edx<31:23>
3039 cmp ecx, 1 //Any non-zero digit yet ?
3040 sbb edi, -1 //Yes->increment ptr, No->keep old ptr
3041 shr eax, 23 //Next digit
3042 and edx, $007fffff //Fraction part
3043 or ecx, eax //Accumulate next digit
3044 or eax, '0' //Convert digit to ASCII
3045 mov [edi], al //Store digit out to memory
3046 {Calculate digit #8}
3047 lea eax, [edx * 4 + edx] //5*fraction, new digit eax<31:22>
3048 lea edx, [edx * 4 + edx] //5*fraction, new fraction edx<22:0>
3049 cmp ecx, 1 //Any non-zero digit yet ?
3050 sbb edi, -1 //Yes->increment ptr, No->keep old ptr
3051 shr eax, 22 //Next digit
3052 and edx, $003fffff //Fraction part
3053 or ecx, eax //Accumulate next digit
3054 or eax, '0' //Convert digit to ASCII
3055 mov [edi], al //Store digit out to memory
3056 {Calculate digit #9}
3057 lea eax, [edx * 4 + edx] //5*fraction, new digit eax<31:21>
3058 lea edx, [edx * 4 + edx] //5*fraction, new fraction edx<21:0>
3059 cmp ecx, 1 //Any non-zero digit yet ?
3060 sbb edi, -1 //Yes->increment ptr, No->keep old ptr
3061 shr eax, 21 //Next digit
3062 and edx, $001fffff //Fraction part
3063 or ecx, eax //Accumulate next digit
3064 or eax, '0' //Convert digit to ASCII
3065 mov [edi], al //Store digit out to memory
3066 {Calculate digit #10}
3067 lea eax, [edx * 4 + edx] //5*fraction, new digit eax<31:20>
3068 cmp ecx, 1 //Any-non-zero digit yet ?
3069 sbb edi, -1 //Yes->increment ptr, No->keep old ptr
3070 shr eax, 20 //Next digit
3071 or eax, '0' //Convert digit to ASCII
3072 mov [edi], al //Store last digit and end marker out to memory
3073 {Return a pointer to the next character}
3074 lea eax, [edi + 1]
3075 {Restore edi}
3076 pop edi
3077 end;
3078 {$endif}
3079
3080 {Converts an unsigned integer to a hexadecimal string at the buffer location,
3081 returning the new buffer position.}
NativeUIntToHexBufnull3082 function NativeUIntToHexBuf(ANum: NativeUInt; APBuffer: PAnsiChar): PAnsiChar;
3083 {$ifndef Use32BitAsm}
3084 const
3085 MaxDigits = 16;
3086 var
3087 LDigitBuffer: array[0..MaxDigits - 1] of AnsiChar;
3088 LCount: Cardinal;
3089 LDigit: NativeUInt;
3090 begin
3091 {Generate the digits in the local buffer}
3092 LCount := 0;
3093 repeat
3094 LDigit := ANum;
3095 ANum := ANum div 16;
3096 LDigit := LDigit - ANum * 16;
3097 Inc(LCount);
3098 LDigitBuffer[MaxDigits - LCount] := HexTable[LDigit];
3099 until ANum = 0;
3100 {Copy the digits to the output buffer and advance it}
3101 System.Move(LDigitBuffer[MaxDigits - LCount], APBuffer^, LCount);
3102 Result := APBuffer + LCount;
3103 end;
3104 {$else}
3105 asm
3106 {On entry:
3107 eax = ANum
3108 edx = ABuffer}
3109 push ebx
3110 push edi
3111 {Save ANum in ebx}
3112 mov ebx, eax
3113 {Get a pointer to the first character in edi}
3114 mov edi, edx
3115 {Get the number in ecx as well}
3116 mov ecx, eax
3117 {Keep the low nibbles in ebx and the high nibbles in ecx}
3118 and ebx, $0f0f0f0f
3119 and ecx, $f0f0f0f0
3120 {Swap the bytes into the right order}
3121 ror ebx, 16
3122 ror ecx, 20
3123 {Get nibble 7}
3124 movzx eax, ch
3125 mov dl, ch
3126 mov al, byte ptr HexTable[eax]
3127 mov [edi], al
3128 cmp dl, 1
3129 sbb edi, -1
3130 {Get nibble 6}
3131 movzx eax, bh
3132 or dl, bh
3133 mov al, byte ptr HexTable[eax]
3134 mov [edi], al
3135 cmp dl, 1
3136 sbb edi, -1
3137 {Get nibble 5}
3138 movzx eax, cl
3139 or dl, cl
3140 mov al, byte ptr HexTable[eax]
3141 mov [edi], al
3142 cmp dl, 1
3143 sbb edi, -1
3144 {Get nibble 4}
3145 movzx eax, bl
3146 or dl, bl
3147 mov al, byte ptr HexTable[eax]
3148 mov [edi], al
3149 cmp dl, 1
3150 sbb edi, -1
3151 {Rotate ecx and ebx so we get access to the rest}
3152 shr ebx, 16
3153 shr ecx, 16
3154 {Get nibble 3}
3155 movzx eax, ch
3156 or dl, ch
3157 mov al, byte ptr HexTable[eax]
3158 mov [edi], al
3159 cmp dl, 1
3160 sbb edi, -1
3161 {Get nibble 2}
3162 movzx eax, bh
3163 or dl, bh
3164 mov al, byte ptr HexTable[eax]
3165 mov [edi], al
3166 cmp dl, 1
3167 sbb edi, -1
3168 {Get nibble 1}
3169 movzx eax, cl
3170 or dl, cl
3171 mov al, byte ptr HexTable[eax]
3172 mov [edi], al
3173 cmp dl, 1
3174 sbb edi, -1
3175 {Get nibble 0}
3176 movzx eax, bl
3177 mov al, byte ptr HexTable[eax]
3178 mov [edi], al
3179 {Return a pointer to the end of the string}
3180 lea eax, [edi + 1]
3181 {Restore registers}
3182 pop edi
3183 pop ebx
3184 end;
3185 {$endif}
3186
3187 {Appends the source text to the destination and returns the new destination
3188 position}
AppendStringToBuffernull3189 function AppendStringToBuffer(const ASource, ADestination: PAnsiChar; ACount: Cardinal): PAnsiChar;
3190 begin
3191 System.Move(ASource^, ADestination^, ACount);
3192 Result := Pointer(PByte(ADestination) + ACount);
3193 end;
3194
3195 {Appends the name of the class to the destination buffer and returns the new
3196 destination position}
AppendClassNameToBuffernull3197 function AppendClassNameToBuffer(AClass: TClass; ADestination: PAnsiChar): PAnsiChar;
3198 var
3199 LPClassName: PShortString;
3200 begin
3201 {Get a pointer to the class name}
3202 if AClass <> nil then
3203 begin
3204 LPClassName := PShortString(PPointer(PByte(AClass) + vmtClassName)^);
3205 {Append the class name}
3206 Result := AppendStringToBuffer(@LPClassName^[1], ADestination, Length(LPClassName^));
3207 end
3208 else
3209 begin
3210 Result := AppendStringToBuffer(UnknownClassNameMsg, ADestination, Length(UnknownClassNameMsg));
3211 end;
3212 end;
3213
3214 {Shows a message box if the program is not showing one already.}
3215 procedure ShowMessageBox(AText, ACaption: PAnsiChar);
3216 begin
3217 if (not ShowingMessageBox) and (not SuppressMessageBoxes) then
3218 begin
3219 ShowingMessageBox := True;
3220 MessageBoxA(0, AText, ACaption,
3221 MB_OK or MB_ICONERROR or MB_TASKMODAL or MB_DEFAULT_DESKTOP_ONLY);
3222 ShowingMessageBox := False;
3223 end;
3224 end;
3225
3226 {Returns the class for a memory block. Returns nil if it is not a valid class}
DetectClassInstancenull3227 function DetectClassInstance(APointer: Pointer): TClass;
3228 {$ifndef POSIX}
3229 var
3230 LMemInfo: TMemoryBasicInformation;
3231
3232 {Checks whether the given address is a valid address for a VMT entry.}
IsValidVMTAddressnull3233 function IsValidVMTAddress(APAddress: Pointer): Boolean;
3234 begin
3235 {Do some basic pointer checks: Must be dword aligned and beyond 64K}
3236 if (UIntPtr(APAddress) > 65535)
3237 and (UIntPtr(APAddress) and 3 = 0) then
3238 begin
3239 {Do we need to recheck the virtual memory?}
3240 if (UIntPtr(LMemInfo.BaseAddress) > UIntPtr(APAddress))
3241 or ((UIntPtr(LMemInfo.BaseAddress) + LMemInfo.RegionSize) < (UIntPtr(APAddress) + 4)) then
3242 begin
3243 {Get the VM status for the pointer}
3244 LMemInfo.RegionSize := 0;
3245 VirtualQuery(APAddress, LMemInfo, SizeOf(LMemInfo));
3246 end;
3247 {Check the readability of the memory address}
3248 Result := (LMemInfo.RegionSize >= 4)
3249 and (LMemInfo.State = MEM_COMMIT)
3250 and (LMemInfo.Protect and (PAGE_READONLY or PAGE_READWRITE or PAGE_EXECUTE or PAGE_EXECUTE_READ or PAGE_EXECUTE_READWRITE or PAGE_EXECUTE_WRITECOPY) <> 0)
3251 and (LMemInfo.Protect and PAGE_GUARD = 0);
3252 end
3253 else
3254 Result := False;
3255 end;
3256
3257 {Returns true if AClassPointer points to a class VMT}
InternalIsValidClassnull3258 function InternalIsValidClass(AClassPointer: Pointer; ADepth: Integer = 0): Boolean;
3259 var
3260 LParentClassSelfPointer: PPointer;
3261 begin
3262 {Check that the self pointer as well as parent class self pointer addresses
3263 are valid}
3264 if (ADepth < 1000)
3265 and IsValidVMTAddress(Pointer(PByte(AClassPointer) + vmtSelfPtr))
3266 and IsValidVMTAddress(Pointer(PByte(AClassPointer) + vmtParent)) then
3267 begin
3268 {Get a pointer to the parent class' self pointer}
3269 LParentClassSelfPointer := PPointer(PByte(AClassPointer) + vmtParent)^;
3270 {Check that the self pointer as well as the parent class is valid}
3271 Result := (PPointer(PByte(AClassPointer) + vmtSelfPtr)^ = AClassPointer)
3272 and ((LParentClassSelfPointer = nil)
3273 or (IsValidVMTAddress(LParentClassSelfPointer)
3274 and InternalIsValidClass(LParentClassSelfPointer^, ADepth + 1)));
3275 end
3276 else
3277 Result := False;
3278 end;
3279
3280 begin
3281 {Get the class pointer from the (suspected) object}
3282 Result := TClass(PPointer(APointer)^);
3283 {No VM info yet}
3284 LMemInfo.RegionSize := 0;
3285 {Check the block}
3286 if (not InternalIsValidClass(Pointer(Result), 0))
3287 {$ifdef FullDebugMode}
3288 or (Result = @FreedObjectVMT.VMTMethods[0])
3289 {$endif}
3290 then
3291 Result := nil;
3292 end;
3293 {$else}
3294 begin
3295 {Not currently supported under Linux / OS X}
3296 Result := nil;
3297 end;
3298 {$endif}
3299
3300 {Gets the available size inside a block}
GetAvailableSpaceInBlocknull3301 function GetAvailableSpaceInBlock(APointer: Pointer): NativeUInt;
3302 var
3303 LBlockHeader: NativeUInt;
3304 LPSmallBlockPool: PSmallBlockPoolHeader;
3305 begin
3306 LBlockHeader := PNativeUInt(PByte(APointer) - BlockHeaderSize)^;
3307 if LBlockHeader and (IsMediumBlockFlag or IsLargeBlockFlag) = 0 then
3308 begin
3309 LPSmallBlockPool := PSmallBlockPoolHeader(LBlockHeader and DropSmallFlagsMask);
3310 Result := LPSmallBlockPool.BlockType.BlockSize - BlockHeaderSize;
3311 end
3312 else
3313 begin
3314 Result := (LBlockHeader and DropMediumAndLargeFlagsMask) - BlockHeaderSize;
3315 if (LBlockHeader and IsMediumBlockFlag) = 0 then
3316 Dec(Result, LargeBlockHeaderSize);
3317 end;
3318 end;
3319
3320 {-----------------Small Block Management------------------}
3321
3322 {Locks all small block types}
3323 procedure LockAllSmallBlockTypes;
3324 var
3325 LInd: Cardinal;
3326 begin
3327 {Lock the medium blocks}
3328 {$ifndef AssumeMultiThreaded}
3329 if IsMultiThread then
3330 {$endif}
3331 begin
3332 for LInd := 0 to NumSmallBlockTypes - 1 do
3333 begin
3334 while LockCmpxchg(0, 1, @SmallBlockTypes[LInd].BlockTypeLocked) <> 0 do
3335 begin
3336 {$ifdef NeverSleepOnThreadContention}
3337 {$ifdef UseSwitchToThread}
3338 SwitchToThread;
3339 {$endif}
3340 {$else}
3341 Sleep(InitialSleepTime);
3342 if LockCmpxchg(0, 1, @SmallBlockTypes[LInd].BlockTypeLocked) = 0 then
3343 Break;
3344 Sleep(AdditionalSleepTime);
3345 {$endif}
3346 end;
3347 end;
3348 end;
3349 end;
3350
3351 {Gets the first and last block pointer for a small block pool}
3352 procedure GetFirstAndLastSmallBlockInPool(APSmallBlockPool: PSmallBlockPoolHeader;
3353 var AFirstPtr, ALastPtr: Pointer);
3354 var
3355 LBlockSize: NativeUInt;
3356 begin
3357 {Get the pointer to the first block}
3358 AFirstPtr := Pointer(PByte(APSmallBlockPool) + SmallBlockPoolHeaderSize);
3359 {Get a pointer to the last block}
3360 if (APSmallBlockPool.BlockType.CurrentSequentialFeedPool <> APSmallBlockPool)
3361 or (UIntPtr(APSmallBlockPool.BlockType.NextSequentialFeedBlockAddress) > UIntPtr(APSmallBlockPool.BlockType.MaxSequentialFeedBlockAddress)) then
3362 begin
3363 {Not the sequential feed - point to the end of the block}
3364 LBlockSize := PNativeUInt(PByte(APSmallBlockPool) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask;
3365 ALastPtr := Pointer(PByte(APSmallBlockPool) + LBlockSize - APSmallBlockPool.BlockType.BlockSize);
3366 end
3367 else
3368 begin
3369 {The sequential feed pool - point to before the next sequential feed block}
3370 ALastPtr := Pointer(PByte(APSmallBlockPool.BlockType.NextSequentialFeedBlockAddress) - 1);
3371 end;
3372 end;
3373
3374 {-----------------Medium Block Management------------------}
3375
3376 {Advances to the next medium block. Returns nil if the end of the medium block
3377 pool has been reached}
NextMediumBlocknull3378 function NextMediumBlock(APMediumBlock: Pointer): Pointer;
3379 var
3380 LBlockSize: NativeUInt;
3381 begin
3382 {Get the size of this block}
3383 LBlockSize := PNativeUInt(PByte(APMediumBlock) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask;
3384 {Advance the pointer}
3385 Result := Pointer(PByte(APMediumBlock) + LBlockSize);
3386 {Is the next block the end of medium pool marker?}
3387 LBlockSize := PNativeUInt(PByte(Result) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask;
3388 if LBlockSize = 0 then
3389 Result := nil;
3390 end;
3391
3392 {Gets the first medium block in the medium block pool}
GetFirstMediumBlockInPoolnull3393 function GetFirstMediumBlockInPool(APMediumBlockPoolHeader: PMediumBlockPoolHeader): Pointer;
3394 begin
3395 if (MediumSequentialFeedBytesLeft = 0)
3396 or (UIntPtr(LastSequentiallyFedMediumBlock) < UIntPtr(APMediumBlockPoolHeader))
3397 or (UIntPtr(LastSequentiallyFedMediumBlock) > UIntPtr(APMediumBlockPoolHeader) + MediumBlockPoolSize) then
3398 begin
3399 Result := Pointer(PByte(APMediumBlockPoolHeader) + MediumBlockPoolHeaderSize);
3400 end
3401 else
3402 begin
3403 {Is the sequential feed pool empty?}
3404 if MediumSequentialFeedBytesLeft <> MediumBlockPoolSize - MediumBlockPoolHeaderSize then
3405 Result := LastSequentiallyFedMediumBlock
3406 else
3407 Result := nil;
3408 end;
3409 end;
3410
3411 {Locks the medium blocks. Note that the 32-bit asm version is assumed to
3412 preserve all registers except eax.}
3413 {$ifndef Use32BitAsm}
3414 procedure LockMediumBlocks;
3415 begin
3416 {Lock the medium blocks}
3417 {$ifndef AssumeMultiThreaded}
3418 if IsMultiThread then
3419 {$endif}
3420 begin
3421 while LockCmpxchg(0, 1, @MediumBlocksLocked) <> 0 do
3422 begin
3423 {$ifdef NeverSleepOnThreadContention}
3424 {$ifdef UseSwitchToThread}
3425 SwitchToThread;
3426 {$endif}
3427 {$else}
3428 Sleep(InitialSleepTime);
3429 if LockCmpxchg(0, 1, @MediumBlocksLocked) = 0 then
3430 Break;
3431 Sleep(AdditionalSleepTime);
3432 {$endif}
3433 end;
3434 end;
3435 end;
3436 {$else}
3437 procedure LockMediumBlocks;
3438 asm
3439 {Note: This routine is assumed to preserve all registers except eax}
3440 @MediumBlockLockLoop:
3441 mov eax, $100
3442 {Attempt to lock the medium blocks}
3443 lock cmpxchg MediumBlocksLocked, ah
3444 je @Done
3445 {$ifdef NeverSleepOnThreadContention}
3446 {Pause instruction (improves performance on P4)}
3447 rep nop
3448 {$ifdef UseSwitchToThread}
3449 push ecx
3450 push edx
3451 call SwitchToThread
3452 pop edx
3453 pop ecx
3454 {$endif}
3455 {Try again}
3456 jmp @MediumBlockLockLoop
3457 {$else}
3458 {Couldn't lock the medium blocks - sleep and try again}
3459 push ecx
3460 push edx
3461 push InitialSleepTime
3462 call Sleep
3463 pop edx
3464 pop ecx
3465 {Try again}
3466 mov eax, $100
3467 {Attempt to grab the block type}
3468 lock cmpxchg MediumBlocksLocked, ah
3469 je @Done
3470 {Couldn't lock the medium blocks - sleep and try again}
3471 push ecx
3472 push edx
3473 push AdditionalSleepTime
3474 call Sleep
3475 pop edx
3476 pop ecx
3477 {Try again}
3478 jmp @MediumBlockLockLoop
3479 {$endif}
3480 @Done:
3481 end;
3482 {$endif}
3483
3484 {Removes a medium block from the circular linked list of free blocks.
3485 Does not change any header flags. Medium blocks should be locked
3486 before calling this procedure.}
3487 procedure RemoveMediumFreeBlock(APMediumFreeBlock: PMediumFreeBlock);
3488 {$ifndef ASMVersion}
3489 var
3490 LPreviousFreeBlock, LNextFreeBlock: PMediumFreeBlock;
3491 LBinNumber, LBinGroupNumber: Cardinal;
3492 begin
3493 {Get the current previous and next blocks}
3494 LNextFreeBlock := APMediumFreeBlock.NextFreeBlock;
3495 LPreviousFreeBlock := APMediumFreeBlock.PreviousFreeBlock;
3496 {Remove this block from the linked list}
3497 LPreviousFreeBlock.NextFreeBlock := LNextFreeBlock;
3498 LNextFreeBlock.PreviousFreeBlock := LPreviousFreeBlock;
3499 {Is this bin now empty? If the previous and next free block pointers are
3500 equal, they must point to the bin.}
3501 if LPreviousFreeBlock = LNextFreeBlock then
3502 begin
3503 {Get the bin number for this block size}
3504 LBinNumber := (UIntPtr(LNextFreeBlock) - UIntPtr(@MediumBlockBins)) div SizeOf(TMediumFreeBlock);
3505 LBinGroupNumber := LBinNumber div 32;
3506 {Flag this bin as empty}
3507 MediumBlockBinBitmaps[LBinGroupNumber] := MediumBlockBinBitmaps[LBinGroupNumber]
3508 and (not (1 shl (LBinNumber and 31)));
3509 {Is the group now entirely empty?}
3510 if MediumBlockBinBitmaps[LBinGroupNumber] = 0 then
3511 begin
3512 {Flag this group as empty}
3513 MediumBlockBinGroupBitmap := MediumBlockBinGroupBitmap
3514 and (not (1 shl LBinGroupNumber));
3515 end;
3516 end;
3517 end;
3518 {$else}
3519 {$ifdef 32Bit}
3520 asm
3521 {On entry: eax = APMediumFreeBlock}
3522 {Get the current previous and next blocks}
3523 mov ecx, TMediumFreeBlock[eax].NextFreeBlock
3524 mov edx, TMediumFreeBlock[eax].PreviousFreeBlock
3525 {Is this bin now empty? If the previous and next free block pointers are
3526 equal, they must point to the bin.}
3527 cmp ecx, edx
3528 {Remove this block from the linked list}
3529 mov TMediumFreeBlock[ecx].PreviousFreeBlock, edx
3530 mov TMediumFreeBlock[edx].NextFreeBlock, ecx
3531 {Is this bin now empty? If the previous and next free block pointers are
3532 equal, they must point to the bin.}
3533 je @BinIsNowEmpty
3534 @Done:
3535 ret
3536 {Align branch target}
3537 nop
3538 @BinIsNowEmpty:
3539 {Get the bin number for this block size in ecx}
3540 sub ecx, offset MediumBlockBins
3541 mov edx, ecx
3542 shr ecx, 3
3543 {Get the group number in edx}
3544 movzx edx, dh
3545 {Flag this bin as empty}
3546 mov eax, -2
3547 rol eax, cl
3548 and dword ptr [MediumBlockBinBitmaps + edx * 4], eax
3549 jnz @Done
3550 {Flag this group as empty}
3551 mov eax, -2
3552 mov ecx, edx
3553 rol eax, cl
3554 and MediumBlockBinGroupBitmap, eax
3555 end;
3556 {$else}
3557 asm
3558 {On entry: rcx = APMediumFreeBlock}
3559 mov rax, rcx
3560 {Get the current previous and next blocks}
3561 mov rcx, TMediumFreeBlock[rax].NextFreeBlock
3562 mov rdx, TMediumFreeBlock[rax].PreviousFreeBlock
3563 {Is this bin now empty? If the previous and next free block pointers are
3564 equal, they must point to the bin.}
3565 cmp rcx, rdx
3566 {Remove this block from the linked list}
3567 mov TMediumFreeBlock[rcx].PreviousFreeBlock, rdx
3568 mov TMediumFreeBlock[rdx].NextFreeBlock, rcx
3569 {Is this bin now empty? If the previous and next free block pointers are
3570 equal, they must point to the bin.}
3571 jne @Done
3572 {Get the bin number for this block size in rcx}
3573 lea r8, MediumBlockBins
3574 sub rcx, r8
3575 mov edx, ecx
3576 shr ecx, 4
3577 {Get the group number in edx}
3578 shr edx, 9
3579 {Flag this bin as empty}
3580 mov eax, -2
3581 rol eax, cl
3582 lea r8, MediumBlockBinBitmaps
3583 and dword ptr [r8 + rdx * 4], eax
3584 jnz @Done
3585 {Flag this group as empty}
3586 mov eax, -2
3587 mov ecx, edx
3588 rol eax, cl
3589 and MediumBlockBinGroupBitmap, eax
3590 @Done:
3591 end;
3592 {$endif}
3593 {$endif}
3594
3595 {Inserts a medium block into the appropriate medium block bin.}
3596 procedure InsertMediumBlockIntoBin(APMediumFreeBlock: PMediumFreeBlock; AMediumBlockSize: Cardinal);
3597 {$ifndef ASMVersion}
3598 var
3599 LBinNumber, LBinGroupNumber: Cardinal;
3600 LPBin, LPFirstFreeBlock: PMediumFreeBlock;
3601 begin
3602 {Get the bin number for this block size. Get the bin that holds blocks of at
3603 least this size.}
3604 LBinNumber := (AMediumBlockSize - MinimumMediumBlockSize) div MediumBlockGranularity;
3605 if LBinNumber >= MediumBlockBinCount then
3606 LBinNumber := MediumBlockBinCount - 1;
3607 {Get the bin}
3608 LPBin := @MediumBlockBins[LBinNumber];
3609 {Bins are LIFO, se we insert this block as the first free block in the bin}
3610 LPFirstFreeBlock := LPBin.NextFreeBlock;
3611 APMediumFreeBlock.PreviousFreeBlock := LPBin;
3612 APMediumFreeBlock.NextFreeBlock := LPFirstFreeBlock;
3613 LPFirstFreeBlock.PreviousFreeBlock := APMediumFreeBlock;
3614 LPBin.NextFreeBlock := APMediumFreeBlock;
3615 {Was this bin empty?}
3616 if LPFirstFreeBlock = LPBin then
3617 begin
3618 {Get the group number}
3619 LBinGroupNumber := LBinNumber div 32;
3620 {Flag this bin as used}
3621 MediumBlockBinBitmaps[LBinGroupNumber] := MediumBlockBinBitmaps[LBinGroupNumber]
3622 or (1 shl (LBinNumber and 31));
3623 {Flag the group as used}
3624 MediumBlockBinGroupBitmap := MediumBlockBinGroupBitmap
3625 or (1 shl LBinGroupNumber);
3626 end;
3627 end;
3628 {$else}
3629 {$ifdef 32Bit}
3630 asm
3631 {On entry: eax = APMediumFreeBlock, edx = AMediumBlockSize}
3632 {Get the bin number for this block size. Get the bin that holds blocks of at
3633 least this size.}
3634 sub edx, MinimumMediumBlockSize
3635 shr edx, 8
3636 {Validate the bin number}
3637 sub edx, MediumBlockBinCount - 1
3638 sbb ecx, ecx
3639 and edx, ecx
3640 add edx, MediumBlockBinCount - 1
3641 {Get the bin in ecx}
3642 lea ecx, [MediumBlockBins + edx * 8]
3643 {Bins are LIFO, se we insert this block as the first free block in the bin}
3644 mov edx, TMediumFreeBlock[ecx].NextFreeBlock
3645 {Was this bin empty?}
3646 cmp edx, ecx
3647 mov TMediumFreeBlock[eax].PreviousFreeBlock, ecx
3648 mov TMediumFreeBlock[eax].NextFreeBlock, edx
3649 mov TMediumFreeBlock[edx].PreviousFreeBlock, eax
3650 mov TMediumFreeBlock[ecx].NextFreeBlock, eax
3651 {Was this bin empty?}
3652 je @BinWasEmpty
3653 ret
3654 {Align branch target}
3655 nop
3656 nop
3657 @BinWasEmpty:
3658 {Get the bin number in ecx}
3659 sub ecx, offset MediumBlockBins
3660 mov edx, ecx
3661 shr ecx, 3
3662 {Get the group number in edx}
3663 movzx edx, dh
3664 {Flag this bin as not empty}
3665 mov eax, 1
3666 shl eax, cl
3667 or dword ptr [MediumBlockBinBitmaps + edx * 4], eax
3668 {Flag the group as not empty}
3669 mov eax, 1
3670 mov ecx, edx
3671 shl eax, cl
3672 or MediumBlockBinGroupBitmap, eax
3673 end;
3674 {$else}
3675 asm
3676 {On entry: rax = APMediumFreeBlock, edx = AMediumBlockSize}
3677 mov rax, rcx
3678 {Get the bin number for this block size. Get the bin that holds blocks of at
3679 least this size.}
3680 sub edx, MinimumMediumBlockSize
3681 shr edx, 8
3682 {Validate the bin number}
3683 sub edx, MediumBlockBinCount - 1
3684 sbb ecx, ecx
3685 and edx, ecx
3686 add edx, MediumBlockBinCount - 1
3687 mov r9, rdx
3688 {Get the bin address in rcx}
3689 lea rcx, MediumBlockBins
3690 shl edx, 4
3691 add rcx, rdx
3692 {Bins are LIFO, se we insert this block as the first free block in the bin}
3693 mov rdx, TMediumFreeBlock[rcx].NextFreeBlock
3694 {Was this bin empty?}
3695 cmp rdx, rcx
3696 mov TMediumFreeBlock[rax].PreviousFreeBlock, rcx
3697 mov TMediumFreeBlock[rax].NextFreeBlock, rdx
3698 mov TMediumFreeBlock[rdx].PreviousFreeBlock, rax
3699 mov TMediumFreeBlock[rcx].NextFreeBlock, rax
3700 {Was this bin empty?}
3701 jne @Done
3702 {Get the bin number in ecx}
3703 mov rcx, r9
3704 {Get the group number in edx}
3705 mov rdx, r9
3706 shr edx, 5
3707 {Flag this bin as not empty}
3708 mov eax, 1
3709 shl eax, cl
3710 lea r8, MediumBlockBinBitmaps
3711 or dword ptr [r8 + rdx * 4], eax
3712 {Flag the group as not empty}
3713 mov eax, 1
3714 mov ecx, edx
3715 shl eax, cl
3716 or MediumBlockBinGroupBitmap, eax
3717 @Done:
3718 end;
3719 {$endif}
3720 {$endif}
3721
3722 {Bins what remains in the current sequential feed medium block pool. Medium
3723 blocks must be locked.}
3724 procedure BinMediumSequentialFeedRemainder;
3725 {$ifndef ASMVersion}
3726 var
3727 LSequentialFeedFreeSize, LNextBlockSizeAndFlags: NativeUInt;
3728 LPRemainderBlock, LNextMediumBlock: Pointer;
3729 begin
3730 LSequentialFeedFreeSize := MediumSequentialFeedBytesLeft;
3731 if LSequentialFeedFreeSize > 0 then
3732 begin
3733 {Get the block after the open space}
3734 LNextMediumBlock := LastSequentiallyFedMediumBlock;
3735 LNextBlockSizeAndFlags := PNativeUInt(PByte(LNextMediumBlock) - BlockHeaderSize)^;
3736 {Point to the remainder}
3737 LPRemainderBlock := Pointer(PByte(LNextMediumBlock) - LSequentialFeedFreeSize);
3738 {$ifndef FullDebugMode}
3739 {Can the next block be combined with the remainder?}
3740 if (LNextBlockSizeAndFlags and IsFreeBlockFlag) <> 0 then
3741 begin
3742 {Increase the size of this block}
3743 Inc(LSequentialFeedFreeSize, LNextBlockSizeAndFlags and DropMediumAndLargeFlagsMask);
3744 {Remove the next block as well}
3745 if (LNextBlockSizeAndFlags and DropMediumAndLargeFlagsMask) >= MinimumMediumBlockSize then
3746 RemoveMediumFreeBlock(LNextMediumBlock);
3747 end
3748 else
3749 begin
3750 {$endif}
3751 {Set the "previous block is free" flag of the next block}
3752 PNativeUInt(PByte(LNextMediumBlock) - BlockHeaderSize)^ := LNextBlockSizeAndFlags or PreviousMediumBlockIsFreeFlag;
3753 {$ifndef FullDebugMode}
3754 end;
3755 {$endif}
3756 {Store the size of the block as well as the flags}
3757 PNativeUInt(PByte(LPRemainderBlock) - BlockHeaderSize)^ := LSequentialFeedFreeSize or IsMediumBlockFlag or IsFreeBlockFlag;
3758 {Store the trailing size marker}
3759 PNativeUInt(PByte(LPRemainderBlock) + LSequentialFeedFreeSize - BlockHeaderSize * 2)^ := LSequentialFeedFreeSize;
3760 {$ifdef FullDebugMode}
3761 {In full debug mode the sequential feed remainder will never be too small to
3762 fit a full debug header.}
3763 {Clear the user area of the block}
3764 DebugFillMem(Pointer(PByte(LPRemainderBlock) + SizeOf(TFullDebugBlockHeader) + SizeOf(NativeUInt))^,
3765 LSequentialFeedFreeSize - FullDebugBlockOverhead - SizeOf(NativeUInt),
3766 {$ifndef CatchUseOfFreedInterfaces}DebugFillPattern{$else}NativeUInt(@VMTBadInterface){$endif});
3767 {We need to set a valid debug header and footer in the remainder}
3768 PFullDebugBlockHeader(LPRemainderBlock).HeaderCheckSum := NativeUInt(LPRemainderBlock);
3769 PNativeUInt(PByte(LPRemainderBlock) + SizeOf(TFullDebugBlockHeader))^ := not NativeUInt(LPRemainderBlock);
3770 {$endif}
3771 {Bin this medium block}
3772 if LSequentialFeedFreeSize >= MinimumMediumBlockSize then
3773 InsertMediumBlockIntoBin(LPRemainderBlock, LSequentialFeedFreeSize);
3774 end;
3775 end;
3776 {$else}
3777 {$ifdef 32Bit}
3778 asm
3779 cmp MediumSequentialFeedBytesLeft, 0
3780 jne @MustBinMedium
3781 {Nothing to bin}
3782 ret
3783 {Align branch target}
3784 nop
3785 nop
3786 @MustBinMedium:
3787 {Get a pointer to the last sequentially allocated medium block}
3788 mov eax, LastSequentiallyFedMediumBlock
3789 {Is the block that was last fed sequentially free?}
3790 test byte ptr [eax - 4], IsFreeBlockFlag
3791 jnz @LastBlockFedIsFree
3792 {Set the "previous block is free" flag in the last block fed}
3793 or dword ptr [eax - 4], PreviousMediumBlockIsFreeFlag
3794 {Get the remainder in edx}
3795 mov edx, MediumSequentialFeedBytesLeft
3796 {Point eax to the start of the remainder}
3797 sub eax, edx
3798 @BinTheRemainder:
3799 {Status: eax = start of remainder, edx = size of remainder}
3800 {Store the size of the block as well as the flags}
3801 lea ecx, [edx + IsMediumBlockFlag + IsFreeBlockFlag]
3802 mov [eax - 4], ecx
3803 {Store the trailing size marker}
3804 mov [eax + edx - 8], edx
3805 {Bin this medium block}
3806 cmp edx, MinimumMediumBlockSize
3807 jnb InsertMediumBlockIntoBin
3808 ret
3809 {Align branch target}
3810 nop
3811 nop
3812 @LastBlockFedIsFree:
3813 {Drop the flags}
3814 mov edx, DropMediumAndLargeFlagsMask
3815 and edx, [eax - 4]
3816 {Free the last block fed}
3817 cmp edx, MinimumMediumBlockSize
3818 jb @DontRemoveLastFed
3819 {Last fed block is free - remove it from its size bin}
3820 call RemoveMediumFreeBlock
3821 {Re-read eax and edx}
3822 mov eax, LastSequentiallyFedMediumBlock
3823 mov edx, DropMediumAndLargeFlagsMask
3824 and edx, [eax - 4]
3825 @DontRemoveLastFed:
3826 {Get the number of bytes left in ecx}
3827 mov ecx, MediumSequentialFeedBytesLeft
3828 {Point eax to the start of the remainder}
3829 sub eax, ecx
3830 {edx = total size of the remainder}
3831 add edx, ecx
3832 jmp @BinTheRemainder
3833 @Done:
3834 end;
3835 {$else}
3836 asm
3837 .params 2
3838 xor eax, eax
3839 cmp MediumSequentialFeedBytesLeft, eax
3840 je @Done
3841 {Get a pointer to the last sequentially allocated medium block}
3842 mov rax, LastSequentiallyFedMediumBlock
3843 {Is the block that was last fed sequentially free?}
3844 test byte ptr [rax - BlockHeaderSize], IsFreeBlockFlag
3845 jnz @LastBlockFedIsFree
3846 {Set the "previous block is free" flag in the last block fed}
3847 or qword ptr [rax - BlockHeaderSize], PreviousMediumBlockIsFreeFlag
3848 {Get the remainder in edx}
3849 mov edx, MediumSequentialFeedBytesLeft
3850 {Point eax to the start of the remainder}
3851 sub rax, rdx
3852 @BinTheRemainder:
3853 {Status: rax = start of remainder, edx = size of remainder}
3854 {Store the size of the block as well as the flags}
3855 lea rcx, [rdx + IsMediumBlockFlag + IsFreeBlockFlag]
3856 mov [rax - BlockHeaderSize], rcx
3857 {Store the trailing size marker}
3858 mov [rax + rdx - 2 * BlockHeaderSize], rdx
3859 {Bin this medium block}
3860 cmp edx, MinimumMediumBlockSize
3861 jb @Done
3862 mov rcx, rax
3863 call InsertMediumBlockIntoBin
3864 jmp @Done
3865 @LastBlockFedIsFree:
3866 {Drop the flags}
3867 mov rdx, DropMediumAndLargeFlagsMask
3868 and rdx, [rax - BlockHeaderSize]
3869 {Free the last block fed}
3870 cmp edx, MinimumMediumBlockSize
3871 jb @DontRemoveLastFed
3872 {Last fed block is free - remove it from its size bin}
3873 mov rcx, rax
3874 call RemoveMediumFreeBlock
3875 {Re-read rax and rdx}
3876 mov rax, LastSequentiallyFedMediumBlock
3877 mov rdx, DropMediumAndLargeFlagsMask
3878 and rdx, [rax - BlockHeaderSize]
3879 @DontRemoveLastFed:
3880 {Get the number of bytes left in ecx}
3881 mov ecx, MediumSequentialFeedBytesLeft
3882 {Point rax to the start of the remainder}
3883 sub rax, rcx
3884 {edx = total size of the remainder}
3885 add edx, ecx
3886 jmp @BinTheRemainder
3887 @Done:
3888 end;
3889 {$endif}
3890 {$endif}
3891
3892 {Allocates a new sequential feed medium block pool and immediately splits off a
3893 block of the requested size. The block size must be a multiple of 16 and
3894 medium blocks must be locked.}
AllocNewSequentialFeedMediumPoolnull3895 function AllocNewSequentialFeedMediumPool(AFirstBlockSize: Cardinal): Pointer;
3896 var
3897 LOldFirstMediumBlockPool: PMediumBlockPoolHeader;
3898 LNewPool: Pointer;
3899 begin
3900 {Bin the current sequential feed remainder}
3901 BinMediumSequentialFeedRemainder;
3902 {Allocate a new sequential feed block pool}
3903 LNewPool := VirtualAlloc(nil, MediumBlockPoolSize,
3904 MEM_COMMIT{$ifdef AlwaysAllocateTopDown} or MEM_TOP_DOWN{$endif}, PAGE_READWRITE);
3905 if LNewPool <> nil then
3906 begin
3907 {Insert this block pool into the list of block pools}
3908 LOldFirstMediumBlockPool := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader;
3909 PMediumBlockPoolHeader(LNewPool).PreviousMediumBlockPoolHeader := @MediumBlockPoolsCircularList;
3910 MediumBlockPoolsCircularList.NextMediumBlockPoolHeader := LNewPool;
3911 PMediumBlockPoolHeader(LNewPool).NextMediumBlockPoolHeader := LOldFirstMediumBlockPool;
3912 LOldFirstMediumBlockPool.PreviousMediumBlockPoolHeader := LNewPool;
3913 {Store the sequential feed pool trailer}
3914 PNativeUInt(PByte(LNewPool) + MediumBlockPoolSize - BlockHeaderSize)^ := IsMediumBlockFlag;
3915 {Get the number of bytes still available}
3916 MediumSequentialFeedBytesLeft := (MediumBlockPoolSize - MediumBlockPoolHeaderSize) - AFirstBlockSize;
3917 {Get the result}
3918 Result := Pointer(PByte(LNewPool) + MediumBlockPoolSize - AFirstBlockSize);
3919 LastSequentiallyFedMediumBlock := Result;
3920 {Store the block header}
3921 PNativeUInt(PByte(Result) - BlockHeaderSize)^ := AFirstBlockSize or IsMediumBlockFlag;
3922 end
3923 else
3924 begin
3925 {Out of memory}
3926 MediumSequentialFeedBytesLeft := 0;
3927 Result := nil;
3928 end;
3929 end;
3930
3931 {-----------------Large Block Management------------------}
3932
3933 {Locks the large blocks}
3934 procedure LockLargeBlocks;
3935 begin
3936 {Lock the large blocks}
3937 {$ifndef AssumeMultiThreaded}
3938 if IsMultiThread then
3939 {$endif}
3940 begin
3941 while LockCmpxchg(0, 1, @LargeBlocksLocked) <> 0 do
3942 begin
3943 {$ifdef NeverSleepOnThreadContention}
3944 {$ifdef UseSwitchToThread}
3945 SwitchToThread;
3946 {$endif}
3947 {$else}
3948 Sleep(InitialSleepTime);
3949 if LockCmpxchg(0, 1, @LargeBlocksLocked) = 0 then
3950 Break;
3951 Sleep(AdditionalSleepTime);
3952 {$endif}
3953 end;
3954 end;
3955 end;
3956
3957 {Allocates a Large block of at least ASize (actual size may be larger to
3958 allow for alignment etc.). ASize must be the actual user requested size. This
3959 procedure will pad it to the appropriate page boundary and also add the space
3960 required by the header.}
AllocateLargeBlocknull3961 function AllocateLargeBlock(ASize: NativeUInt): Pointer;
3962 var
3963 LLargeUsedBlockSize: NativeUInt;
3964 LOldFirstLargeBlock: PLargeBlockHeader;
3965 begin
3966 {Pad the block size to include the header and granularity. We also add a
3967 SizeOf(Pointer) overhead so a huge block size is a multiple of 16 bytes less
3968 SizeOf(Pointer) (so we can use a single move function for reallocating all
3969 block types)}
3970 LLargeUsedBlockSize := (ASize + LargeBlockHeaderSize + LargeBlockGranularity - 1 + BlockHeaderSize)
3971 and -LargeBlockGranularity;
3972 {Get the Large block}
3973 Result := VirtualAlloc(nil, LLargeUsedBlockSize, MEM_COMMIT or MEM_TOP_DOWN,
3974 PAGE_READWRITE);
3975 {Set the Large block fields}
3976 if Result <> nil then
3977 begin
3978 {Set the large block size and flags}
3979 PLargeBlockHeader(Result).UserAllocatedSize := ASize;
3980 PLargeBlockHeader(Result).BlockSizeAndFlags := LLargeUsedBlockSize or IsLargeBlockFlag;
3981 {Insert the large block into the linked list of large blocks}
3982 LockLargeBlocks;
3983 LOldFirstLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader;
3984 PLargeBlockHeader(Result).PreviousLargeBlockHeader := @LargeBlocksCircularList;
3985 LargeBlocksCircularList.NextLargeBlockHeader := Result;
3986 PLargeBlockHeader(Result).NextLargeBlockHeader := LOldFirstLargeBlock;
3987 LOldFirstLargeBlock.PreviousLargeBlockHeader := Result;
3988 LargeBlocksLocked := False;
3989 {Add the size of the header}
3990 Inc(PByte(Result), LargeBlockHeaderSize);
3991 {$ifdef FullDebugMode}
3992 {Since large blocks are never reused, the user area is not initialized to
3993 the debug fill pattern, but the debug header and footer must be set.}
3994 PFullDebugBlockHeader(Result).HeaderCheckSum := NativeUInt(Result);
3995 PNativeUInt(PByte(Result) + SizeOf(TFullDebugBlockHeader))^ := not NativeUInt(Result);
3996 {$endif}
3997 end;
3998 end;
3999
4000 {Frees a large block, returning 0 on success, -1 otherwise}
FreeLargeBlocknull4001 function FreeLargeBlock(APointer: Pointer): Integer;
4002 var
4003 LPreviousLargeBlockHeader, LNextLargeBlockHeader: PLargeBlockHeader;
4004 {$ifndef POSIX}
4005 LRemainingSize: NativeUInt;
4006 LCurrentSegment: Pointer;
4007 LMemInfo: TMemoryBasicInformation;
4008 {$endif}
4009 begin
4010 {$ifdef ClearLargeBlocksBeforeReturningToOS}
4011 FillChar(APointer^,
4012 (PLargeBlockHeader(PByte(APointer) - LargeBlockHeaderSize).BlockSizeAndFlags
4013 and DropMediumAndLargeFlagsMask) - LargeBlockHeaderSize, 0);
4014 {$endif}
4015 {Point to the start of the large block}
4016 APointer := Pointer(PByte(APointer) - LargeBlockHeaderSize);
4017 {Get the previous and next large blocks}
4018 LockLargeBlocks;
4019 LPreviousLargeBlockHeader := PLargeBlockHeader(APointer).PreviousLargeBlockHeader;
4020 LNextLargeBlockHeader := PLargeBlockHeader(APointer).NextLargeBlockHeader;
4021 {$ifndef POSIX}
4022 {Is the large block segmented?}
4023 if PLargeBlockHeader(APointer).BlockSizeAndFlags and LargeBlockIsSegmented = 0 then
4024 begin
4025 {$endif}
4026 {Single segment large block: Try to free it}
4027 if VirtualFree(APointer, 0, MEM_RELEASE) then
4028 Result := 0
4029 else
4030 Result := -1;
4031 {$ifndef POSIX}
4032 end
4033 else
4034 begin
4035 {The large block is segmented - free all segments}
4036 LCurrentSegment := APointer;
4037 LRemainingSize := PLargeBlockHeader(APointer).BlockSizeAndFlags and DropMediumAndLargeFlagsMask;
4038 Result := 0;
4039 while True do
4040 begin
4041 {Get the size of the current segment}
4042 VirtualQuery(LCurrentSegment, LMemInfo, SizeOf(LMemInfo));
4043 {Free the segment}
4044 if not VirtualFree(LCurrentSegment, 0, MEM_RELEASE) then
4045 begin
4046 Result := -1;
4047 Break;
4048 end;
4049 {Done?}
4050 if NativeUInt(LMemInfo.RegionSize) >= LRemainingSize then
4051 Break;
4052 {Decrement the remaining size}
4053 Dec(LRemainingSize, NativeUInt(LMemInfo.RegionSize));
4054 Inc(PByte(LCurrentSegment), NativeUInt(LMemInfo.RegionSize));
4055 end;
4056 end;
4057 {$endif}
4058 {Success?}
4059 if Result = 0 then
4060 begin
4061 {Remove the large block from the linked list}
4062 LNextLargeBlockHeader.PreviousLargeBlockHeader := LPreviousLargeBlockHeader;
4063 LPreviousLargeBlockHeader.NextLargeBlockHeader := LNextLargeBlockHeader;
4064 end;
4065 {Unlock the large blocks}
4066 LargeBlocksLocked := False;
4067 end;
4068
4069 {$ifndef FullDebugMode}
4070 {Reallocates a large block to at least the requested size. Returns the new
4071 pointer, or nil on error}
ReallocateLargeBlocknull4072 function ReallocateLargeBlock(APointer: Pointer; ANewSize: NativeUInt): Pointer;
4073 var
4074 LOldAvailableSize, LBlockHeader, LOldUserSize, LMinimumUpsize,
4075 LNewAllocSize: NativeUInt;
4076 {$ifndef POSIX}
4077 LNewSegmentSize: NativeUInt;
4078 LNextSegmentPointer: Pointer;
4079 LMemInfo: TMemoryBasicInformation;
4080 {$endif}
4081 begin
4082 {Get the block header}
4083 LBlockHeader := PNativeUInt(PByte(APointer) - BlockHeaderSize)^;
4084 {Large block - size is (16 + 4) less than the allocated size}
4085 LOldAvailableSize := (LBlockHeader and DropMediumAndLargeFlagsMask) - (LargeBlockHeaderSize + BlockHeaderSize);
4086 {Is it an upsize or a downsize?}
4087 if ANewSize > LOldAvailableSize then
4088 begin
4089 {This pointer is being reallocated to a larger block and therefore it is
4090 logical to assume that it may be enlarged again. Since reallocations are
4091 expensive, there is a minimum upsize percentage to avoid unnecessary
4092 future move operations.}
4093 {Add 25% for large block upsizes}
4094 LMinimumUpsize := LOldAvailableSize + (LOldAvailableSize shr 2);
4095 if ANewSize < LMinimumUpsize then
4096 LNewAllocSize := LMinimumUpsize
4097 else
4098 LNewAllocSize := ANewSize;
4099 {$ifndef POSIX}
4100 {Can another large block segment be allocated directly after this segment,
4101 thus negating the need to move the data?}
4102 LNextSegmentPointer := Pointer(PByte(APointer) - LargeBlockHeaderSize + (LBlockHeader and DropMediumAndLargeFlagsMask));
4103 VirtualQuery(LNextSegmentPointer, LMemInfo, SizeOf(LMemInfo));
4104 if LMemInfo.State = MEM_FREE then
4105 begin
4106 {Round the region size to the previous 64K}
4107 LMemInfo.RegionSize := LMemInfo.RegionSize and -LargeBlockGranularity;
4108 {Enough space to grow in place?}
4109 if NativeUInt(LMemInfo.RegionSize) > (ANewSize - LOldAvailableSize) then
4110 begin
4111 {There is enough space after the block to extend it - determine by how
4112 much}
4113 LNewSegmentSize := (LNewAllocSize - LOldAvailableSize + LargeBlockGranularity - 1) and -LargeBlockGranularity;
4114 if LNewSegmentSize > LMemInfo.RegionSize then
4115 LNewSegmentSize := LMemInfo.RegionSize;
4116 {Attempy to reserve the address range (which will fail if another
4117 thread has just reserved it) and commit it immediately afterwards.}
4118 if (VirtualAlloc(LNextSegmentPointer, LNewSegmentSize, MEM_RESERVE, PAGE_READWRITE) <> nil)
4119 and (VirtualAlloc(LNextSegmentPointer, LNewSegmentSize, MEM_COMMIT, PAGE_READWRITE) <> nil) then
4120 begin
4121 {Update the requested size}
4122 PLargeBlockHeader(PByte(APointer) - LargeBlockHeaderSize).UserAllocatedSize := ANewSize;
4123 PLargeBlockHeader(PByte(APointer) - LargeBlockHeaderSize).BlockSizeAndFlags :=
4124 (PLargeBlockHeader(PByte(APointer) - LargeBlockHeaderSize).BlockSizeAndFlags + LNewSegmentSize)
4125 or LargeBlockIsSegmented;
4126 {Success}
4127 Result := APointer;
4128 Exit;
4129 end;
4130 end;
4131 end;
4132 {$endif}
4133 {Could not resize in place: Allocate the new block}
4134 Result := FastGetMem(LNewAllocSize);
4135 if Result <> nil then
4136 begin
4137 {If it's a large block - store the actual user requested size (it may
4138 not be if the block that is being reallocated from was previously
4139 downsized)}
4140 if LNewAllocSize > (MaximumMediumBlockSize - BlockHeaderSize) then
4141 PLargeBlockHeader(PByte(Result) - LargeBlockHeaderSize).UserAllocatedSize := ANewSize;
4142 {The user allocated size is stored for large blocks}
4143 LOldUserSize := PLargeBlockHeader(PByte(APointer) - LargeBlockHeaderSize).UserAllocatedSize;
4144 {The number of bytes to move is the old user size.}
4145 {$ifdef UseCustomVariableSizeMoveRoutines}
4146 MoveX16LP(APointer^, Result^, LOldUserSize);
4147 {$else}
4148 System.Move(APointer^, Result^, LOldUserSize);
4149 {$endif}
4150 {Free the old block}
4151 FastFreeMem(APointer);
4152 end;
4153 end
4154 else
4155 begin
4156 {It's a downsize: do we need to reallocate? Only if the new size is less
4157 than half the old size}
4158 if ANewSize >= (LOldAvailableSize shr 1) then
4159 begin
4160 {No need to reallocate}
4161 Result := APointer;
4162 {Update the requested size}
4163 PLargeBlockHeader(PByte(APointer) - LargeBlockHeaderSize).UserAllocatedSize := ANewSize;
4164 end
4165 else
4166 begin
4167 {The block is less than half the old size, and the current size is
4168 greater than the minimum block size allowing a downsize: reallocate}
4169 Result := FastGetMem(ANewSize);
4170 if Result <> nil then
4171 begin
4172 {Still a large block? -> Set the user size}
4173 if ANewSize > (MaximumMediumBlockSize - BlockHeaderSize) then
4174 PLargeBlockHeader(PByte(APointer) - LargeBlockHeaderSize).UserAllocatedSize := ANewSize;
4175 {Move the data across}
4176 {$ifdef UseCustomVariableSizeMoveRoutines}
4177 {$ifdef Align16Bytes}
4178 MoveX16LP(APointer^, Result^, ANewSize);
4179 {$else}
4180 MoveX8LP(APointer^, Result^, ANewSize);
4181 {$endif}
4182 {$else}
4183 System.Move(APointer^, Result^, ANewSize);
4184 {$endif}
4185 {Free the old block}
4186 FastFreeMem(APointer);
4187 end;
4188 end;
4189 end;
4190 end;
4191 {$endif}
4192
4193 {---------------------Replacement Memory Manager Interface---------------------}
4194
4195 {Replacement for SysGetMem}
4196
FastGetMemnull4197 function FastGetMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer;
4198 {$ifndef ASMVersion}
4199 var
4200 LMediumBlock{$ifndef FullDebugMode}, LNextFreeBlock, LSecondSplit{$endif}: PMediumFreeBlock;
4201 LNextMediumBlockHeader: PNativeUInt;
4202 LBlockSize, LAvailableBlockSize{$ifndef FullDebugMode}, LSecondSplitSize{$endif},
4203 LSequentialFeedFreeSize: NativeUInt;
4204 LPSmallBlockType: PSmallBlockType;
4205 LPSmallBlockPool, LPNewFirstPool: PSmallBlockPoolHeader;
4206 LNewFirstFreeBlock: Pointer;
4207 LPMediumBin: PMediumFreeBlock;
4208 LBinNumber, {$ifndef FullDebugMode}LBinGroupsMasked, {$endif}LBinGroupMasked,
4209 LBinGroupNumber: Cardinal;
4210 begin
4211 {Is it a small block? -> Take the header size into account when
4212 determining the required block size}
4213 if NativeUInt(ASize) <= (MaximumSmallBlockSize - BlockHeaderSize) then
4214 begin
4215 {-------------------------Allocate a small block---------------------------}
4216 {Get the block type from the size}
4217 LPSmallBlockType := PSmallBlockType(AllocSize2SmallBlockTypeIndX4[
4218 (NativeUInt(ASize) + (BlockHeaderSize - 1)) div SmallBlockGranularity]
4219 * (SizeOf(TSmallBlockType) div 4)
4220 + UIntPtr(@SmallBlockTypes));
4221 {Lock the block type}
4222 {$ifndef AssumeMultiThreaded}
4223 if IsMultiThread then
4224 {$endif}
4225 begin
4226 while True do
4227 begin
4228 {Try to lock the small block type}
4229 if LockCmpxchg(0, 1, @LPSmallBlockType.BlockTypeLocked) = 0 then
4230 Break;
4231 {Try the next block type}
4232 Inc(PByte(LPSmallBlockType), SizeOf(TSmallBlockType));
4233 if LockCmpxchg(0, 1, @LPSmallBlockType.BlockTypeLocked) = 0 then
4234 Break;
4235 {Try up to two sizes past the requested size}
4236 Inc(PByte(LPSmallBlockType), SizeOf(TSmallBlockType));
4237 if LockCmpxchg(0, 1, @LPSmallBlockType.BlockTypeLocked) = 0 then
4238 Break;
4239 {All three sizes locked - given up and sleep}
4240 Dec(PByte(LPSmallBlockType), 2 * SizeOf(TSmallBlockType));
4241 {$ifdef NeverSleepOnThreadContention}
4242 {$ifdef UseSwitchToThread}
4243 SwitchToThread;
4244 {$endif}
4245 {$else}
4246 {Both this block type and the next is in use: sleep}
4247 Sleep(InitialSleepTime);
4248 {Try the lock again}
4249 if LockCmpxchg(0, 1, @LPSmallBlockType.BlockTypeLocked) = 0 then
4250 Break;
4251 {Sleep longer}
4252 Sleep(AdditionalSleepTime);
4253 {$endif}
4254 end;
4255 end;
4256 {Get the first pool with free blocks}
4257 LPSmallBlockPool := LPSmallBlockType.NextPartiallyFreePool;
4258 {Is the pool valid?}
4259 if UIntPtr(LPSmallBlockPool) <> UIntPtr(LPSmallBlockType) then
4260 begin
4261 {Get the first free offset}
4262 Result := LPSmallBlockPool.FirstFreeBlock;
4263 {Get the new first free block}
4264 LNewFirstFreeBlock := PPointer(PByte(Result) - BlockHeaderSize)^;
4265 {$ifdef CheckHeapForCorruption}
4266 {The block should be free}
4267 if (NativeUInt(LNewFirstFreeBlock) and ExtractSmallFlagsMask) <> IsFreeBlockFlag then
4268 {$ifdef BCB6OrDelphi7AndUp}
4269 System.Error(reInvalidPtr);
4270 {$else}
4271 System.RunError(reInvalidPtr);
4272 {$endif}
4273 {$endif}
4274 LNewFirstFreeBlock := Pointer(UIntPtr(LNewFirstFreeBlock) and DropSmallFlagsMask);
4275 {Increment the number of used blocks}
4276 Inc(LPSmallBlockPool.BlocksInUse);
4277 {Set the new first free block}
4278 LPSmallBlockPool.FirstFreeBlock := LNewFirstFreeBlock;
4279 {Is the pool now full?}
4280 if LNewFirstFreeBlock = nil then
4281 begin
4282 {Pool is full - remove it from the partially free list}
4283 LPNewFirstPool := LPSmallBlockPool.NextPartiallyFreePool;
4284 LPSmallBlockType.NextPartiallyFreePool := LPNewFirstPool;
4285 LPNewFirstPool.PreviousPartiallyFreePool := PSmallBlockPoolHeader(LPSmallBlockType);
4286 end;
4287 end
4288 else
4289 begin
4290 {Try to feed a small block sequentially}
4291 Result := LPSmallBlockType.NextSequentialFeedBlockAddress;
4292 {Can another block fit?}
4293 if UIntPtr(Result) <= UIntPtr(LPSmallBlockType.MaxSequentialFeedBlockAddress) then
4294 begin
4295 {Get the sequential feed block pool}
4296 LPSmallBlockPool := LPSmallBlockType.CurrentSequentialFeedPool;
4297 {Increment the number of used blocks in the sequential feed pool}
4298 Inc(LPSmallBlockPool.BlocksInUse);
4299 {Store the next sequential feed block address}
4300 LPSmallBlockType.NextSequentialFeedBlockAddress := Pointer(PByte(Result) + LPSmallBlockType.BlockSize);
4301 end
4302 else
4303 begin
4304 {Need to allocate a pool: Lock the medium blocks}
4305 LockMediumBlocks;
4306 {$ifndef FullDebugMode}
4307 {Are there any available blocks of a suitable size?}
4308 LBinGroupsMasked := MediumBlockBinGroupBitmap and ($ffffff00 or LPSmallBlockType.AllowedGroupsForBlockPoolBitmap);
4309 if LBinGroupsMasked <> 0 then
4310 begin
4311 {Get the bin group with free blocks}
4312 LBinGroupNumber := FindFirstSetBit(LBinGroupsMasked);
4313 {Get the bin in the group with free blocks}
4314 LBinNumber := FindFirstSetBit(MediumBlockBinBitmaps[LBinGroupNumber])
4315 + LBinGroupNumber * 32;
4316 LPMediumBin := @MediumBlockBins[LBinNumber];
4317 {Get the first block in the bin}
4318 LMediumBlock := LPMediumBin.NextFreeBlock;
4319 {Remove the first block from the linked list (LIFO)}
4320 LNextFreeBlock := LMediumBlock.NextFreeBlock;
4321 LPMediumBin.NextFreeBlock := LNextFreeBlock;
4322 LNextFreeBlock.PreviousFreeBlock := LPMediumBin;
4323 {Is this bin now empty?}
4324 if LNextFreeBlock = LPMediumBin then
4325 begin
4326 {Flag this bin as empty}
4327 MediumBlockBinBitmaps[LBinGroupNumber] := MediumBlockBinBitmaps[LBinGroupNumber]
4328 and (not (1 shl (LBinNumber and 31)));
4329 {Is the group now entirely empty?}
4330 if MediumBlockBinBitmaps[LBinGroupNumber] = 0 then
4331 begin
4332 {Flag this group as empty}
4333 MediumBlockBinGroupBitmap := MediumBlockBinGroupBitmap
4334 and (not (1 shl LBinGroupNumber));
4335 end;
4336 end;
4337 {Get the size of the available medium block}
4338 LBlockSize := PNativeUInt(PByte(LMediumBlock) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask;
4339 {$ifdef CheckHeapForCorruption}
4340 {Check that this block is actually free and the next and previous blocks
4341 are both in use.}
4342 if ((PNativeUInt(PByte(LMediumBlock) - BlockHeaderSize)^ and ExtractMediumAndLargeFlagsMask) <> (IsMediumBlockFlag or IsFreeBlockFlag))
4343 or ((PNativeUInt(PByte(LMediumBlock) + (PNativeUInt(PByte(LMediumBlock) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask) - BlockHeaderSize)^ and IsFreeBlockFlag) <> 0)
4344 then
4345 begin
4346 {$ifdef BCB6OrDelphi7AndUp}
4347 System.Error(reInvalidPtr);
4348 {$else}
4349 System.RunError(reInvalidPtr);
4350 {$endif}
4351 end;
4352 {$endif}
4353 {Should the block be split?}
4354 if LBlockSize >= MaximumSmallBlockPoolSize then
4355 begin
4356 {Get the size of the second split}
4357 LSecondSplitSize := LBlockSize - LPSmallBlockType.OptimalBlockPoolSize;
4358 {Adjust the block size}
4359 LBlockSize := LPSmallBlockType.OptimalBlockPoolSize;
4360 {Split the block in two}
4361 LSecondSplit := PMediumFreeBlock(PByte(LMediumBlock) + LBlockSize);
4362 PNativeUInt(PByte(LSecondSplit) - BlockHeaderSize)^ := LSecondSplitSize or (IsMediumBlockFlag or IsFreeBlockFlag);
4363 {Store the size of the second split as the second last dword/qword}
4364 PNativeUInt(PByte(LSecondSplit) + LSecondSplitSize - 2 * BlockHeaderSize)^ := LSecondSplitSize;
4365 {Put the remainder in a bin (it will be big enough)}
4366 InsertMediumBlockIntoBin(LSecondSplit, LSecondSplitSize);
4367 end
4368 else
4369 begin
4370 {Mark this block as used in the block following it}
4371 LNextMediumBlockHeader := PNativeUInt(PByte(LMediumBlock) + LBlockSize - BlockHeaderSize);
4372 LNextMediumBlockHeader^ := LNextMediumBlockHeader^ and (not PreviousMediumBlockIsFreeFlag);
4373 end;
4374 end
4375 else
4376 begin
4377 {$endif}
4378 {Check the sequential feed medium block pool for space}
4379 LSequentialFeedFreeSize := MediumSequentialFeedBytesLeft;
4380 if LSequentialFeedFreeSize >= LPSmallBlockType.MinimumBlockPoolSize then
4381 begin
4382 {Enough sequential feed space: Will the remainder be usable?}
4383 if LSequentialFeedFreeSize >= (LPSmallBlockType.OptimalBlockPoolSize + MinimumMediumBlockSize) then
4384 begin
4385 LBlockSize := LPSmallBlockType.OptimalBlockPoolSize;
4386 end
4387 else
4388 LBlockSize := LSequentialFeedFreeSize;
4389 {Get the block}
4390 LMediumBlock := Pointer(PByte(LastSequentiallyFedMediumBlock) - LBlockSize);
4391 {Update the sequential feed parameters}
4392 LastSequentiallyFedMediumBlock := LMediumBlock;
4393 MediumSequentialFeedBytesLeft := LSequentialFeedFreeSize - LBlockSize;
4394 end
4395 else
4396 begin
4397 {Need to allocate a new sequential feed medium block pool: use the
4398 optimal size for this small block pool}
4399 LBlockSize := LPSmallBlockType.OptimalBlockPoolSize;
4400 {Allocate the medium block pool}
4401 LMediumBlock := AllocNewSequentialFeedMediumPool(LBlockSize);
4402 if LMediumBlock = nil then
4403 begin
4404 {Out of memory}
4405 {Unlock the medium blocks}
4406 MediumBlocksLocked := False;
4407 {Unlock the block type}
4408 LPSmallBlockType.BlockTypeLocked := False;
4409 {Failed}
4410 Result := nil;
4411 {done}
4412 Exit;
4413 end;
4414 end;
4415 {$ifndef FullDebugMode}
4416 end;
4417 {$endif}
4418 {Mark this block as in use}
4419 {Set the size and flags for this block}
4420 PNativeUInt(PByte(LMediumBlock) - BlockHeaderSize)^ := LBlockSize or IsMediumBlockFlag or IsSmallBlockPoolInUseFlag;
4421 {Unlock medium blocks}
4422 MediumBlocksLocked := False;
4423 {Set up the block pool}
4424 LPSmallBlockPool := PSmallBlockPoolHeader(LMediumBlock);
4425 LPSmallBlockPool.BlockType := LPSmallBlockType;
4426 LPSmallBlockPool.FirstFreeBlock := nil;
4427 LPSmallBlockPool.BlocksInUse := 1;
4428 {Set it up for sequential block serving}
4429 LPSmallBlockType.CurrentSequentialFeedPool := LPSmallBlockPool;
4430 Result := Pointer(PByte(LPSmallBlockPool) + SmallBlockPoolHeaderSize);
4431 LPSmallBlockType.NextSequentialFeedBlockAddress := Pointer(PByte(Result) + LPSmallBlockType.BlockSize);
4432 LPSmallBlockType.MaxSequentialFeedBlockAddress := Pointer(PByte(LPSmallBlockPool) + LBlockSize - LPSmallBlockType.BlockSize);
4433 end;
4434 {$ifdef FullDebugMode}
4435 {Clear the user area of the block}
4436 DebugFillMem(Pointer(PByte(Result) + (SizeOf(TFullDebugBlockHeader) + SizeOf(NativeUInt)))^,
4437 LPSmallBlockType.BlockSize - FullDebugBlockOverhead - SizeOf(NativeUInt),
4438 {$ifndef CatchUseOfFreedInterfaces}DebugFillPattern{$else}NativeUInt(@VMTBadInterface){$endif});
4439 {Block was fed sequentially - we need to set a valid debug header. Use
4440 the block address.}
4441 PFullDebugBlockHeader(Result).HeaderCheckSum := NativeUInt(Result);
4442 PNativeUInt(PByte(Result) + SizeOf(TFullDebugBlockHeader))^ := not NativeUInt(Result);
4443 {$endif}
4444 end;
4445 {Unlock the block type}
4446 LPSmallBlockType.BlockTypeLocked := False;
4447 {Set the block header}
4448 PNativeUInt(PByte(Result) - BlockHeaderSize)^ := UIntPtr(LPSmallBlockPool);
4449 end
4450 else
4451 begin
4452 {Medium block or Large block?}
4453 if NativeUInt(ASize) <= (MaximumMediumBlockSize - BlockHeaderSize) then
4454 begin
4455 {------------------------Allocate a medium block--------------------------}
4456 {Get the block size and bin number for this block size. Block sizes are
4457 rounded up to the next bin size.}
4458 LBlockSize := ((NativeUInt(ASize) + (MediumBlockGranularity - 1 + BlockHeaderSize - MediumBlockSizeOffset))
4459 and -MediumBlockGranularity) + MediumBlockSizeOffset;
4460 {Get the bin number}
4461 LBinNumber := (LBlockSize - MinimumMediumBlockSize) div MediumBlockGranularity;
4462 {Lock the medium blocks}
4463 LockMediumBlocks;
4464 {Calculate the bin group}
4465 LBinGroupNumber := LBinNumber div 32;
4466 {Is there a suitable block inside this group?}
4467 LBinGroupMasked := MediumBlockBinBitmaps[LBinGroupNumber] and -(1 shl (LBinNumber and 31));
4468 if LBinGroupMasked <> 0 then
4469 begin
4470 {Get the actual bin number}
4471 LBinNumber := FindFirstSetBit(LBinGroupMasked) + LBinGroupNumber * 32;
4472 end
4473 else
4474 begin
4475 {$ifndef FullDebugMode}
4476 {Try all groups greater than this group}
4477 LBinGroupsMasked := MediumBlockBinGroupBitmap and -(2 shl LBinGroupNumber);
4478 if LBinGroupsMasked <> 0 then
4479 begin
4480 {There is a suitable group with space: get the bin number}
4481 LBinGroupNumber := FindFirstSetBit(LBinGroupsMasked);
4482 {Get the bin in the group with free blocks}
4483 LBinNumber := FindFirstSetBit(MediumBlockBinBitmaps[LBinGroupNumber])
4484 + LBinGroupNumber * 32;
4485 end
4486 else
4487 begin
4488 {$endif}
4489 {There are no bins with a suitable block: Sequentially feed the required block}
4490 LSequentialFeedFreeSize := MediumSequentialFeedBytesLeft;
4491 if LSequentialFeedFreeSize >= LBlockSize then
4492 begin
4493 {$ifdef FullDebugMode}
4494 {In full debug mode a medium block must have enough bytes to fit
4495 all the debug info, so we must make sure there are no tiny medium
4496 blocks at the start of the pool.}
4497 if LSequentialFeedFreeSize - LBlockSize < (FullDebugBlockOverhead + BlockHeaderSize) then
4498 LBlockSize := LSequentialFeedFreeSize;
4499 {$endif}
4500 {Block can be fed sequentially}
4501 Result := Pointer(PByte(LastSequentiallyFedMediumBlock) - LBlockSize);
4502 {Store the last sequentially fed block}
4503 LastSequentiallyFedMediumBlock := Result;
4504 {Store the remaining bytes}
4505 MediumSequentialFeedBytesLeft := LSequentialFeedFreeSize - LBlockSize;
4506 {Set the flags for the block}
4507 PNativeUInt(PByte(Result) - BlockHeaderSize)^ := LBlockSize or IsMediumBlockFlag;
4508 end
4509 else
4510 begin
4511 {Need to allocate a new sequential feed block}
4512 Result := AllocNewSequentialFeedMediumPool(LBlockSize);
4513 end;
4514 {$ifdef FullDebugMode}
4515 {Block was fed sequentially - we need to set a valid debug header}
4516 if Result <> nil then
4517 begin
4518 PFullDebugBlockHeader(Result).HeaderCheckSum := NativeUInt(Result);
4519 PNativeUInt(PByte(Result) + SizeOf(TFullDebugBlockHeader))^ := not NativeUInt(Result);
4520 {Clear the user area of the block}
4521 DebugFillMem(Pointer(PByte(Result) + SizeOf(TFullDebugBlockHeader) + SizeOf(NativeUInt))^,
4522 LBlockSize - FullDebugBlockOverhead - SizeOf(NativeUInt),
4523 {$ifndef CatchUseOfFreedInterfaces}DebugFillPattern{$else}NativeUInt(@VMTBadInterface){$endif});
4524 end;
4525 {$endif}
4526 {Done}
4527 MediumBlocksLocked := False;
4528 Exit;
4529 {$ifndef FullDebugMode}
4530 end;
4531 {$endif}
4532 end;
4533 {If we get here we have a valid LBinGroupNumber and LBinNumber:
4534 Use the first block in the bin, splitting it if necessary}
4535 {Get a pointer to the bin}
4536 LPMediumBin := @MediumBlockBins[LBinNumber];
4537 {Get the result}
4538 Result := LPMediumBin.NextFreeBlock;
4539 {$ifdef CheckHeapForCorruption}
4540 {Check that this block is actually free and the next and previous blocks
4541 are both in use (except in full debug mode).}
4542 if ((PNativeUInt(PByte(Result) - BlockHeaderSize)^ and {$ifndef FullDebugMode}ExtractMediumAndLargeFlagsMask{$else}(IsMediumBlockFlag or IsFreeBlockFlag){$endif}) <> (IsFreeBlockFlag or IsMediumBlockFlag))
4543 {$ifndef FullDebugMode}
4544 or ((PNativeUInt(PByte(Result) + (PNativeUInt(PByte(Result) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask) - BlockHeaderSize)^ and (ExtractMediumAndLargeFlagsMask - IsSmallBlockPoolInUseFlag)) <> (IsMediumBlockFlag or PreviousMediumBlockIsFreeFlag))
4545 {$endif}
4546 then
4547 begin
4548 {$ifdef BCB6OrDelphi7AndUp}
4549 System.Error(reInvalidPtr);
4550 {$else}
4551 System.RunError(reInvalidPtr);
4552 {$endif}
4553 end;
4554 {$endif}
4555 {Remove the block from the bin containing it}
4556 RemoveMediumFreeBlock(Result);
4557 {Get the block size}
4558 LAvailableBlockSize := PNativeUInt(PByte(Result) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask;
4559 {$ifndef FullDebugMode}
4560 {Is it an exact fit or not?}
4561 LSecondSplitSize := LAvailableBlockSize - LBlockSize;
4562 if LSecondSplitSize <> 0 then
4563 begin
4564 {Split the block in two}
4565 LSecondSplit := PMediumFreeBlock(PByte(Result) + LBlockSize);
4566 {Set the size of the second split}
4567 PNativeUInt(PByte(LSecondSplit) - BlockHeaderSize)^ := LSecondSplitSize or (IsMediumBlockFlag or IsFreeBlockFlag);
4568 {Store the size of the second split}
4569 PNativeUInt(PByte(LSecondSplit) + LSecondSplitSize - 2 * BlockHeaderSize)^ := LSecondSplitSize;
4570 {Put the remainder in a bin if it is big enough}
4571 if LSecondSplitSize >= MinimumMediumBlockSize then
4572 InsertMediumBlockIntoBin(LSecondSplit, LSecondSplitSize);
4573 end
4574 else
4575 begin
4576 {$else}
4577 {In full debug mode blocks are never split or coalesced}
4578 LBlockSize := LAvailableBlockSize;
4579 {$endif}
4580 {Mark this block as used in the block following it}
4581 LNextMediumBlockHeader := Pointer(PByte(Result) + LBlockSize - BlockHeaderSize);
4582 {$ifndef FullDebugMode}
4583 {$ifdef CheckHeapForCorruption}
4584 {The next block must be in use}
4585 if (LNextMediumBlockHeader^ and (ExtractMediumAndLargeFlagsMask - IsSmallBlockPoolInUseFlag)) <> (IsMediumBlockFlag or PreviousMediumBlockIsFreeFlag) then
4586 {$ifdef BCB6OrDelphi7AndUp}
4587 System.Error(reInvalidPtr);
4588 {$else}
4589 System.RunError(reInvalidPtr);
4590 {$endif}
4591 {$endif}
4592 {$endif}
4593 LNextMediumBlockHeader^ :=
4594 LNextMediumBlockHeader^ and (not PreviousMediumBlockIsFreeFlag);
4595 {$ifndef FullDebugMode}
4596 end;
4597 {Set the size and flags for this block}
4598 PNativeUInt(PByte(Result) - BlockHeaderSize)^ := LBlockSize or IsMediumBlockFlag;
4599 {$else}
4600 {In full debug mode blocks are never split or coalesced}
4601 Dec(PNativeUInt(PByte(Result) - BlockHeaderSize)^, IsFreeBlockFlag);
4602 {$endif}
4603 {Unlock the medium blocks}
4604 MediumBlocksLocked := False;
4605 end
4606 else
4607 begin
4608 {Allocate a Large block}
4609 if ASize > 0 then
4610 Result := AllocateLargeBlock(ASize)
4611 else
4612 Result := nil;
4613 end;
4614 end;
4615 end;
4616 {$else}
4617 {$ifdef 32Bit}
4618 asm
4619 {On entry:
4620 eax = ASize}
4621 {Since most allocations are for small blocks, determine the small block type
4622 index so long}
4623 lea edx, [eax + BlockHeaderSize - 1]
4624 {$ifdef Align16Bytes}
4625 shr edx, 4
4626 {$else}
4627 shr edx, 3
4628 {$endif}
4629 {Is it a small block?}
4630 cmp eax, (MaximumSmallBlockSize - BlockHeaderSize)
4631 {Save ebx}
4632 push ebx
4633 {Get the IsMultiThread variable so long}
4634 {$ifndef AssumeMultiThreaded}
4635 mov cl, IsMultiThread
4636 {$endif}
4637 {Is it a small block?}
4638 ja @NotASmallBlock
4639 {Do we need to lock the block type?}
4640 {$ifndef AssumeMultiThreaded}
4641 test cl, cl
4642 {$endif}
4643 {Get the small block type in ebx}
4644 movzx eax, byte ptr [AllocSize2SmallBlockTypeIndX4 + edx]
4645 lea ebx, [SmallBlockTypes + eax * 8]
4646 {Do we need to lock the block type?}
4647 {$ifndef AssumeMultiThreaded}
4648 jnz @LockBlockTypeLoop
4649 {$else}
4650 jmp @LockBlockTypeLoop
4651 {Align branch target}
4652 nop
4653 nop
4654 {$endif}
4655 @GotLockOnSmallBlockType:
4656 {Find the next free block: Get the first pool with free blocks in edx}
4657 mov edx, TSmallBlockType[ebx].NextPartiallyFreePool
4658 {Get the first free block (or the next sequential feed address if edx = ebx)}
4659 mov eax, TSmallBlockPoolHeader[edx].FirstFreeBlock
4660 {Get the drop flags mask in ecx so long}
4661 mov ecx, DropSmallFlagsMask
4662 {Is there a pool with free blocks?}
4663 cmp edx, ebx
4664 je @TrySmallSequentialFeed
4665 {Increment the number of used blocks}
4666 add TSmallBlockPoolHeader[edx].BlocksInUse, 1
4667 {Get the new first free block}
4668 and ecx, [eax - 4]
4669 {Set the new first free block}
4670 mov TSmallBlockPoolHeader[edx].FirstFreeBlock, ecx
4671 {Set the block header}
4672 mov [eax - 4], edx
4673 {Is the chunk now full?}
4674 jz @RemoveSmallPool
4675 {Unlock the block type}
4676 mov TSmallBlockType[ebx].BlockTypeLocked, False
4677 {Restore ebx}
4678 pop ebx
4679 {All done}
4680 ret
4681 {Align branch target}
4682 {$ifndef AssumeMultiThreaded}
4683 nop
4684 nop
4685 {$endif}
4686 nop
4687 @TrySmallSequentialFeed:
4688 {Try to feed a small block sequentially: Get the sequential feed block pool}
4689 mov edx, TSmallBlockType[ebx].CurrentSequentialFeedPool
4690 {Get the next sequential feed address so long}
4691 movzx ecx, TSmallBlockType[ebx].BlockSize
4692 add ecx, eax
4693 {Can another block fit?}
4694 cmp eax, TSmallBlockType[ebx].MaxSequentialFeedBlockAddress
4695 ja @AllocateSmallBlockPool
4696 {Increment the number of used blocks in the sequential feed pool}
4697 add TSmallBlockPoolHeader[edx].BlocksInUse, 1
4698 {Store the next sequential feed block address}
4699 mov TSmallBlockType[ebx].NextSequentialFeedBlockAddress, ecx
4700 {Unlock the block type}
4701 mov TSmallBlockType[ebx].BlockTypeLocked, False
4702 {Set the block header}
4703 mov [eax - 4], edx
4704 {Restore ebx}
4705 pop ebx
4706 {All done}
4707 ret
4708 {Align branch target}
4709 nop
4710 nop
4711 nop
4712 @RemoveSmallPool:
4713 {Pool is full - remove it from the partially free list}
4714 mov ecx, TSmallBlockPoolHeader[edx].NextPartiallyFreePool
4715 mov TSmallBlockPoolHeader[ecx].PreviousPartiallyFreePool, ebx
4716 mov TSmallBlockType[ebx].NextPartiallyFreePool, ecx
4717 {Unlock the block type}
4718 mov TSmallBlockType[ebx].BlockTypeLocked, False
4719 {Restore ebx}
4720 pop ebx
4721 {All done}
4722 ret
4723 {Align branch target}
4724 nop
4725 nop
4726 @LockBlockTypeLoop:
4727 mov eax, $100
4728 {Attempt to grab the block type}
4729 lock cmpxchg TSmallBlockType([ebx]).BlockTypeLocked, ah
4730 je @GotLockOnSmallBlockType
4731 {Try the next size}
4732 add ebx, Type(TSmallBlockType)
4733 mov eax, $100
4734 lock cmpxchg TSmallBlockType([ebx]).BlockTypeLocked, ah
4735 je @GotLockOnSmallBlockType
4736 {Try the next size (up to two sizes larger)}
4737 add ebx, Type(TSmallBlockType)
4738 mov eax, $100
4739 lock cmpxchg TSmallBlockType([ebx]).BlockTypeLocked, ah
4740 je @GotLockOnSmallBlockType
4741 {Block type and two sizes larger are all locked - give up and sleep}
4742 sub ebx, 2 * Type(TSmallBlockType)
4743 {$ifdef NeverSleepOnThreadContention}
4744 {Pause instruction (improves performance on P4)}
4745 rep nop
4746 {$ifdef UseSwitchToThread}
4747 call SwitchToThread
4748 {$endif}
4749 {Try again}
4750 jmp @LockBlockTypeLoop
4751 {Align branch target}
4752 nop
4753 {$ifndef UseSwitchToThread}
4754 nop
4755 {$endif}
4756 {$else}
4757 {Couldn't grab the block type - sleep and try again}
4758 push InitialSleepTime
4759 call Sleep
4760 {Try again}
4761 mov eax, $100
4762 {Attempt to grab the block type}
4763 lock cmpxchg TSmallBlockType([ebx]).BlockTypeLocked, ah
4764 je @GotLockOnSmallBlockType
4765 {Couldn't grab the block type - sleep and try again}
4766 push AdditionalSleepTime
4767 call Sleep
4768 {Try again}
4769 jmp @LockBlockTypeLoop
4770 {Align branch target}
4771 nop
4772 nop
4773 nop
4774 {$endif}
4775 @AllocateSmallBlockPool:
4776 {save additional registers}
4777 push esi
4778 push edi
4779 {Do we need to lock the medium blocks?}
4780 {$ifndef AssumeMultiThreaded}
4781 cmp IsMultiThread, False
4782 je @MediumBlocksLockedForPool
4783 {$endif}
4784 call LockMediumBlocks
4785 @MediumBlocksLockedForPool:
4786 {Are there any available blocks of a suitable size?}
4787 movsx esi, TSmallBlockType[ebx].AllowedGroupsForBlockPoolBitmap
4788 and esi, MediumBlockBinGroupBitmap
4789 jz @NoSuitableMediumBlocks
4790 {Get the bin group number with free blocks in eax}
4791 bsf eax, esi
4792 {Get the bin number in ecx}
4793 lea esi, [eax * 8]
4794 mov ecx, dword ptr [MediumBlockBinBitmaps + eax * 4]
4795 bsf ecx, ecx
4796 lea ecx, [ecx + esi * 4]
4797 {Get a pointer to the bin in edi}
4798 lea edi, [MediumBlockBins + ecx * 8]
4799 {Get the free block in esi}
4800 mov esi, TMediumFreeBlock[edi].NextFreeBlock
4801 {Remove the first block from the linked list (LIFO)}
4802 mov edx, TMediumFreeBlock[esi].NextFreeBlock
4803 mov TMediumFreeBlock[edi].NextFreeBlock, edx
4804 mov TMediumFreeBlock[edx].PreviousFreeBlock, edi
4805 {Is this bin now empty?}
4806 cmp edi, edx
4807 jne @MediumBinNotEmpty
4808 {eax = bin group number, ecx = bin number, edi = @bin, esi = free block, ebx = block type}
4809 {Flag this bin as empty}
4810 mov edx, -2
4811 rol edx, cl
4812 and dword ptr [MediumBlockBinBitmaps + eax * 4], edx
4813 jnz @MediumBinNotEmpty
4814 {Flag the group as empty}
4815 btr MediumBlockBinGroupBitmap, eax
4816 @MediumBinNotEmpty:
4817 {esi = free block, ebx = block type}
4818 {Get the size of the available medium block in edi}
4819 mov edi, DropMediumAndLargeFlagsMask
4820 and edi, [esi - 4]
4821 cmp edi, MaximumSmallBlockPoolSize
4822 jb @UseWholeBlock
4823 {Split the block: get the size of the second part, new block size is the
4824 optimal size}
4825 mov edx, edi
4826 movzx edi, TSmallBlockType[ebx].OptimalBlockPoolSize
4827 sub edx, edi
4828 {Split the block in two}
4829 lea eax, [esi + edi]
4830 lea ecx, [edx + IsMediumBlockFlag + IsFreeBlockFlag]
4831 mov [eax - 4], ecx
4832 {Store the size of the second split as the second last dword}
4833 mov [eax + edx - 8], edx
4834 {Put the remainder in a bin (it will be big enough)}
4835 call InsertMediumBlockIntoBin
4836 jmp @GotMediumBlock
4837 {Align branch target}
4838 {$ifdef AssumeMultiThreaded}
4839 nop
4840 {$endif}
4841 @NoSuitableMediumBlocks:
4842 {Check the sequential feed medium block pool for space}
4843 movzx ecx, TSmallBlockType[ebx].MinimumBlockPoolSize
4844 mov edi, MediumSequentialFeedBytesLeft
4845 cmp edi, ecx
4846 jb @AllocateNewSequentialFeed
4847 {Get the address of the last block that was fed}
4848 mov esi, LastSequentiallyFedMediumBlock
4849 {Enough sequential feed space: Will the remainder be usable?}
4850 movzx ecx, TSmallBlockType[ebx].OptimalBlockPoolSize
4851 lea edx, [ecx + MinimumMediumBlockSize]
4852 cmp edi, edx
4853 jb @NotMuchSpace
4854 mov edi, ecx
4855 @NotMuchSpace:
4856 sub esi, edi
4857 {Update the sequential feed parameters}
4858 sub MediumSequentialFeedBytesLeft, edi
4859 mov LastSequentiallyFedMediumBlock, esi
4860 {Get the block pointer}
4861 jmp @GotMediumBlock
4862 {Align branch target}
4863 @AllocateNewSequentialFeed:
4864 {Need to allocate a new sequential feed medium block pool: use the
4865 optimal size for this small block pool}
4866 movzx eax, TSmallBlockType[ebx].OptimalBlockPoolSize
4867 mov edi, eax
4868 {Allocate the medium block pool}
4869 call AllocNewSequentialFeedMediumPool
4870 mov esi, eax
4871 test eax, eax
4872 jnz @GotMediumBlock
4873 mov MediumBlocksLocked, al
4874 mov TSmallBlockType[ebx].BlockTypeLocked, al
4875 pop edi
4876 pop esi
4877 pop ebx
4878 ret
4879 {Align branch target}
4880 @UseWholeBlock:
4881 {esi = free block, ebx = block type, edi = block size}
4882 {Mark this block as used in the block following it}
4883 and byte ptr [esi + edi - 4], not PreviousMediumBlockIsFreeFlag
4884 @GotMediumBlock:
4885 {esi = free block, ebx = block type, edi = block size}
4886 {Set the size and flags for this block}
4887 lea ecx, [edi + IsMediumBlockFlag + IsSmallBlockPoolInUseFlag]
4888 mov [esi - 4], ecx
4889 {Unlock medium blocks}
4890 xor eax, eax
4891 mov MediumBlocksLocked, al
4892 {Set up the block pool}
4893 mov TSmallBlockPoolHeader[esi].BlockType, ebx
4894 mov TSmallBlockPoolHeader[esi].FirstFreeBlock, eax
4895 mov TSmallBlockPoolHeader[esi].BlocksInUse, 1
4896 {Set it up for sequential block serving}
4897 mov TSmallBlockType[ebx].CurrentSequentialFeedPool, esi
4898 {Return the pointer to the first block}
4899 lea eax, [esi + SmallBlockPoolHeaderSize]
4900 movzx ecx, TSmallBlockType[ebx].BlockSize
4901 lea edx, [eax + ecx]
4902 mov TSmallBlockType[ebx].NextSequentialFeedBlockAddress, edx
4903 add edi, esi
4904 sub edi, ecx
4905 mov TSmallBlockType[ebx].MaxSequentialFeedBlockAddress, edi
4906 {Unlock the small block type}
4907 mov TSmallBlockType[ebx].BlockTypeLocked, False
4908 {Set the small block header}
4909 mov [eax - 4], esi
4910 {Restore registers}
4911 pop edi
4912 pop esi
4913 pop ebx
4914 {Done}
4915 ret
4916 {-------------------Medium block allocation-------------------}
4917 {Align branch target}
4918 nop
4919 @NotASmallBlock:
4920 cmp eax, (MaximumMediumBlockSize - BlockHeaderSize)
4921 ja @IsALargeBlockRequest
4922 {Get the bin size for this block size. Block sizes are
4923 rounded up to the next bin size.}
4924 lea ebx, [eax + MediumBlockGranularity - 1 + BlockHeaderSize - MediumBlockSizeOffset]
4925 and ebx, -MediumBlockGranularity
4926 add ebx, MediumBlockSizeOffset
4927 {Do we need to lock the medium blocks?}
4928 {$ifndef AssumeMultiThreaded}
4929 test cl, cl
4930 jz @MediumBlocksLocked
4931 {$endif}
4932 call LockMediumBlocks
4933 @MediumBlocksLocked:
4934 {Get the bin number in ecx and the group number in edx}
4935 lea edx, [ebx - MinimumMediumBlockSize]
4936 mov ecx, edx
4937 shr edx, 8 + 5
4938 shr ecx, 8
4939 {Is there a suitable block inside this group?}
4940 mov eax, -1
4941 shl eax, cl
4942 and eax, dword ptr [MediumBlockBinBitmaps + edx * 4]
4943 jz @GroupIsEmpty
4944 {Get the actual bin number}
4945 and ecx, -32
4946 bsf eax, eax
4947 or ecx, eax
4948 jmp @GotBinAndGroup
4949 {Align branch target}
4950 nop
4951 @GroupIsEmpty:
4952 {Try all groups greater than this group}
4953 mov eax, -2
4954 mov ecx, edx
4955 shl eax, cl
4956 and eax, MediumBlockBinGroupBitmap
4957 jz @TrySequentialFeedMedium
4958 {There is a suitable group with space: get the bin number}
4959 bsf edx, eax
4960 {Get the bin in the group with free blocks}
4961 mov eax, dword ptr [MediumBlockBinBitmaps + edx * 4]
4962 bsf ecx, eax
4963 mov eax, edx
4964 shl eax, 5
4965 or ecx, eax
4966 jmp @GotBinAndGroup
4967 {Align branch target}
4968 nop
4969 @TrySequentialFeedMedium:
4970 mov ecx, MediumSequentialFeedBytesLeft
4971 {Block can be fed sequentially?}
4972 sub ecx, ebx
4973 jc @AllocateNewSequentialFeedForMedium
4974 {Get the block address}
4975 mov eax, LastSequentiallyFedMediumBlock
4976 sub eax, ebx
4977 mov LastSequentiallyFedMediumBlock, eax
4978 {Store the remaining bytes}
4979 mov MediumSequentialFeedBytesLeft, ecx
4980 {Set the flags for the block}
4981 or ebx, IsMediumBlockFlag
4982 mov [eax - 4], ebx
4983 jmp @MediumBlockGetDone
4984 {Align branch target}
4985 @AllocateNewSequentialFeedForMedium:
4986 mov eax, ebx
4987 call AllocNewSequentialFeedMediumPool
4988 @MediumBlockGetDone:
4989 mov MediumBlocksLocked, False
4990 pop ebx
4991 ret
4992 {Align branch target}
4993 @GotBinAndGroup:
4994 {ebx = block size, ecx = bin number, edx = group number}
4995 push esi
4996 push edi
4997 {Get a pointer to the bin in edi}
4998 lea edi, [MediumBlockBins + ecx * 8]
4999 {Get the free block in esi}
5000 mov esi, TMediumFreeBlock[edi].NextFreeBlock
5001 {Remove the first block from the linked list (LIFO)}
5002 mov eax, TMediumFreeBlock[esi].NextFreeBlock
5003 mov TMediumFreeBlock[edi].NextFreeBlock, eax
5004 mov TMediumFreeBlock[eax].PreviousFreeBlock, edi
5005 {Is this bin now empty?}
5006 cmp edi, eax
5007 jne @MediumBinNotEmptyForMedium
5008 {eax = bin group number, ecx = bin number, edi = @bin, esi = free block, ebx = block size}
5009 {Flag this bin as empty}
5010 mov eax, -2
5011 rol eax, cl
5012 and dword ptr [MediumBlockBinBitmaps + edx * 4], eax
5013 jnz @MediumBinNotEmptyForMedium
5014 {Flag the group as empty}
5015 btr MediumBlockBinGroupBitmap, edx
5016 @MediumBinNotEmptyForMedium:
5017 {esi = free block, ebx = block size}
5018 {Get the size of the available medium block in edi}
5019 mov edi, DropMediumAndLargeFlagsMask
5020 and edi, [esi - 4]
5021 {Get the size of the second split in edx}
5022 mov edx, edi
5023 sub edx, ebx
5024 jz @UseWholeBlockForMedium
5025 {Split the block in two}
5026 lea eax, [esi + ebx]
5027 lea ecx, [edx + IsMediumBlockFlag + IsFreeBlockFlag]
5028 mov [eax - 4], ecx
5029 {Store the size of the second split as the second last dword}
5030 mov [eax + edx - 8], edx
5031 {Put the remainder in a bin}
5032 cmp edx, MinimumMediumBlockSize
5033 jb @GotMediumBlockForMedium
5034 call InsertMediumBlockIntoBin
5035 jmp @GotMediumBlockForMedium
5036 {Align branch target}
5037 nop
5038 nop
5039 nop
5040 @UseWholeBlockForMedium:
5041 {Mark this block as used in the block following it}
5042 and byte ptr [esi + edi - 4], not PreviousMediumBlockIsFreeFlag
5043 @GotMediumBlockForMedium:
5044 {Set the size and flags for this block}
5045 lea ecx, [ebx + IsMediumBlockFlag]
5046 mov [esi - 4], ecx
5047 {Unlock medium blocks}
5048 mov MediumBlocksLocked, False
5049 mov eax, esi
5050 pop edi
5051 pop esi
5052 pop ebx
5053 ret
5054 {-------------------Large block allocation-------------------}
5055 {Align branch target}
5056 @IsALargeBlockRequest:
5057 pop ebx
5058 test eax, eax
5059 jns AllocateLargeBlock
5060 xor eax, eax
5061 end;
5062 {$else}
5063 {64-bit BASM implementation}
5064 asm
5065 {On entry:
5066 rcx = ASize}
5067 .params 2
5068 .pushnv rbx
5069 .pushnv rsi
5070 .pushnv rdi
5071 {Since most allocations are for small blocks, determine the small block type
5072 index so long}
5073 lea edx, [ecx + BlockHeaderSize - 1]
5074 {$ifdef Align16Bytes}
5075 shr edx, 4
5076 {$else}
5077 shr edx, 3
5078 {$endif}
5079 {Preload the addresses of some small block structures}
5080 lea r8, AllocSize2SmallBlockTypeIndX4
5081 lea rbx, SmallBlockTypes
5082 {$ifndef AssumeMultiThreaded}
5083 {Get the IsMultiThread variable so long}
5084 movzx esi, IsMultiThread
5085 {$endif}
5086 {Is it a small block?}
5087 cmp rcx, (MaximumSmallBlockSize - BlockHeaderSize)
5088 ja @NotASmallBlock
5089 {Get the small block type pointer in rbx}
5090 movzx ecx, byte ptr [r8 + rdx]
5091 shl ecx, 4 //SizeOf(TSmallBlockType) = 64
5092 add rbx, rcx
5093 {Do we need to lock the block type?}
5094 {$ifndef AssumeMultiThreaded}
5095 test esi, esi
5096 jnz @LockBlockTypeLoop
5097 {$else}
5098 jmp @LockBlockTypeLoop
5099 {$endif}
5100 @GotLockOnSmallBlockType:
5101 {Find the next free block: Get the first pool with free blocks in rdx}
5102 mov rdx, TSmallBlockType[rbx].NextPartiallyFreePool
5103 {Get the first free block (or the next sequential feed address if rdx = rbx)}
5104 mov rax, TSmallBlockPoolHeader[rdx].FirstFreeBlock
5105 {Get the drop flags mask in rcx so long}
5106 mov rcx, DropSmallFlagsMask
5107 {Is there a pool with free blocks?}
5108 cmp rdx, rbx
5109 je @TrySmallSequentialFeed
5110 {Increment the number of used blocks}
5111 add TSmallBlockPoolHeader[rdx].BlocksInUse, 1
5112 {Get the new first free block}
5113 and rcx, [rax - BlockHeaderSize]
5114 {Set the new first free block}
5115 mov TSmallBlockPoolHeader[rdx].FirstFreeBlock, rcx
5116 {Set the block header}
5117 mov [rax - BlockHeaderSize], rdx
5118 {Is the chunk now full?}
5119 jz @RemoveSmallPool
5120 {Unlock the block type}
5121 mov TSmallBlockType[rbx].BlockTypeLocked, False
5122 jmp @Done
5123 @TrySmallSequentialFeed:
5124 {Try to feed a small block sequentially: Get the sequential feed block pool}
5125 mov rdx, TSmallBlockType[rbx].CurrentSequentialFeedPool
5126 {Get the next sequential feed address so long}
5127 movzx ecx, TSmallBlockType[rbx].BlockSize
5128 add rcx, rax
5129 {Can another block fit?}
5130 cmp rax, TSmallBlockType[rbx].MaxSequentialFeedBlockAddress
5131 ja @AllocateSmallBlockPool
5132 {Increment the number of used blocks in the sequential feed pool}
5133 add TSmallBlockPoolHeader[rdx].BlocksInUse, 1
5134 {Store the next sequential feed block address}
5135 mov TSmallBlockType[rbx].NextSequentialFeedBlockAddress, rcx
5136 {Unlock the block type}
5137 mov TSmallBlockType[rbx].BlockTypeLocked, False
5138 {Set the block header}
5139 mov [rax - BlockHeaderSize], rdx
5140 jmp @Done
5141 @RemoveSmallPool:
5142 {Pool is full - remove it from the partially free list}
5143 mov rcx, TSmallBlockPoolHeader[rdx].NextPartiallyFreePool
5144 mov TSmallBlockPoolHeader[rcx].PreviousPartiallyFreePool, rbx
5145 mov TSmallBlockType[rbx].NextPartiallyFreePool, rcx
5146 {Unlock the block type}
5147 mov TSmallBlockType[rbx].BlockTypeLocked, False
5148 jmp @Done
5149 @LockBlockTypeLoop:
5150 mov eax, $100
5151 {Attempt to grab the block type}
5152 lock cmpxchg TSmallBlockType([rbx]).BlockTypeLocked, ah
5153 je @GotLockOnSmallBlockType
5154 {Try the next size}
5155 add rbx, Type(TSmallBlockType)
5156 mov eax, $100
5157 lock cmpxchg TSmallBlockType([rbx]).BlockTypeLocked, ah
5158 je @GotLockOnSmallBlockType
5159 {Try the next size (up to two sizes larger)}
5160 add rbx, Type(TSmallBlockType)
5161 mov eax, $100
5162 lock cmpxchg TSmallBlockType([rbx]).BlockTypeLocked, ah
5163 je @GotLockOnSmallBlockType
5164 {Block type and two sizes larger are all locked - give up and sleep}
5165 sub rbx, 2 * Type(TSmallBlockType)
5166 {$ifdef NeverSleepOnThreadContention}
5167 {Pause instruction (improves performance on P4)}
5168 pause
5169 {$ifdef UseSwitchToThread}
5170 call SwitchToThread
5171 {$endif}
5172 {Try again}
5173 jmp @LockBlockTypeLoop
5174 {$else}
5175 {Couldn't grab the block type - sleep and try again}
5176 mov ecx, InitialSleepTime
5177 call Sleep
5178 {Try again}
5179 mov eax, $100
5180 {Attempt to grab the block type}
5181 lock cmpxchg TSmallBlockType([rbx]).BlockTypeLocked, ah
5182 je @GotLockOnSmallBlockType
5183 {Couldn't grab the block type - sleep and try again}
5184 mov ecx, AdditionalSleepTime
5185 call Sleep
5186 {Try again}
5187 jmp @LockBlockTypeLoop
5188 {$endif}
5189 @AllocateSmallBlockPool:
5190 {Do we need to lock the medium blocks?}
5191 {$ifndef AssumeMultiThreaded}
5192 test esi, esi
5193 jz @MediumBlocksLockedForPool
5194 {$endif}
5195 call LockMediumBlocks
5196 @MediumBlocksLockedForPool:
5197 {Are there any available blocks of a suitable size?}
5198 movsx esi, TSmallBlockType[rbx].AllowedGroupsForBlockPoolBitmap
5199 and esi, MediumBlockBinGroupBitmap
5200 jz @NoSuitableMediumBlocks
5201 {Get the bin group number with free blocks in eax}
5202 bsf eax, esi
5203 {Get the bin number in ecx}
5204 lea r8, MediumBlockBinBitmaps
5205 lea r9, [rax * 4]
5206 mov ecx, [r8 + r9]
5207 bsf ecx, ecx
5208 lea ecx, [ecx + r9d * 8]
5209 {Get a pointer to the bin in edi}
5210 lea rdi, MediumBlockBins
5211 lea esi, [ecx * 8]
5212 lea rdi, [rdi + rsi * 2] //SizeOf(TMediumBlockBin) = 16
5213 {Get the free block in rsi}
5214 mov rsi, TMediumFreeBlock[rdi].NextFreeBlock
5215 {Remove the first block from the linked list (LIFO)}
5216 mov rdx, TMediumFreeBlock[rsi].NextFreeBlock
5217 mov TMediumFreeBlock[rdi].NextFreeBlock, rdx
5218 mov TMediumFreeBlock[rdx].PreviousFreeBlock, rdi
5219 {Is this bin now empty?}
5220 cmp rdi, rdx
5221 jne @MediumBinNotEmpty
5222 {r8 = @MediumBlockBinBitmaps, eax = bin group number,
5223 r9 = bin group number * 4, ecx = bin number, edi = @bin, esi = free block,
5224 ebx = block type}
5225 {Flag this bin as empty}
5226 mov edx, -2
5227 rol edx, cl
5228 and [r8 + r9], edx
5229 jnz @MediumBinNotEmpty
5230 {Flag the group as empty}
5231 btr MediumBlockBinGroupBitmap, eax
5232 @MediumBinNotEmpty:
5233 {esi = free block, ebx = block type}
5234 {Get the size of the available medium block in edi}
5235 mov rdi, DropMediumAndLargeFlagsMask
5236 and rdi, [rsi - BlockHeaderSize]
5237 cmp edi, MaximumSmallBlockPoolSize
5238 jb @UseWholeBlock
5239 {Split the block: get the size of the second part, new block size is the
5240 optimal size}
5241 mov edx, edi
5242 movzx edi, TSmallBlockType[rbx].OptimalBlockPoolSize
5243 sub edx, edi
5244 {Split the block in two}
5245 lea rcx, [rsi + rdi]
5246 lea rax, [rdx + IsMediumBlockFlag + IsFreeBlockFlag]
5247 mov [rcx - BlockHeaderSize], rax
5248 {Store the size of the second split as the second last qword}
5249 mov [rcx + rdx - BlockHeaderSize * 2], rdx
5250 {Put the remainder in a bin (it will be big enough)}
5251 call InsertMediumBlockIntoBin
5252 jmp @GotMediumBlock
5253 @NoSuitableMediumBlocks:
5254 {Check the sequential feed medium block pool for space}
5255 movzx ecx, TSmallBlockType[rbx].MinimumBlockPoolSize
5256 mov edi, MediumSequentialFeedBytesLeft
5257 cmp edi, ecx
5258 jb @AllocateNewSequentialFeed
5259 {Get the address of the last block that was fed}
5260 mov rsi, LastSequentiallyFedMediumBlock
5261 {Enough sequential feed space: Will the remainder be usable?}
5262 movzx ecx, TSmallBlockType[rbx].OptimalBlockPoolSize
5263 lea edx, [ecx + MinimumMediumBlockSize]
5264 cmp edi, edx
5265 jb @NotMuchSpace
5266 mov edi, ecx
5267 @NotMuchSpace:
5268 sub rsi, rdi
5269 {Update the sequential feed parameters}
5270 sub MediumSequentialFeedBytesLeft, edi
5271 mov LastSequentiallyFedMediumBlock, rsi
5272 {Get the block pointer}
5273 jmp @GotMediumBlock
5274 {Align branch target}
5275 @AllocateNewSequentialFeed:
5276 {Need to allocate a new sequential feed medium block pool: use the
5277 optimal size for this small block pool}
5278 movzx ecx, TSmallBlockType[rbx].OptimalBlockPoolSize
5279 mov edi, ecx
5280 {Allocate the medium block pool}
5281 call AllocNewSequentialFeedMediumPool
5282 mov rsi, rax
5283 test rax, rax
5284 jnz @GotMediumBlock
5285 mov MediumBlocksLocked, al
5286 mov TSmallBlockType[rbx].BlockTypeLocked, al
5287 jmp @Done
5288 @UseWholeBlock:
5289 {rsi = free block, rbx = block type, edi = block size}
5290 {Mark this block as used in the block following it}
5291 and byte ptr [rsi + rdi - BlockHeaderSize], not PreviousMediumBlockIsFreeFlag
5292 @GotMediumBlock:
5293 {rsi = free block, rbx = block type, edi = block size}
5294 {Set the size and flags for this block}
5295 lea ecx, [edi + IsMediumBlockFlag + IsSmallBlockPoolInUseFlag]
5296 mov [rsi - BlockHeaderSize], rcx
5297 {Unlock medium blocks}
5298 xor eax, eax
5299 mov MediumBlocksLocked, al
5300 {Set up the block pool}
5301 mov TSmallBlockPoolHeader[rsi].BlockType, rbx
5302 mov TSmallBlockPoolHeader[rsi].FirstFreeBlock, rax
5303 mov TSmallBlockPoolHeader[rsi].BlocksInUse, 1
5304 {Set it up for sequential block serving}
5305 mov TSmallBlockType[rbx].CurrentSequentialFeedPool, rsi
5306 {Return the pointer to the first block}
5307 lea rax, [rsi + SmallBlockPoolHeaderSize]
5308 movzx ecx, TSmallBlockType[rbx].BlockSize
5309 lea rdx, [rax + rcx]
5310 mov TSmallBlockType[rbx].NextSequentialFeedBlockAddress, rdx
5311 add rdi, rsi
5312 sub rdi, rcx
5313 mov TSmallBlockType[rbx].MaxSequentialFeedBlockAddress, rdi
5314 {Unlock the small block type}
5315 mov TSmallBlockType[rbx].BlockTypeLocked, False
5316 {Set the small block header}
5317 mov [rax - BlockHeaderSize], rsi
5318 jmp @Done
5319 {-------------------Medium block allocation-------------------}
5320 @NotASmallBlock:
5321 cmp rcx, (MaximumMediumBlockSize - BlockHeaderSize)
5322 ja @IsALargeBlockRequest
5323 {Get the bin size for this block size. Block sizes are
5324 rounded up to the next bin size.}
5325 lea ebx, [ecx + MediumBlockGranularity - 1 + BlockHeaderSize - MediumBlockSizeOffset]
5326 and ebx, -MediumBlockGranularity
5327 add ebx, MediumBlockSizeOffset
5328 {Do we need to lock the medium blocks?}
5329 {$ifndef AssumeMultiThreaded}
5330 test esi, esi
5331 jz @MediumBlocksLocked
5332 {$endif}
5333 call LockMediumBlocks
5334 @MediumBlocksLocked:
5335 {Get the bin number in ecx and the group number in edx}
5336 lea edx, [ebx - MinimumMediumBlockSize]
5337 mov ecx, edx
5338 shr edx, 8 + 5
5339 shr ecx, 8
5340 {Is there a suitable block inside this group?}
5341 mov eax, -1
5342 shl eax, cl
5343 lea r8, MediumBlockBinBitmaps
5344 and eax, [r8 + rdx * 4]
5345 jz @GroupIsEmpty
5346 {Get the actual bin number}
5347 and ecx, -32
5348 bsf eax, eax
5349 or ecx, eax
5350 jmp @GotBinAndGroup
5351 @GroupIsEmpty:
5352 {Try all groups greater than this group}
5353 mov eax, -2
5354 mov ecx, edx
5355 shl eax, cl
5356 and eax, MediumBlockBinGroupBitmap
5357 jz @TrySequentialFeedMedium
5358 {There is a suitable group with space: get the bin number}
5359 bsf edx, eax
5360 {Get the bin in the group with free blocks}
5361 mov eax, [r8 + rdx * 4]
5362 bsf ecx, eax
5363 mov eax, edx
5364 shl eax, 5
5365 or ecx, eax
5366 jmp @GotBinAndGroup
5367 @TrySequentialFeedMedium:
5368 mov ecx, MediumSequentialFeedBytesLeft
5369 {Block can be fed sequentially?}
5370 sub ecx, ebx
5371 jc @AllocateNewSequentialFeedForMedium
5372 {Get the block address}
5373 mov rax, LastSequentiallyFedMediumBlock
5374 sub rax, rbx
5375 mov LastSequentiallyFedMediumBlock, rax
5376 {Store the remaining bytes}
5377 mov MediumSequentialFeedBytesLeft, ecx
5378 {Set the flags for the block}
5379 or rbx, IsMediumBlockFlag
5380 mov [rax - BlockHeaderSize], rbx
5381 jmp @MediumBlockGetDone
5382 @AllocateNewSequentialFeedForMedium:
5383 mov ecx, ebx
5384 call AllocNewSequentialFeedMediumPool
5385 @MediumBlockGetDone:
5386 xor cl, cl
5387 mov MediumBlocksLocked, cl //workaround for QC99023
5388 jmp @Done
5389 @GotBinAndGroup:
5390 {ebx = block size, ecx = bin number, edx = group number}
5391 {Get a pointer to the bin in edi}
5392 lea rdi, MediumBlockBins
5393 lea eax, [ecx + ecx]
5394 lea rdi, [rdi + rax * 8]
5395 {Get the free block in esi}
5396 mov rsi, TMediumFreeBlock[rdi].NextFreeBlock
5397 {Remove the first block from the linked list (LIFO)}
5398 mov rax, TMediumFreeBlock[rsi].NextFreeBlock
5399 mov TMediumFreeBlock[rdi].NextFreeBlock, rax
5400 mov TMediumFreeBlock[rax].PreviousFreeBlock, rdi
5401 {Is this bin now empty?}
5402 cmp rdi, rax
5403 jne @MediumBinNotEmptyForMedium
5404 {edx = bin group number, ecx = bin number, rdi = @bin, rsi = free block, ebx = block size}
5405 {Flag this bin as empty}
5406 mov eax, -2
5407 rol eax, cl
5408 lea r8, MediumBlockBinBitmaps
5409 and [r8 + rdx * 4], eax
5410 jnz @MediumBinNotEmptyForMedium
5411 {Flag the group as empty}
5412 btr MediumBlockBinGroupBitmap, edx
5413 @MediumBinNotEmptyForMedium:
5414 {rsi = free block, ebx = block size}
5415 {Get the size of the available medium block in edi}
5416 mov rdi, DropMediumAndLargeFlagsMask
5417 and rdi, [rsi - BlockHeaderSize]
5418 {Get the size of the second split in edx}
5419 mov edx, edi
5420 sub edx, ebx
5421 jz @UseWholeBlockForMedium
5422 {Split the block in two}
5423 lea rcx, [rsi + rbx]
5424 lea rax, [rdx + IsMediumBlockFlag + IsFreeBlockFlag]
5425 mov [rcx - BlockHeaderSize], rax
5426 {Store the size of the second split as the second last dword}
5427 mov [rcx + rdx - BlockHeaderSize * 2], rdx
5428 {Put the remainder in a bin}
5429 cmp edx, MinimumMediumBlockSize
5430 jb @GotMediumBlockForMedium
5431 call InsertMediumBlockIntoBin
5432 jmp @GotMediumBlockForMedium
5433 @UseWholeBlockForMedium:
5434 {Mark this block as used in the block following it}
5435 and byte ptr [rsi + rdi - BlockHeaderSize], not PreviousMediumBlockIsFreeFlag
5436 @GotMediumBlockForMedium:
5437 {Set the size and flags for this block}
5438 lea rcx, [rbx + IsMediumBlockFlag]
5439 mov [rsi - BlockHeaderSize], rcx
5440 {Unlock medium blocks}
5441 xor cl, cl
5442 mov MediumBlocksLocked, cl //workaround for QC99023
5443 mov rax, rsi
5444 jmp @Done
5445 {-------------------Large block allocation-------------------}
5446 @IsALargeBlockRequest:
5447 xor rax, rax
5448 test rcx, rcx
5449 js @Done
5450 call AllocateLargeBlock
5451 @Done:
5452 end;
5453 {$endif}
5454 {$endif}
5455
5456 {$ifndef ASMVersion}
5457 {Frees a medium block, returning 0 on success, -1 otherwise}
FreeMediumBlocknull5458 function FreeMediumBlock(APointer: Pointer): Integer;
5459 var
5460 LNextMediumBlock{$ifndef FullDebugMode}, LPreviousMediumBlock{$endif}: PMediumFreeBlock;
5461 LNextMediumBlockSizeAndFlags: NativeUInt;
5462 LBlockSize{$ifndef FullDebugMode}, LPreviousMediumBlockSize{$endif}: Cardinal;
5463 {$ifndef FullDebugMode}
5464 LPPreviousMediumBlockPoolHeader, LPNextMediumBlockPoolHeader: PMediumBlockPoolHeader;
5465 {$endif}
5466 LBlockHeader: NativeUInt;
5467 begin
5468 {Get the block header}
5469 LBlockHeader := PNativeUInt(PByte(APointer) - BlockHeaderSize)^;
5470 {Get the medium block size}
5471 LBlockSize := LBlockHeader and DropMediumAndLargeFlagsMask;
5472 {Lock the medium blocks}
5473 LockMediumBlocks;
5474 {Can we combine this block with the next free block?}
5475 LNextMediumBlock := PMediumFreeBlock(PByte(APointer) + LBlockSize);
5476 LNextMediumBlockSizeAndFlags := PNativeUInt(PByte(LNextMediumBlock) - BlockHeaderSize)^;
5477 {$ifndef FullDebugMode}
5478 {$ifdef CheckHeapForCorruption}
5479 {Check that this block was flagged as in use in the next block}
5480 if (LNextMediumBlockSizeAndFlags and PreviousMediumBlockIsFreeFlag) <> 0 then
5481 {$ifdef BCB6OrDelphi7AndUp}
5482 System.Error(reInvalidPtr);
5483 {$else}
5484 System.RunError(reInvalidPtr);
5485 {$endif}
5486 {$endif}
5487 if (LNextMediumBlockSizeAndFlags and IsFreeBlockFlag) <> 0 then
5488 begin
5489 {Increase the size of this block}
5490 Inc(LBlockSize, LNextMediumBlockSizeAndFlags and DropMediumAndLargeFlagsMask);
5491 {Remove the next block as well}
5492 if LNextMediumBlockSizeAndFlags >= MinimumMediumBlockSize then
5493 RemoveMediumFreeBlock(LNextMediumBlock);
5494 end
5495 else
5496 begin
5497 {$endif}
5498 {Reset the "previous in use" flag of the next block}
5499 PNativeUInt(PByte(LNextMediumBlock) - BlockHeaderSize)^ := LNextMediumBlockSizeAndFlags or PreviousMediumBlockIsFreeFlag;
5500 {$ifndef FullDebugMode}
5501 end;
5502 {Can we combine this block with the previous free block? We need to
5503 re-read the flags since it could have changed before we could lock the
5504 medium blocks.}
5505 if (PNativeUInt(PByte(APointer) - BlockHeaderSize)^ and PreviousMediumBlockIsFreeFlag) <> 0 then
5506 begin
5507 {Get the size of the free block just before this one}
5508 LPreviousMediumBlockSize := PNativeUInt(PByte(APointer) - 2 * BlockHeaderSize)^;
5509 {Get the start of the previous block}
5510 LPreviousMediumBlock := PMediumFreeBlock(PByte(APointer) - LPreviousMediumBlockSize);
5511 {$ifdef CheckHeapForCorruption}
5512 {Check that the previous block is actually free}
5513 if (PNativeUInt(PByte(LPreviousMediumBlock) - BlockHeaderSize)^ and ExtractMediumAndLargeFlagsMask) <> (IsMediumBlockFlag or IsFreeBlockFlag) then
5514 {$ifdef BCB6OrDelphi7AndUp}
5515 System.Error(reInvalidPtr);
5516 {$else}
5517 System.RunError(reInvalidPtr);
5518 {$endif}
5519 {$endif}
5520 {Set the new block size}
5521 Inc(LBlockSize, LPreviousMediumBlockSize);
5522 {This is the new current block}
5523 APointer := LPreviousMediumBlock;
5524 {Remove the previous block from the linked list}
5525 if LPreviousMediumBlockSize >= MinimumMediumBlockSize then
5526 RemoveMediumFreeBlock(LPreviousMediumBlock);
5527 end;
5528 {$ifdef CheckHeapForCorruption}
5529 {Check that the previous block is currently flagged as in use}
5530 if (PNativeUInt(PByte(APointer) - BlockHeaderSize)^ and PreviousMediumBlockIsFreeFlag) <> 0 then
5531 {$ifdef BCB6OrDelphi7AndUp}
5532 System.Error(reInvalidPtr);
5533 {$else}
5534 System.RunError(reInvalidPtr);
5535 {$endif}
5536 {$endif}
5537 {Is the entire medium block pool free, and there are other free blocks
5538 that can fit the largest possible medium block? -> free it. (Except in
5539 full debug mode where medium pools are never freed.)}
5540 if (LBlockSize <> (MediumBlockPoolSize - MediumBlockPoolHeaderSize)) then
5541 begin
5542 {Store the size of the block as well as the flags}
5543 PNativeUInt(PByte(APointer) - BlockHeaderSize)^ := LBlockSize or (IsMediumBlockFlag or IsFreeBlockFlag);
5544 {$else}
5545 {Mark the block as free}
5546 Inc(PNativeUInt(PByte(APointer) - BlockHeaderSize)^, IsFreeBlockFlag);
5547 {$endif}
5548 {Store the trailing size marker}
5549 PNativeUInt(PByte(APointer) + LBlockSize - 2 * BlockHeaderSize)^ := LBlockSize;
5550 {Insert this block back into the bins: Size check not required here,
5551 since medium blocks that are in use are not allowed to be
5552 shrunk smaller than MinimumMediumBlockSize}
5553 InsertMediumBlockIntoBin(APointer, LBlockSize);
5554 {$ifndef FullDebugMode}
5555 {$ifdef CheckHeapForCorruption}
5556 {Check that this block is actually free and the next and previous blocks are both in use.}
5557 if ((PNativeUInt(PByte(APointer) - BlockHeaderSize)^ and ExtractMediumAndLargeFlagsMask) <> (IsMediumBlockFlag or IsFreeBlockFlag))
5558 or ((PNativeUInt(PByte(APointer) + (PNativeUInt(PByte(APointer) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask) - BlockHeaderSize)^ and IsFreeBlockFlag) <> 0) then
5559 begin
5560 {$ifdef BCB6OrDelphi7AndUp}
5561 System.Error(reInvalidPtr);
5562 {$else}
5563 System.RunError(reInvalidPtr);
5564 {$endif}
5565 end;
5566 {$endif}
5567 {$endif}
5568 {Unlock medium blocks}
5569 MediumBlocksLocked := False;
5570 {All OK}
5571 Result := 0;
5572 {$ifndef FullDebugMode}
5573 end
5574 else
5575 begin
5576 {Should this become the new sequential feed?}
5577 if MediumSequentialFeedBytesLeft <> MediumBlockPoolSize - MediumBlockPoolHeaderSize then
5578 begin
5579 {Bin the current sequential feed}
5580 BinMediumSequentialFeedRemainder;
5581 {Set this medium pool up as the new sequential feed pool:
5582 Store the sequential feed pool trailer}
5583 PNativeUInt(PByte(APointer) + LBlockSize - BlockHeaderSize)^ := IsMediumBlockFlag;
5584 {Store the number of bytes available in the sequential feed chunk}
5585 MediumSequentialFeedBytesLeft := MediumBlockPoolSize - MediumBlockPoolHeaderSize;
5586 {Set the last sequentially fed block}
5587 LastSequentiallyFedMediumBlock := Pointer(PByte(APointer) + LBlockSize);
5588 {Unlock medium blocks}
5589 MediumBlocksLocked := False;
5590 {Success}
5591 Result := 0;
5592 end
5593 else
5594 begin
5595 {Remove this medium block pool from the linked list}
5596 Dec(PByte(APointer), MediumBlockPoolHeaderSize);
5597 LPPreviousMediumBlockPoolHeader := PMediumBlockPoolHeader(APointer).PreviousMediumBlockPoolHeader;
5598 LPNextMediumBlockPoolHeader := PMediumBlockPoolHeader(APointer).NextMediumBlockPoolHeader;
5599 LPPreviousMediumBlockPoolHeader.NextMediumBlockPoolHeader := LPNextMediumBlockPoolHeader;
5600 LPNextMediumBlockPoolHeader.PreviousMediumBlockPoolHeader := LPPreviousMediumBlockPoolHeader;
5601 {Unlock medium blocks}
5602 MediumBlocksLocked := False;
5603 {$ifdef ClearMediumBlockPoolsBeforeReturningToOS}
5604 FillChar(APointer^, MediumBlockPoolSize, 0);
5605 {$endif}
5606 {Free the medium block pool}
5607 if VirtualFree(APointer, 0, MEM_RELEASE) then
5608 Result := 0
5609 else
5610 Result := -1;
5611 end;
5612 end;
5613 {$endif}
5614 end;
5615 {$endif}
5616
5617 {Replacement for SysFreeMem}
FastFreeMemnull5618 function FastFreeMem(APointer: Pointer): Integer;
5619 {$ifndef ASMVersion}
5620 var
5621 LPSmallBlockPool{$ifndef FullDebugMode}, LPPreviousPool, LPNextPool{$endif},
5622 LPOldFirstPool: PSmallBlockPoolHeader;
5623 LPSmallBlockType: PSmallBlockType;
5624 LOldFirstFreeBlock: Pointer;
5625 LBlockHeader: NativeUInt;
5626 begin
5627 {Get the small block header: Is it actually a small block?}
5628 LBlockHeader := PNativeUInt(PByte(APointer) - BlockHeaderSize)^;
5629 {Is it a small block that is in use?}
5630 if LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag or IsLargeBlockFlag) = 0 then
5631 begin
5632 {Get a pointer to the block pool}
5633 LPSmallBlockPool := PSmallBlockPoolHeader(LBlockHeader);
5634 {Get the block type}
5635 LPSmallBlockType := LPSmallBlockPool.BlockType;
5636 {$ifdef ClearSmallAndMediumBlocksInFreeMem}
5637 FillChar(APointer^, LPSmallBlockType.BlockSize - BlockHeaderSize, 0);
5638 {$endif}
5639 {Lock the block type}
5640 {$ifndef AssumeMultiThreaded}
5641 if IsMultiThread then
5642 {$endif}
5643 begin
5644 while (LockCmpxchg(0, 1, @LPSmallBlockType.BlockTypeLocked) <> 0) do
5645 begin
5646 {$ifdef NeverSleepOnThreadContention}
5647 {$ifdef UseSwitchToThread}
5648 SwitchToThread;
5649 {$endif}
5650 {$else}
5651 Sleep(InitialSleepTime);
5652 if LockCmpxchg(0, 1, @LPSmallBlockType.BlockTypeLocked) = 0 then
5653 Break;
5654 Sleep(AdditionalSleepTime);
5655 {$endif}
5656 end;
5657 end;
5658 {Get the old first free block}
5659 LOldFirstFreeBlock := LPSmallBlockPool.FirstFreeBlock;
5660 {Was the pool manager previously full?}
5661 if LOldFirstFreeBlock = nil then
5662 begin
5663 {Insert this as the first partially free pool for the block size}
5664 LPOldFirstPool := LPSmallBlockType.NextPartiallyFreePool;
5665 LPSmallBlockPool.NextPartiallyFreePool := LPOldFirstPool;
5666 LPOldFirstPool.PreviousPartiallyFreePool := LPSmallBlockPool;
5667 LPSmallBlockPool.PreviousPartiallyFreePool := PSmallBlockPoolHeader(LPSmallBlockType);
5668 LPSmallBlockType.NextPartiallyFreePool := LPSmallBlockPool;
5669 end;
5670 {Store the old first free block}
5671 PNativeUInt(PByte(APointer) - BlockHeaderSize)^ := UIntPtr(LOldFirstFreeBlock) or IsFreeBlockFlag;
5672 {Store this as the new first free block}
5673 LPSmallBlockPool.FirstFreeBlock := APointer;
5674 {Decrement the number of allocated blocks}
5675 Dec(LPSmallBlockPool.BlocksInUse);
5676 {Small block pools are never freed in full debug mode. This increases the
5677 likehood of success in catching objects still being used after being
5678 destroyed.}
5679 {$ifndef FullDebugMode}
5680 {Is the entire pool now free? -> Free it.}
5681 if LPSmallBlockPool.BlocksInUse = 0 then
5682 begin
5683 {Get the previous and next chunk managers}
5684 LPPreviousPool := LPSmallBlockPool.PreviousPartiallyFreePool;
5685 LPNextPool := LPSmallBlockPool.NextPartiallyFreePool;
5686 {Remove this manager}
5687 LPPreviousPool.NextPartiallyFreePool := LPNextPool;
5688 LPNextPool.PreviousPartiallyFreePool := LPPreviousPool;
5689 {Is this the sequential feed pool? If so, stop sequential feeding}
5690 if (LPSmallBlockType.CurrentSequentialFeedPool = LPSmallBlockPool) then
5691 LPSmallBlockType.MaxSequentialFeedBlockAddress := nil;
5692 {Unlock this block type}
5693 LPSmallBlockType.BlockTypeLocked := False;
5694 {Free the block pool}
5695 FreeMediumBlock(LPSmallBlockPool);
5696 end
5697 else
5698 begin
5699 {$endif}
5700 {Unlock this block type}
5701 LPSmallBlockType.BlockTypeLocked := False;
5702 {$ifndef FullDebugMode}
5703 end;
5704 {$endif}
5705 {No error}
5706 Result := 0;
5707 end
5708 else
5709 begin
5710 {Is this a medium block or a large block?}
5711 if LBlockHeader and (IsFreeBlockFlag or IsLargeBlockFlag) = 0 then
5712 begin
5713 {$ifdef ClearSmallAndMediumBlocksInFreeMem}
5714 {Get the block header, extract the block size and clear the block it.}
5715 LBlockHeader := PNativeUInt(PByte(APointer) - BlockHeaderSize)^;
5716 FillChar(APointer^,
5717 (LBlockHeader and DropMediumAndLargeFlagsMask) - BlockHeaderSize, 0);
5718 {$endif}
5719 Result := FreeMediumBlock(APointer);
5720 end
5721 else
5722 begin
5723 {Validate: Is this actually a Large block, or is it an attempt to free an
5724 already freed small block?}
5725 if LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag) = 0 then
5726 Result := FreeLargeBlock(APointer)
5727 else
5728 Result := -1;
5729 end;
5730 end;
5731 end;
5732 {$else}
5733 {$ifdef 32Bit}
5734 asm
5735 {Get the block header in edx}
5736 mov edx, [eax - 4]
5737 {Is it a small block in use?}
5738 test dl, IsFreeBlockFlag + IsMediumBlockFlag + IsLargeBlockFlag
5739 {Save the pointer in ecx}
5740 mov ecx, eax
5741 {Save ebx}
5742 push ebx
5743 {Get the IsMultiThread variable in bl}
5744 {$ifndef AssumeMultiThreaded}
5745 mov bl, IsMultiThread
5746 {$endif}
5747 {Is it a small block that is in use?}
5748 jnz @NotSmallBlockInUse
5749 {$ifdef ClearSmallAndMediumBlocksInFreeMem}
5750 push edx
5751 push ecx
5752 mov edx, TSmallBlockPoolHeader[edx].BlockType
5753 movzx edx, TSmallBlockType(edx).BlockSize
5754 sub edx, BlockHeaderSize
5755 xor ecx, ecx
5756 call System.@FillChar
5757 pop ecx
5758 pop edx
5759 {$endif}
5760 {Do we need to lock the block type?}
5761 {$ifndef AssumeMultiThreaded}
5762 test bl, bl
5763 {$endif}
5764 {Get the small block type in ebx}
5765 mov ebx, TSmallBlockPoolHeader[edx].BlockType
5766 {Do we need to lock the block type?}
5767 {$ifndef AssumeMultiThreaded}
5768 jnz @LockBlockTypeLoop
5769 {$else}
5770 jmp @LockBlockTypeLoop
5771 {Align branch target}
5772 nop
5773 {$endif}
5774 @GotLockOnSmallBlockType:
5775 {Current state: edx = @SmallBlockPoolHeader, ecx = APointer, ebx = @SmallBlockType}
5776 {Decrement the number of blocks in use}
5777 sub TSmallBlockPoolHeader[edx].BlocksInUse, 1
5778 {Get the old first free block}
5779 mov eax, TSmallBlockPoolHeader[edx].FirstFreeBlock
5780 {Is the pool now empty?}
5781 jz @PoolIsNowEmpty
5782 {Was the pool full?}
5783 test eax, eax
5784 {Store this as the new first free block}
5785 mov TSmallBlockPoolHeader[edx].FirstFreeBlock, ecx
5786 {Store the previous first free block as the block header}
5787 lea eax, [eax + IsFreeBlockFlag]
5788 mov [ecx - 4], eax
5789 {Insert the pool back into the linked list if it was full}
5790 jz @SmallPoolWasFull
5791 {All ok}
5792 xor eax, eax
5793 {Unlock the block type}
5794 mov TSmallBlockType[ebx].BlockTypeLocked, al
5795 {Restore registers}
5796 pop ebx
5797 {Done}
5798 ret
5799 {Align branch target}
5800 {$ifndef AssumeMultiThreaded}
5801 nop
5802 {$endif}
5803 @SmallPoolWasFull:
5804 {Insert this as the first partially free pool for the block size}
5805 mov ecx, TSmallBlockType[ebx].NextPartiallyFreePool
5806 mov TSmallBlockPoolHeader[edx].PreviousPartiallyFreePool, ebx
5807 mov TSmallBlockPoolHeader[edx].NextPartiallyFreePool, ecx
5808 mov TSmallBlockPoolHeader[ecx].PreviousPartiallyFreePool, edx
5809 mov TSmallBlockType[ebx].NextPartiallyFreePool, edx
5810 {Unlock the block type}
5811 mov TSmallBlockType[ebx].BlockTypeLocked, False
5812 {All ok}
5813 xor eax, eax
5814 {Restore registers}
5815 pop ebx
5816 {Done}
5817 ret
5818 {Align branch target}
5819 nop
5820 nop
5821 @PoolIsNowEmpty:
5822 {Was this pool actually in the linked list of pools with space? If not, it
5823 can only be the sequential feed pool (it is the only pool that may contain
5824 only one block, i.e. other blocks have not been split off yet)}
5825 test eax, eax
5826 jz @IsSequentialFeedPool
5827 {Pool is now empty: Remove it from the linked list and free it}
5828 mov eax, TSmallBlockPoolHeader[edx].PreviousPartiallyFreePool
5829 mov ecx, TSmallBlockPoolHeader[edx].NextPartiallyFreePool
5830 {Remove this manager}
5831 mov TSmallBlockPoolHeader[eax].NextPartiallyFreePool, ecx
5832 mov TSmallBlockPoolHeader[ecx].PreviousPartiallyFreePool, eax
5833 {Zero out eax}
5834 xor eax, eax
5835 {Is this the sequential feed pool? If so, stop sequential feeding}
5836 cmp TSmallBlockType[ebx].CurrentSequentialFeedPool, edx
5837 jne @NotSequentialFeedPool
5838 @IsSequentialFeedPool:
5839 mov TSmallBlockType[ebx].MaxSequentialFeedBlockAddress, eax
5840 @NotSequentialFeedPool:
5841 {Unlock the block type}
5842 mov TSmallBlockType[ebx].BlockTypeLocked, al
5843 {Release this pool}
5844 mov eax, edx
5845 mov edx, [edx - 4]
5846 {$ifndef AssumeMultiThreaded}
5847 mov bl, IsMultiThread
5848 {$endif}
5849 jmp @FreeMediumBlock
5850 {Align branch target}
5851 {$ifndef AssumeMultiThreaded}
5852 nop
5853 nop
5854 {$endif}
5855 nop
5856 @LockBlockTypeLoop:
5857 mov eax, $100
5858 {Attempt to grab the block type}
5859 lock cmpxchg TSmallBlockType([ebx]).BlockTypeLocked, ah
5860 je @GotLockOnSmallBlockType
5861 {$ifdef NeverSleepOnThreadContention}
5862 {Pause instruction (improves performance on P4)}
5863 rep nop
5864 {$ifdef UseSwitchToThread}
5865 push ecx
5866 push edx
5867 call SwitchToThread
5868 pop edx
5869 pop ecx
5870 {$endif}
5871 {Try again}
5872 jmp @LockBlockTypeLoop
5873 {Align branch target}
5874 {$ifndef UseSwitchToThread}
5875 nop
5876 {$endif}
5877 {$else}
5878 {Couldn't grab the block type - sleep and try again}
5879 push ecx
5880 push edx
5881 push InitialSleepTime
5882 call Sleep
5883 pop edx
5884 pop ecx
5885 {Try again}
5886 mov eax, $100
5887 {Attempt to grab the block type}
5888 lock cmpxchg TSmallBlockType([ebx]).BlockTypeLocked, ah
5889 je @GotLockOnSmallBlockType
5890 {Couldn't grab the block type - sleep and try again}
5891 push ecx
5892 push edx
5893 push AdditionalSleepTime
5894 call Sleep
5895 pop edx
5896 pop ecx
5897 {Try again}
5898 jmp @LockBlockTypeLoop
5899 {Align branch target}
5900 nop
5901 nop
5902 {$endif}
5903 {---------------------Medium blocks------------------------------}
5904 {Align branch target}
5905 @NotSmallBlockInUse:
5906 {Not a small block in use: is it a medium or large block?}
5907 test dl, IsFreeBlockFlag + IsLargeBlockFlag
5908 jnz @NotASmallOrMediumBlock
5909 @FreeMediumBlock:
5910 {$ifdef ClearSmallAndMediumBlocksInFreeMem}
5911 push eax
5912 push edx
5913 and edx, DropMediumAndLargeFlagsMask
5914 sub edx, BlockHeaderSize
5915 xor ecx, ecx
5916 call System.@FillChar
5917 pop edx
5918 pop eax
5919 {$endif}
5920 {Drop the flags}
5921 and edx, DropMediumAndLargeFlagsMask
5922 {Free the medium block pointed to by eax, header in edx, bl = IsMultiThread}
5923 {$ifndef AssumeMultiThreaded}
5924 {Do we need to lock the medium blocks?}
5925 test bl, bl
5926 {$endif}
5927 {Block size in ebx}
5928 mov ebx, edx
5929 {Save registers}
5930 push esi
5931 {Pointer in esi}
5932 mov esi, eax
5933 {Do we need to lock the medium blocks?}
5934 {$ifndef AssumeMultiThreaded}
5935 jz @MediumBlocksLocked
5936 {$endif}
5937 call LockMediumBlocks
5938 @MediumBlocksLocked:
5939 {Can we combine this block with the next free block?}
5940 test dword ptr [esi + ebx - 4], IsFreeBlockFlag
5941 {Get the next block size and flags in ecx}
5942 mov ecx, [esi + ebx - 4]
5943 jnz @NextBlockIsFree
5944 {Set the "PreviousIsFree" flag in the next block}
5945 or ecx, PreviousMediumBlockIsFreeFlag
5946 mov [esi + ebx - 4], ecx
5947 @NextBlockChecked:
5948 {Can we combine this block with the previous free block? We need to
5949 re-read the flags since it could have changed before we could lock the
5950 medium blocks.}
5951 test byte ptr [esi - 4], PreviousMediumBlockIsFreeFlag
5952 jnz @PreviousBlockIsFree
5953 @PreviousBlockChecked:
5954 {Is the entire medium block pool free, and there are other free blocks
5955 that can fit the largest possible medium block -> free it.}
5956 cmp ebx, (MediumBlockPoolSize - MediumBlockPoolHeaderSize)
5957 je @EntireMediumPoolFree
5958 @BinFreeMediumBlock:
5959 {Store the size of the block as well as the flags}
5960 lea eax, [ebx + IsMediumBlockFlag + IsFreeBlockFlag]
5961 mov [esi - 4], eax
5962 {Store the trailing size marker}
5963 mov [esi + ebx - 8], ebx
5964 {Insert this block back into the bins: Size check not required here,
5965 since medium blocks that are in use are not allowed to be
5966 shrunk smaller than MinimumMediumBlockSize}
5967 mov eax, esi
5968 mov edx, ebx
5969 {Insert into bin}
5970 call InsertMediumBlockIntoBin
5971 {Unlock medium blocks}
5972 mov MediumBlocksLocked, False;
5973 {All OK}
5974 xor eax, eax
5975 {Restore registers}
5976 pop esi
5977 pop ebx
5978 {Return}
5979 ret
5980 {Align branch target}
5981 @NextBlockIsFree:
5982 {Get the next block address in eax}
5983 lea eax, [esi + ebx]
5984 {Increase the size of this block}
5985 and ecx, DropMediumAndLargeFlagsMask
5986 add ebx, ecx
5987 {Was the block binned?}
5988 cmp ecx, MinimumMediumBlockSize
5989 jb @NextBlockChecked
5990 call RemoveMediumFreeBlock
5991 jmp @NextBlockChecked
5992 {Align branch target}
5993 nop
5994 @PreviousBlockIsFree:
5995 {Get the size of the free block just before this one}
5996 mov ecx, [esi - 8]
5997 {Include the previous block}
5998 sub esi, ecx
5999 {Set the new block size}
6000 add ebx, ecx
6001 {Remove the previous block from the linked list}
6002 cmp ecx, MinimumMediumBlockSize
6003 jb @PreviousBlockChecked
6004 mov eax, esi
6005 call RemoveMediumFreeBlock
6006 jmp @PreviousBlockChecked
6007 {Align branch target}
6008 @EntireMediumPoolFree:
6009 {Should we make this the new sequential feed medium block pool? If the
6010 current sequential feed pool is not entirely free, we make this the new
6011 sequential feed pool.}
6012 cmp MediumSequentialFeedBytesLeft, MediumBlockPoolSize - MediumBlockPoolHeaderSize
6013 jne @MakeEmptyMediumPoolSequentialFeed
6014 {Point esi to the medium block pool header}
6015 sub esi, MediumBlockPoolHeaderSize
6016 {Remove this medium block pool from the linked list}
6017 mov eax, TMediumBlockPoolHeader[esi].PreviousMediumBlockPoolHeader
6018 mov edx, TMediumBlockPoolHeader[esi].NextMediumBlockPoolHeader
6019 mov TMediumBlockPoolHeader[eax].NextMediumBlockPoolHeader, edx
6020 mov TMediumBlockPoolHeader[edx].PreviousMediumBlockPoolHeader, eax
6021 {Unlock medium blocks}
6022 mov MediumBlocksLocked, False;
6023 {$ifdef ClearMediumBlockPoolsBeforeReturningToOS}
6024 mov eax, esi
6025 mov edx, MediumBlockPoolSize
6026 xor ecx, ecx
6027 call System.@FillChar
6028 {$endif}
6029 {Free the medium block pool}
6030 push MEM_RELEASE
6031 push 0
6032 push esi
6033 call VirtualFree
6034 {VirtualFree returns >0 if all is ok}
6035 cmp eax, 1
6036 {Return 0 on all ok}
6037 sbb eax, eax
6038 {Restore registers}
6039 pop esi
6040 pop ebx
6041 ret
6042 {Align branch target}
6043 nop
6044 nop
6045 nop
6046 @MakeEmptyMediumPoolSequentialFeed:
6047 {Get a pointer to the end-marker block}
6048 lea ebx, [esi + MediumBlockPoolSize - MediumBlockPoolHeaderSize]
6049 {Bin the current sequential feed pool}
6050 call BinMediumSequentialFeedRemainder
6051 {Set this medium pool up as the new sequential feed pool:
6052 Store the sequential feed pool trailer}
6053 mov dword ptr [ebx - BlockHeaderSize], IsMediumBlockFlag
6054 {Store the number of bytes available in the sequential feed chunk}
6055 mov MediumSequentialFeedBytesLeft, MediumBlockPoolSize - MediumBlockPoolHeaderSize
6056 {Set the last sequentially fed block}
6057 mov LastSequentiallyFedMediumBlock, ebx
6058 {Unlock medium blocks}
6059 mov MediumBlocksLocked, False;
6060 {Success}
6061 xor eax, eax
6062 {Restore registers}
6063 pop esi
6064 pop ebx
6065 ret
6066 {Align branch target}
6067 nop
6068 nop
6069 @NotASmallOrMediumBlock:
6070 {Restore ebx}
6071 pop ebx
6072 {Is it in fact a large block?}
6073 test dl, IsFreeBlockFlag + IsMediumBlockFlag
6074 jz FreeLargeBlock
6075 {Attempt to free an already free block}
6076 mov eax, -1
6077 end;
6078
6079 {$else}
6080
6081 {---------------64-bit BASM FastFreeMem---------------}
6082 asm
6083 .params 3
6084 .pushnv rbx
6085 .pushnv rsi
6086 {Get the block header in rdx}
6087 mov rdx, [rcx - BlockHeaderSize]
6088 {Is it a small block in use?}
6089 test dl, IsFreeBlockFlag + IsMediumBlockFlag + IsLargeBlockFlag
6090 {Get the IsMultiThread variable in bl}
6091 {$ifndef AssumeMultiThreaded}
6092 mov bl, IsMultiThread
6093 {$endif}
6094 {Is it a small block that is in use?}
6095 jnz @NotSmallBlockInUse
6096 {$ifdef ClearSmallAndMediumBlocksInFreeMem}
6097 mov rsi, rcx
6098 mov rdx, TSmallBlockPoolHeader[rdx].BlockType
6099 movzx edx, TSmallBlockType(rdx).BlockSize
6100 sub edx, BlockHeaderSize
6101 xor r8, r8
6102 call System.@FillChar
6103 mov rcx, rsi
6104 mov rdx, [rcx - BlockHeaderSize]
6105 {$endif}
6106 {Do we need to lock the block type?}
6107 {$ifndef AssumeMultiThreaded}
6108 test bl, bl
6109 {$endif}
6110 {Get the small block type in rbx}
6111 mov rbx, TSmallBlockPoolHeader[rdx].BlockType
6112 {Do we need to lock the block type?}
6113 {$ifndef AssumeMultiThreaded}
6114 jnz @LockBlockTypeLoop
6115 {$else}
6116 jmp @LockBlockTypeLoop
6117 {$endif}
6118 @GotLockOnSmallBlockType:
6119 {Current state: rdx = @SmallBlockPoolHeader, rcx = APointer, rbx = @SmallBlockType}
6120 {Decrement the number of blocks in use}
6121 sub TSmallBlockPoolHeader[rdx].BlocksInUse, 1
6122 {Get the old first free block}
6123 mov rax, TSmallBlockPoolHeader[rdx].FirstFreeBlock
6124 {Is the pool now empty?}
6125 jz @PoolIsNowEmpty
6126 {Was the pool full?}
6127 test rax, rax
6128 {Store this as the new first free block}
6129 mov TSmallBlockPoolHeader[rdx].FirstFreeBlock, rcx
6130 {Store the previous first free block as the block header}
6131 lea rax, [rax + IsFreeBlockFlag]
6132 mov [rcx - BlockHeaderSize], rax
6133 {Insert the pool back into the linked list if it was full}
6134 jz @SmallPoolWasFull
6135 {All ok}
6136 xor eax, eax
6137 {Unlock the block type}
6138 mov TSmallBlockType[rbx].BlockTypeLocked, al
6139 jmp @Done
6140 @SmallPoolWasFull:
6141 {Insert this as the first partially free pool for the block size}
6142 mov rcx, TSmallBlockType[rbx].NextPartiallyFreePool
6143 mov TSmallBlockPoolHeader[rdx].PreviousPartiallyFreePool, rbx
6144 mov TSmallBlockPoolHeader[rdx].NextPartiallyFreePool, rcx
6145 mov TSmallBlockPoolHeader[rcx].PreviousPartiallyFreePool, rdx
6146 mov TSmallBlockType[rbx].NextPartiallyFreePool, rdx
6147 {Unlock the block type}
6148 mov TSmallBlockType[rbx].BlockTypeLocked, False
6149 {All ok}
6150 xor eax, eax
6151 jmp @Done
6152 @PoolIsNowEmpty:
6153 {Was this pool actually in the linked list of pools with space? If not, it
6154 can only be the sequential feed pool (it is the only pool that may contain
6155 only one block, i.e. other blocks have not been split off yet)}
6156 test rax, rax
6157 jz @IsSequentialFeedPool
6158 {Pool is now empty: Remove it from the linked list and free it}
6159 mov rax, TSmallBlockPoolHeader[rdx].PreviousPartiallyFreePool
6160 mov rcx, TSmallBlockPoolHeader[rdx].NextPartiallyFreePool
6161 {Remove this manager}
6162 mov TSmallBlockPoolHeader[rax].NextPartiallyFreePool, rcx
6163 mov TSmallBlockPoolHeader[rcx].PreviousPartiallyFreePool, rax
6164 {Zero out eax}
6165 xor rax, rax
6166 {Is this the sequential feed pool? If so, stop sequential feeding}
6167 cmp TSmallBlockType[rbx].CurrentSequentialFeedPool, rdx
6168 jne @NotSequentialFeedPool
6169 @IsSequentialFeedPool:
6170 mov TSmallBlockType[rbx].MaxSequentialFeedBlockAddress, rax
6171 @NotSequentialFeedPool:
6172 {Unlock the block type}
6173 mov TSmallBlockType[rbx].BlockTypeLocked, al
6174 {Release this pool}
6175 mov rcx, rdx
6176 mov rdx, [rdx - BlockHeaderSize]
6177 {$ifndef AssumeMultiThreaded}
6178 mov bl, IsMultiThread
6179 {$endif}
6180 jmp @FreeMediumBlock
6181 @LockBlockTypeLoop:
6182 mov eax, $100
6183 {Attempt to grab the block type}
6184 lock cmpxchg TSmallBlockType([rbx]).BlockTypeLocked, ah
6185 je @GotLockOnSmallBlockType
6186 {$ifdef NeverSleepOnThreadContention}
6187 {Pause instruction (improves performance on P4)}
6188 pause
6189 {$ifdef UseSwitchToThread}
6190 mov rsi, rcx
6191 call SwitchToThread
6192 mov rcx, rsi
6193 mov rdx, [rcx - BlockHeaderSize]
6194 {$endif}
6195 {Try again}
6196 jmp @LockBlockTypeLoop
6197 {$else}
6198 {Couldn't grab the block type - sleep and try again}
6199 mov rsi, rcx
6200 mov ecx, InitialSleepTime
6201 call Sleep
6202 mov rcx, rsi
6203 mov rdx, [rcx - BlockHeaderSize]
6204 {Try again}
6205 mov eax, $100
6206 {Attempt to grab the block type}
6207 lock cmpxchg TSmallBlockType([rbx]).BlockTypeLocked, ah
6208 je @GotLockOnSmallBlockType
6209 {Couldn't grab the block type - sleep and try again}
6210 mov rsi, rcx
6211 mov ecx, AdditionalSleepTime
6212 call Sleep
6213 mov rcx, rsi
6214 mov rdx, [rcx - BlockHeaderSize]
6215 {Try again}
6216 jmp @LockBlockTypeLoop
6217 {$endif}
6218 {---------------------Medium blocks------------------------------}
6219 @NotSmallBlockInUse:
6220 {Not a small block in use: is it a medium or large block?}
6221 test dl, IsFreeBlockFlag + IsLargeBlockFlag
6222 jnz @NotASmallOrMediumBlock
6223 @FreeMediumBlock:
6224 {$ifdef ClearSmallAndMediumBlocksInFreeMem}
6225 mov rsi, rcx
6226 and rdx, DropMediumAndLargeFlagsMask
6227 sub rdx, BlockHeaderSize
6228 xor r8, r8
6229 call System.@FillChar
6230 mov rcx, rsi
6231 mov rdx, [rcx - BlockHeaderSize]
6232 {$endif}
6233 {Drop the flags}
6234 and rdx, DropMediumAndLargeFlagsMask
6235 {Free the medium block pointed to by eax, header in edx, bl = IsMultiThread}
6236 {$ifndef AssumeMultiThreaded}
6237 {Do we need to lock the medium blocks?}
6238 test bl, bl
6239 {$endif}
6240 {Block size in rbx}
6241 mov rbx, rdx
6242 {Pointer in rsi}
6243 mov rsi, rcx
6244 {Do we need to lock the medium blocks?}
6245 {$ifndef AssumeMultiThreaded}
6246 jz @MediumBlocksLocked
6247 {$endif}
6248 call LockMediumBlocks
6249 @MediumBlocksLocked:
6250 {Can we combine this block with the next free block?}
6251 test qword ptr [rsi + rbx - BlockHeaderSize], IsFreeBlockFlag
6252 {Get the next block size and flags in rcx}
6253 mov rcx, [rsi + rbx - BlockHeaderSize]
6254 jnz @NextBlockIsFree
6255 {Set the "PreviousIsFree" flag in the next block}
6256 or rcx, PreviousMediumBlockIsFreeFlag
6257 mov [rsi + rbx - BlockHeaderSize], rcx
6258 @NextBlockChecked:
6259 {Can we combine this block with the previous free block? We need to
6260 re-read the flags since it could have changed before we could lock the
6261 medium blocks.}
6262 test byte ptr [rsi - BlockHeaderSize], PreviousMediumBlockIsFreeFlag
6263 jnz @PreviousBlockIsFree
6264 @PreviousBlockChecked:
6265 {Is the entire medium block pool free, and there are other free blocks
6266 that can fit the largest possible medium block -> free it.}
6267 cmp ebx, (MediumBlockPoolSize - MediumBlockPoolHeaderSize)
6268 je @EntireMediumPoolFree
6269 @BinFreeMediumBlock:
6270 {Store the size of the block as well as the flags}
6271 lea rax, [rbx + IsMediumBlockFlag + IsFreeBlockFlag]
6272 mov [rsi - BlockHeaderSize], rax
6273 {Store the trailing size marker}
6274 mov [rsi + rbx - 2 * BlockHeaderSize], rbx
6275 {Insert this block back into the bins: Size check not required here,
6276 since medium blocks that are in use are not allowed to be
6277 shrunk smaller than MinimumMediumBlockSize}
6278 mov rcx, rsi
6279 mov rdx, rbx
6280 {Insert into bin}
6281 call InsertMediumBlockIntoBin
6282 {All OK}
6283 xor eax, eax
6284 {Unlock medium blocks}
6285 mov MediumBlocksLocked, al
6286 jmp @Done
6287 @NextBlockIsFree:
6288 {Get the next block address in rax}
6289 lea rax, [rsi + rbx]
6290 {Increase the size of this block}
6291 and rcx, DropMediumAndLargeFlagsMask
6292 add rbx, rcx
6293 {Was the block binned?}
6294 cmp rcx, MinimumMediumBlockSize
6295 jb @NextBlockChecked
6296 mov rcx, rax
6297 call RemoveMediumFreeBlock
6298 jmp @NextBlockChecked
6299 @PreviousBlockIsFree:
6300 {Get the size of the free block just before this one}
6301 mov rcx, [rsi - 2 * BlockHeaderSize]
6302 {Include the previous block}
6303 sub rsi, rcx
6304 {Set the new block size}
6305 add rbx, rcx
6306 {Remove the previous block from the linked list}
6307 cmp ecx, MinimumMediumBlockSize
6308 jb @PreviousBlockChecked
6309 mov rcx, rsi
6310 call RemoveMediumFreeBlock
6311 jmp @PreviousBlockChecked
6312 @EntireMediumPoolFree:
6313 {Should we make this the new sequential feed medium block pool? If the
6314 current sequential feed pool is not entirely free, we make this the new
6315 sequential feed pool.}
6316 lea r8, MediumSequentialFeedBytesLeft
6317 cmp dword ptr [r8], MediumBlockPoolSize - MediumBlockPoolHeaderSize //workaround for QC99023
6318 jne @MakeEmptyMediumPoolSequentialFeed
6319 {Point esi to the medium block pool header}
6320 sub rsi, MediumBlockPoolHeaderSize
6321 {Remove this medium block pool from the linked list}
6322 mov rax, TMediumBlockPoolHeader[rsi].PreviousMediumBlockPoolHeader
6323 mov rdx, TMediumBlockPoolHeader[rsi].NextMediumBlockPoolHeader
6324 mov TMediumBlockPoolHeader[rax].NextMediumBlockPoolHeader, rdx
6325 mov TMediumBlockPoolHeader[rdx].PreviousMediumBlockPoolHeader, rax
6326 {Unlock medium blocks}
6327 xor eax, eax
6328 mov MediumBlocksLocked, al
6329 {$ifdef ClearMediumBlockPoolsBeforeReturningToOS}
6330 mov rcx, rsi
6331 mov edx, MediumBlockPoolSize
6332 xor r8, r8
6333 call System.@FillChar
6334 {$endif}
6335 {Free the medium block pool}
6336 mov rcx, rsi
6337 xor edx, edx
6338 mov r8d, MEM_RELEASE
6339 call VirtualFree
6340 {VirtualFree returns >0 if all is ok}
6341 cmp eax, 1
6342 {Return 0 on all ok}
6343 sbb eax, eax
6344 jmp @Done
6345 @MakeEmptyMediumPoolSequentialFeed:
6346 {Get a pointer to the end-marker block}
6347 lea rbx, [rsi + MediumBlockPoolSize - MediumBlockPoolHeaderSize]
6348 {Bin the current sequential feed pool}
6349 call BinMediumSequentialFeedRemainder
6350 {Set this medium pool up as the new sequential feed pool:
6351 Store the sequential feed pool trailer}
6352 mov qword ptr [rbx - BlockHeaderSize], IsMediumBlockFlag
6353 {Store the number of bytes available in the sequential feed chunk}
6354 lea rax, MediumSequentialFeedBytesLeft
6355 mov dword ptr [rax], MediumBlockPoolSize - MediumBlockPoolHeaderSize //QC99023 workaround
6356 {Set the last sequentially fed block}
6357 mov LastSequentiallyFedMediumBlock, rbx
6358 {Success}
6359 xor eax, eax
6360 {Unlock medium blocks}
6361 mov MediumBlocksLocked, al
6362 jmp @Done
6363 @NotASmallOrMediumBlock:
6364 {Attempt to free an already free block?}
6365 mov eax, -1
6366 {Is it in fact a large block?}
6367 test dl, IsFreeBlockFlag + IsMediumBlockFlag
6368 jnz @Done
6369 call FreeLargeBlock
6370 @Done:
6371 end;
6372 {$endif}
6373 {$endif}
6374
6375 {$ifndef FullDebugMode}
6376 {Replacement for SysReallocMem}
FastReallocMemnull6377 function FastReallocMem(APointer: Pointer; ANewSize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer;
6378 {$ifndef ASMVersion}
6379 var
6380 LBlockHeader, LNextBlockSizeAndFlags, LNewAllocSize, LBlockFlags,
6381 LOldAvailableSize, LNextBlockSize, LNewAvailableSize, LMinimumUpsize,
6382 LSecondSplitSize, LNewBlockSize: NativeUInt;
6383 LPSmallBlockType: PSmallBlockType;
6384 LPNextBlock, LPNextBlockHeader: Pointer;
6385
6386 {Upsizes a large block in-place. The following variables are assumed correct:
6387 LBlockFlags, LOldAvailableSize, LPNextBlock, LNextBlockSizeAndFlags,
6388 LNextBlockSize, LNewAvailableSize. Medium blocks must be locked on entry if
6389 required.}
6390 procedure MediumBlockInPlaceUpsize;
6391 begin
6392 {Remove the next block}
6393 if LNextBlockSizeAndFlags >= MinimumMediumBlockSize then
6394 RemoveMediumFreeBlock(LPNextBlock);
6395 {Add 25% for medium block in-place upsizes}
6396 LMinimumUpsize := LOldAvailableSize + (LOldAvailableSize shr 2);
6397 if NativeUInt(ANewSize) < LMinimumUpsize then
6398 LNewAllocSize := LMinimumUpsize
6399 else
6400 LNewAllocSize := NativeUInt(ANewSize);
6401 {Round up to the nearest block size granularity}
6402 LNewBlockSize := ((LNewAllocSize + (BlockHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset))
6403 and -MediumBlockGranularity) + MediumBlockSizeOffset;
6404 {Calculate the size of the second split}
6405 LSecondSplitSize := LNewAvailableSize + BlockHeaderSize - LNewBlockSize;
6406 {Does it fit?}
6407 if NativeInt(LSecondSplitSize) <= 0 then
6408 begin
6409 {The block size is the full available size plus header}
6410 LNewBlockSize := LNewAvailableSize + BlockHeaderSize;
6411 {Grab the whole block: Mark it as used in the block following it}
6412 LPNextBlockHeader := Pointer(PByte(APointer) + LNewAvailableSize);
6413 PNativeUInt(LPNextBlockHeader)^ :=
6414 PNativeUInt(LPNextBlockHeader)^ and (not PreviousMediumBlockIsFreeFlag);
6415 end
6416 else
6417 begin
6418 {Split the block in two}
6419 LPNextBlock := PMediumFreeBlock(PByte(APointer) + LNewBlockSize);
6420 {Set the size of the second split}
6421 PNativeUInt(PByte(LPNextBlock) - BlockHeaderSize)^ := LSecondSplitSize or (IsMediumBlockFlag or IsFreeBlockFlag);
6422 {Store the size of the second split before the header of the next block}
6423 PNativeUInt(PByte(LPNextBlock) + LSecondSplitSize - 2 * BlockHeaderSize)^ := LSecondSplitSize;
6424 {Put the remainder in a bin if it is big enough}
6425 if LSecondSplitSize >= MinimumMediumBlockSize then
6426 InsertMediumBlockIntoBin(LPNextBlock, LSecondSplitSize);
6427 end;
6428 {Set the size and flags for this block}
6429 PNativeUInt(PByte(APointer) - BlockHeaderSize)^ := LNewBlockSize or LBlockFlags;
6430 end;
6431
6432 {In-place downsize of a medium block. On entry Size must be less than half of
6433 LOldAvailableSize.}
6434 procedure MediumBlockInPlaceDownsize;
6435 begin
6436 {Round up to the next medium block size}
6437 LNewBlockSize := ((ANewSize + (BlockHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset))
6438 and -MediumBlockGranularity) + MediumBlockSizeOffset;
6439 {Get the size of the second split}
6440 LSecondSplitSize := (LOldAvailableSize + BlockHeaderSize) - LNewBlockSize;
6441 {Lock the medium blocks}
6442 LockMediumBlocks;
6443 {Set the new size}
6444 PNativeUInt(PByte(APointer) - BlockHeaderSize)^ :=
6445 (PNativeUInt(PByte(APointer) - BlockHeaderSize)^ and ExtractMediumAndLargeFlagsMask)
6446 or LNewBlockSize;
6447 {Is the next block in use?}
6448 LPNextBlock := PNativeUInt(PByte(APointer) + LOldAvailableSize + BlockHeaderSize);
6449 LNextBlockSizeAndFlags := PNativeUInt(PByte(LPNextBlock) - BlockHeaderSize)^;
6450 if LNextBlockSizeAndFlags and IsFreeBlockFlag = 0 then
6451 begin
6452 {The next block is in use: flag its previous block as free}
6453 PNativeUInt(PByte(LPNextBlock) - BlockHeaderSize)^ :=
6454 LNextBlockSizeAndFlags or PreviousMediumBlockIsFreeFlag;
6455 end
6456 else
6457 begin
6458 {The next block is free: combine it}
6459 LNextBlockSizeAndFlags := LNextBlockSizeAndFlags and DropMediumAndLargeFlagsMask;
6460 Inc(LSecondSplitSize, LNextBlockSizeAndFlags);
6461 if LNextBlockSizeAndFlags >= MinimumMediumBlockSize then
6462 RemoveMediumFreeBlock(LPNextBlock);
6463 end;
6464 {Set the split}
6465 LPNextBlock := PNativeUInt(PByte(APointer) + LNewBlockSize);
6466 {Store the free part's header}
6467 PNativeUInt(PByte(LPNextBlock) - BlockHeaderSize)^ := LSecondSplitSize or (IsMediumBlockFlag or IsFreeBlockFlag);
6468 {Store the trailing size field}
6469 PNativeUInt(PByte(LPNextBlock) + LSecondSplitSize - 2 * BlockHeaderSize)^ := LSecondSplitSize;
6470 {Bin this free block}
6471 if LSecondSplitSize >= MinimumMediumBlockSize then
6472 InsertMediumBlockIntoBin(LPNextBlock, LSecondSplitSize);
6473 {Unlock the medium blocks}
6474 MediumBlocksLocked := False;
6475 end;
6476
6477 begin
6478 {Get the block header: Is it actually a small block?}
6479 LBlockHeader := PNativeUInt(PByte(APointer) - BlockHeaderSize)^;
6480 {Is it a small block that is in use?}
6481 if LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag or IsLargeBlockFlag) = 0 then
6482 begin
6483 {-----------------------------------Small block-------------------------------------}
6484 {The block header is a pointer to the block pool: Get the block type}
6485 LPSmallBlockType := PSmallBlockPoolHeader(LBlockHeader).BlockType;
6486 {Get the available size inside blocks of this type.}
6487 LOldAvailableSize := LPSmallBlockType.BlockSize - BlockHeaderSize;
6488 {Is it an upsize or a downsize?}
6489 if LOldAvailableSize >= NativeUInt(ANewSize) then
6490 begin
6491 {It's a downsize. Do we need to allocate a smaller block? Only if the new
6492 block size is less than a quarter of the available size less
6493 SmallBlockDownsizeCheckAdder bytes}
6494 if (NativeUInt(ANewSize) * 4 + SmallBlockDownsizeCheckAdder) >= LOldAvailableSize then
6495 begin
6496 {In-place downsize - return the pointer}
6497 Result := APointer;
6498 Exit;
6499 end
6500 else
6501 begin
6502 {Allocate a smaller block}
6503 Result := FastGetMem(ANewSize);
6504 {Allocated OK?}
6505 if Result <> nil then
6506 begin
6507 {Move the data across}
6508 {$ifdef UseCustomVariableSizeMoveRoutines}
6509 {$ifdef Align16Bytes}
6510 MoveX16LP(APointer^, Result^, ANewSize);
6511 {$else}
6512 MoveX8LP(APointer^, Result^, ANewSize);
6513 {$endif}
6514 {$else}
6515 System.Move(APointer^, Result^, ANewSize);
6516 {$endif}
6517 {Free the old pointer}
6518 FastFreeMem(APointer);
6519 end;
6520 end;
6521 end
6522 else
6523 begin
6524 {This pointer is being reallocated to a larger block and therefore it is
6525 logical to assume that it may be enlarged again. Since reallocations are
6526 expensive, there is a minimum upsize percentage to avoid unnecessary
6527 future move operations.}
6528 {Must grow with at least 100% + x bytes}
6529 LNewAllocSize := LOldAvailableSize * 2 + SmallBlockUpsizeAdder;
6530 {Still not large enough?}
6531 if LNewAllocSize < NativeUInt(ANewSize) then
6532 LNewAllocSize := NativeUInt(ANewSize);
6533 {Allocate the new block}
6534 Result := FastGetMem(LNewAllocSize);
6535 {Allocated OK?}
6536 if Result <> nil then
6537 begin
6538 {Do we need to store the requested size? Only large blocks store the
6539 requested size.}
6540 if LNewAllocSize > (MaximumMediumBlockSize - BlockHeaderSize) then
6541 PLargeBlockHeader(PByte(Result) - LargeBlockHeaderSize).UserAllocatedSize := ANewSize;
6542 {Move the data across}
6543 {$ifdef UseCustomFixedSizeMoveRoutines}
6544 LPSmallBlockType.UpsizeMoveProcedure(APointer^, Result^, LOldAvailableSize);
6545 {$else}
6546 System.Move(APointer^, Result^, LOldAvailableSize);
6547 {$endif}
6548 {Free the old pointer}
6549 FastFreeMem(APointer);
6550 end;
6551 end;
6552 end
6553 else
6554 begin
6555 {Is this a medium block or a large block?}
6556 if LBlockHeader and (IsFreeBlockFlag or IsLargeBlockFlag) = 0 then
6557 begin
6558 {-------------------------------Medium block--------------------------------------}
6559 {What is the available size in the block being reallocated?}
6560 LOldAvailableSize := (LBlockHeader and DropMediumAndLargeFlagsMask);
6561 {Get a pointer to the next block}
6562 LPNextBlock := PNativeUInt(PByte(APointer) + LOldAvailableSize);
6563 {Subtract the block header size from the old available size}
6564 Dec(LOldAvailableSize, BlockHeaderSize);
6565 {Is it an upsize or a downsize?}
6566 if NativeUInt(ANewSize) > LOldAvailableSize then
6567 begin
6568 {Can we do an in-place upsize?}
6569 LNextBlockSizeAndFlags := PNativeUInt(PByte(LPNextBlock) - BlockHeaderSize)^;
6570 {Is the next block free?}
6571 if LNextBlockSizeAndFlags and IsFreeBlockFlag <> 0 then
6572 begin
6573 LNextBlockSize := LNextBlockSizeAndFlags and DropMediumAndLargeFlagsMask;
6574 {The available size including the next block}
6575 LNewAvailableSize := LOldAvailableSize + LNextBlockSize;
6576 {Can the block fit?}
6577 if NativeUInt(ANewSize) <= LNewAvailableSize then
6578 begin
6579 {The next block is free and there is enough space to grow this
6580 block in place.}
6581 {$ifndef AssumeMultiThreaded}
6582 if IsMultiThread then
6583 begin
6584 {$endif}
6585 {Multi-threaded application - lock medium blocks and re-read the
6586 information on the blocks.}
6587 LockMediumBlocks;
6588 {Re-read the info for this block}
6589 LBlockFlags := PNativeUInt(PByte(APointer) - BlockHeaderSize)^ and ExtractMediumAndLargeFlagsMask;
6590 {Re-read the info for the next block}
6591 LNextBlockSizeAndFlags := PNativeUInt(PByte(LPNextBlock) - BlockHeaderSize)^;
6592 {Recalculate the next block size}
6593 LNextBlockSize := LNextBlockSizeAndFlags and DropMediumAndLargeFlagsMask;
6594 {The available size including the next block}
6595 LNewAvailableSize := LOldAvailableSize + LNextBlockSize;
6596 {Is the next block still free and the size still sufficient?}
6597 if (LNextBlockSizeAndFlags and IsFreeBlockFlag <> 0)
6598 and (NativeUInt(ANewSize) <= LNewAvailableSize) then
6599 begin
6600 {Upsize the block in-place}
6601 MediumBlockInPlaceUpsize;
6602 {Unlock the medium blocks}
6603 MediumBlocksLocked := False;
6604 {Return the result}
6605 Result := APointer;
6606 {Done}
6607 Exit;
6608 end;
6609 {Couldn't use the block: Unlock the medium blocks}
6610 MediumBlocksLocked := False;
6611 {$ifndef AssumeMultiThreaded}
6612 end
6613 else
6614 begin
6615 {Extract the block flags}
6616 LBlockFlags := ExtractMediumAndLargeFlagsMask and LBlockHeader;
6617 {Upsize the block in-place}
6618 MediumBlockInPlaceUpsize;
6619 {Return the result}
6620 Result := APointer;
6621 {Done}
6622 Exit;
6623 end;
6624 {$endif}
6625 end;
6626 end;
6627 {Couldn't upsize in place. Grab a new block and move the data across:
6628 If we have to reallocate and move medium blocks, we grow by at
6629 least 25%}
6630 LMinimumUpsize := LOldAvailableSize + (LOldAvailableSize shr 2);
6631 if NativeUInt(ANewSize) < LMinimumUpsize then
6632 LNewAllocSize := LMinimumUpsize
6633 else
6634 LNewAllocSize := NativeUInt(ANewSize);
6635 {Allocate the new block}
6636 Result := FastGetMem(LNewAllocSize);
6637 if Result <> nil then
6638 begin
6639 {If it's a large block - store the actual user requested size}
6640 if LNewAllocSize > (MaximumMediumBlockSize - BlockHeaderSize) then
6641 PLargeBlockHeader(PByte(Result) - LargeBlockHeaderSize).UserAllocatedSize := ANewSize;
6642 {Move the data across}
6643 {$ifdef UseCustomVariableSizeMoveRoutines}
6644 MoveX16LP(APointer^, Result^, LOldAvailableSize);
6645 {$else}
6646 System.Move(APointer^, Result^, LOldAvailableSize);
6647 {$endif}
6648 {Free the old block}
6649 FastFreeMem(APointer);
6650 end;
6651 end
6652 else
6653 begin
6654 {Must be less than half the current size or we don't bother resizing.}
6655 if NativeUInt(ANewSize * 2) >= LOldAvailableSize then
6656 begin
6657 Result := APointer;
6658 end
6659 else
6660 begin
6661 {In-place downsize? Balance the cost of moving the data vs. the cost
6662 of fragmenting the memory pool. Medium blocks in use may never be
6663 smaller than MinimumMediumBlockSize.}
6664 if NativeUInt(ANewSize) >= (MinimumMediumBlockSize - BlockHeaderSize) then
6665 begin
6666 MediumBlockInPlaceDownsize;
6667 Result := APointer;
6668 end
6669 else
6670 begin
6671 {The requested size is less than the minimum medium block size. If
6672 the requested size is less than the threshold value (currently a
6673 quarter of the minimum medium block size), move the data to a small
6674 block, otherwise shrink the medium block to the minimum allowable
6675 medium block size.}
6676 if NativeUInt(ANewSize) >= MediumInPlaceDownsizeLimit then
6677 begin
6678 {The request is for a size smaller than the minimum medium block
6679 size, but not small enough to justify moving data: Reduce the
6680 block size to the minimum medium block size}
6681 ANewSize := MinimumMediumBlockSize - BlockHeaderSize;
6682 {Is it already at the minimum medium block size?}
6683 if LOldAvailableSize > NativeUInt(ANewSize) then
6684 MediumBlockInPlaceDownsize;
6685 Result := APointer;
6686 end
6687 else
6688 begin
6689 {Allocate the new block}
6690 Result := FastGetMem(ANewSize);
6691 if Result <> nil then
6692 begin
6693 {Move the data across}
6694 {$ifdef UseCustomVariableSizeMoveRoutines}
6695 {$ifdef Align16Bytes}
6696 MoveX16LP(APointer^, Result^, ANewSize);
6697 {$else}
6698 MoveX8LP(APointer^, Result^, ANewSize);
6699 {$endif}
6700 {$else}
6701 System.Move(APointer^, Result^, ANewSize);
6702 {$endif}
6703 {Free the old block}
6704 FastFreeMem(APointer);
6705 end;
6706 end;
6707 end;
6708 end;
6709 end;
6710 end
6711 else
6712 begin
6713 {Is this a valid large block?}
6714 if LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag) = 0 then
6715 begin
6716 {-----------------------Large block------------------------------}
6717 Result := ReallocateLargeBlock(APointer, ANewSize);
6718 end
6719 else
6720 begin
6721 {-----------------------Invalid block------------------------------}
6722 {Bad pointer: probably an attempt to reallocate a free memory block.}
6723 Result := nil;
6724 end;
6725 end;
6726 end;
6727 end;
6728 {$else}
6729 {$ifdef 32Bit}
6730 asm
6731 {On entry: eax = APointer; edx = ANewSize}
6732 {Get the block header: Is it actually a small block?}
6733 mov ecx, [eax - 4]
6734 {Is it a small block?}
6735 test cl, IsFreeBlockFlag + IsMediumBlockFlag + IsLargeBlockFlag
6736 {Save ebx}
6737 push ebx
6738 {Save esi}
6739 push esi
6740 {Save the original pointer in esi}
6741 mov esi, eax
6742 {Is it a small block?}
6743 jnz @NotASmallBlock
6744 {-----------------------------------Small block-------------------------------------}
6745 {Get the block type in ebx}
6746 mov ebx, TSmallBlockPoolHeader[ecx].BlockType
6747 {Get the available size inside blocks of this type.}
6748 movzx ecx, TSmallBlockType[ebx].BlockSize
6749 sub ecx, 4
6750 {Is it an upsize or a downsize?}
6751 cmp ecx, edx
6752 jb @SmallUpsize
6753 {It's a downsize. Do we need to allocate a smaller block? Only if the new
6754 size is less than a quarter of the available size less
6755 SmallBlockDownsizeCheckAdder bytes}
6756 lea ebx, [edx * 4 + SmallBlockDownsizeCheckAdder]
6757 cmp ebx, ecx
6758 jb @NotSmallInPlaceDownsize
6759 {In-place downsize - return the original pointer}
6760 pop esi
6761 pop ebx
6762 ret
6763 {Align branch target}
6764 nop
6765 @NotSmallInPlaceDownsize:
6766 {Save the requested size}
6767 mov ebx, edx
6768 {Allocate a smaller block}
6769 mov eax, edx
6770 call FastGetMem
6771 {Allocated OK?}
6772 test eax, eax
6773 jz @SmallDownsizeDone
6774 {Move data across: count in ecx}
6775 mov ecx, ebx
6776 {Destination in edx}
6777 mov edx, eax
6778 {Save the result in ebx}
6779 mov ebx, eax
6780 {Original pointer in eax}
6781 mov eax, esi
6782 {Move the data across}
6783 {$ifdef UseCustomVariableSizeMoveRoutines}
6784 {$ifdef Align16Bytes}
6785 call MoveX16LP
6786 {$else}
6787 call MoveX8LP
6788 {$endif}
6789 {$else}
6790 call System.Move
6791 {$endif}
6792 {Free the original pointer}
6793 mov eax, esi
6794 call FastFreeMem
6795 {Return the pointer}
6796 mov eax, ebx
6797 @SmallDownsizeDone:
6798 pop esi
6799 pop ebx
6800 ret
6801 {Align branch target}
6802 nop
6803 nop
6804 @SmallUpsize:
6805 {State: esi = APointer, edx = ANewSize, ecx = Current Block Size, ebx = Current Block Type}
6806 {This pointer is being reallocated to a larger block and therefore it is
6807 logical to assume that it may be enlarged again. Since reallocations are
6808 expensive, there is a minimum upsize percentage to avoid unnecessary
6809 future move operations.}
6810 {Small blocks always grow with at least 100% + SmallBlockUpsizeAdder bytes}
6811 lea ecx, [ecx + ecx + SmallBlockUpsizeAdder]
6812 {save edi}
6813 push edi
6814 {Save the requested size in edi}
6815 mov edi, edx
6816 {New allocated size is the maximum of the requested size and the minimum
6817 upsize}
6818 xor eax, eax
6819 sub ecx, edx
6820 adc eax, -1
6821 and eax, ecx
6822 add eax, edx
6823 {Allocate the new block}
6824 call FastGetMem
6825 {Allocated OK?}
6826 test eax, eax
6827 jz @SmallUpsizeDone
6828 {Do we need to store the requested size? Only large blocks store the
6829 requested size.}
6830 cmp edi, MaximumMediumBlockSize - BlockHeaderSize
6831 jbe @NotSmallUpsizeToLargeBlock
6832 {Store the user requested size}
6833 mov [eax - 8], edi
6834 @NotSmallUpsizeToLargeBlock:
6835 {Get the size to move across}
6836 movzx ecx, TSmallBlockType[ebx].BlockSize
6837 sub ecx, BlockHeaderSize
6838 {Move to the new block}
6839 mov edx, eax
6840 {Save the result in edi}
6841 mov edi, eax
6842 {Move from the old block}
6843 mov eax, esi
6844 {Move the data across}
6845 {$ifdef UseCustomFixedSizeMoveRoutines}
6846 call TSmallBlockType[ebx].UpsizeMoveProcedure
6847 {$else}
6848 call System.Move
6849 {$endif}
6850 {Free the old pointer}
6851 mov eax, esi
6852 call FastFreeMem
6853 {Done}
6854 mov eax, edi
6855 @SmallUpsizeDone:
6856 pop edi
6857 pop esi
6858 pop ebx
6859 ret
6860 {Align branch target}
6861 nop
6862 @NotASmallBlock:
6863 {Is this a medium block or a large block?}
6864 test cl, IsFreeBlockFlag + IsLargeBlockFlag
6865 jnz @PossibleLargeBlock
6866 {-------------------------------Medium block--------------------------------------}
6867 {Status: ecx = Current Block Size + Flags, eax/esi = APointer,
6868 edx = Requested Size}
6869 mov ebx, ecx
6870 {Drop the flags from the header}
6871 and ecx, DropMediumAndLargeFlagsMask
6872 {Save edi}
6873 push edi
6874 {Get a pointer to the next block in edi}
6875 lea edi, [eax + ecx]
6876 {Subtract the block header size from the old available size}
6877 sub ecx, BlockHeaderSize
6878 {Get the complete flags in ebx}
6879 and ebx, ExtractMediumAndLargeFlagsMask
6880 {Is it an upsize or a downsize?}
6881 cmp edx, ecx
6882 {Save ebp}
6883 push ebp
6884 {Is it an upsize or a downsize?}
6885 ja @MediumBlockUpsize
6886 {Status: ecx = Current Block Size - 4, bl = Current Block Flags,
6887 edi = @Next Block, eax/esi = APointer, edx = Requested Size}
6888 {Must be less than half the current size or we don't bother resizing.}
6889 lea ebp, [edx + edx]
6890 cmp ebp, ecx
6891 jb @MediumMustDownsize
6892 @MediumNoResize:
6893 {Restore registers}
6894 pop ebp
6895 pop edi
6896 pop esi
6897 pop ebx
6898 {Return}
6899 ret
6900 {Align branch target}
6901 nop
6902 nop
6903 nop
6904 @MediumMustDownsize:
6905 {In-place downsize? Balance the cost of moving the data vs. the cost of
6906 fragmenting the memory pool. Medium blocks in use may never be smaller
6907 than MinimumMediumBlockSize.}
6908 cmp edx, MinimumMediumBlockSize - BlockHeaderSize
6909 jae @MediumBlockInPlaceDownsize
6910 {The requested size is less than the minimum medium block size. If the
6911 requested size is less than the threshold value (currently a quarter of the
6912 minimum medium block size), move the data to a small block, otherwise shrink
6913 the medium block to the minimum allowable medium block size.}
6914 cmp edx, MediumInPlaceDownsizeLimit
6915 jb @MediumDownsizeRealloc
6916 {The request is for a size smaller than the minimum medium block size, but
6917 not small enough to justify moving data: Reduce the block size to the
6918 minimum medium block size}
6919 mov edx, MinimumMediumBlockSize - BlockHeaderSize
6920 {Is it already at the minimum medium block size?}
6921 cmp ecx, edx
6922 jna @MediumNoResize
6923 @MediumBlockInPlaceDownsize:
6924 {Round up to the next medium block size}
6925 lea ebp, [edx + BlockHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset]
6926 and ebp, -MediumBlockGranularity;
6927 add ebp, MediumBlockSizeOffset
6928 {Get the size of the second split}
6929 add ecx, BlockHeaderSize
6930 sub ecx, ebp
6931 {Lock the medium blocks}
6932 {$ifndef AssumeMultiThreaded}
6933 cmp IsMultiThread, False
6934 je @DoMediumInPlaceDownsize
6935 {$endif}
6936 @DoMediumLockForDownsize:
6937 {Lock the medium blocks (ecx *must* be preserved)}
6938 call LockMediumBlocks
6939 {Reread the flags - they may have changed before medium blocks could be
6940 locked.}
6941 mov ebx, ExtractMediumAndLargeFlagsMask
6942 and ebx, [esi - 4]
6943 @DoMediumInPlaceDownsize:
6944 {Set the new size}
6945 or ebx, ebp
6946 mov [esi - 4], ebx
6947 {Get the second split size in ebx}
6948 mov ebx, ecx
6949 {Is the next block in use?}
6950 mov edx, [edi - 4]
6951 test dl, IsFreeBlockFlag
6952 jnz @MediumDownsizeNextBlockFree
6953 {The next block is in use: flag its previous block as free}
6954 or edx, PreviousMediumBlockIsFreeFlag
6955 mov [edi - 4], edx
6956 jmp @MediumDownsizeDoSplit
6957 {Align branch target}
6958 nop
6959 nop
6960 {$ifdef AssumeMultiThreaded}
6961 nop
6962 {$endif}
6963 @MediumDownsizeNextBlockFree:
6964 {The next block is free: combine it}
6965 mov eax, edi
6966 and edx, DropMediumAndLargeFlagsMask
6967 add ebx, edx
6968 add edi, edx
6969 cmp edx, MinimumMediumBlockSize
6970 jb @MediumDownsizeDoSplit
6971 call RemoveMediumFreeBlock
6972 @MediumDownsizeDoSplit:
6973 {Store the trailing size field}
6974 mov [edi - 8], ebx
6975 {Store the free part's header}
6976 lea eax, [ebx + IsMediumBlockFlag + IsFreeBlockFlag];
6977 mov [esi + ebp - 4], eax
6978 {Bin this free block}
6979 cmp ebx, MinimumMediumBlockSize
6980 jb @MediumBlockDownsizeDone
6981 lea eax, [esi + ebp]
6982 mov edx, ebx
6983 call InsertMediumBlockIntoBin
6984 @MediumBlockDownsizeDone:
6985 {Unlock the medium blocks}
6986 mov MediumBlocksLocked, False
6987 {Result = old pointer}
6988 mov eax, esi
6989 {Restore registers}
6990 pop ebp
6991 pop edi
6992 pop esi
6993 pop ebx
6994 {Return}
6995 ret
6996 {Align branch target}
6997 @MediumDownsizeRealloc:
6998 {Save the requested size}
6999 mov edi, edx
7000 mov eax, edx
7001 {Allocate the new block}
7002 call FastGetMem
7003 test eax, eax
7004 jz @MediumBlockDownsizeExit
7005 {Save the result}
7006 mov ebp, eax
7007 mov edx, eax
7008 mov eax, esi
7009 mov ecx, edi
7010 {Move the data across}
7011 {$ifdef UseCustomVariableSizeMoveRoutines}
7012 {$ifdef Align16Bytes}
7013 call MoveX16LP
7014 {$else}
7015 call MoveX8LP
7016 {$endif}
7017 {$else}
7018 call System.Move
7019 {$endif}
7020 mov eax, esi
7021 call FastFreeMem
7022 {Return the result}
7023 mov eax, ebp
7024 @MediumBlockDownsizeExit:
7025 pop ebp
7026 pop edi
7027 pop esi
7028 pop ebx
7029 ret
7030 {Align branch target}
7031 @MediumBlockUpsize:
7032 {Status: ecx = Current Block Size - 4, bl = Current Block Flags,
7033 edi = @Next Block, eax/esi = APointer, edx = Requested Size}
7034 {Can we do an in-place upsize?}
7035 mov eax, [edi - 4]
7036 test al, IsFreeBlockFlag
7037 jz @CannotUpsizeMediumBlockInPlace
7038 {Get the total available size including the next block}
7039 and eax, DropMediumAndLargeFlagsMask
7040 {ebp = total available size including the next block (excluding the header)}
7041 lea ebp, [eax + ecx]
7042 {Can the block fit?}
7043 cmp edx, ebp
7044 ja @CannotUpsizeMediumBlockInPlace
7045 {The next block is free and there is enough space to grow this
7046 block in place.}
7047 {$ifndef AssumeMultiThreaded}
7048 cmp IsMultiThread, False
7049 je @DoMediumInPlaceUpsize
7050 {$endif}
7051 @DoMediumLockForUpsize:
7052 {Lock the medium blocks (ecx and edx *must* be preserved}
7053 call LockMediumBlocks
7054 {Re-read the info for this block (since it may have changed before the medium
7055 blocks could be locked)}
7056 mov ebx, ExtractMediumAndLargeFlagsMask
7057 and ebx, [esi - 4]
7058 {Re-read the info for the next block}
7059 mov eax, [edi - 4]
7060 {Next block still free?}
7061 test al, IsFreeBlockFlag
7062 jz @NextMediumBlockChanged
7063 {Recalculate the next block size}
7064 and eax, DropMediumAndLargeFlagsMask
7065 {The available size including the next block}
7066 lea ebp, [eax + ecx]
7067 {Can the block still fit?}
7068 cmp edx, ebp
7069 ja @NextMediumBlockChanged
7070 @DoMediumInPlaceUpsize:
7071 {Is the next block binnable?}
7072 cmp eax, MinimumMediumBlockSize
7073 {Remove the next block}
7074 jb @MediumInPlaceNoNextRemove
7075 mov eax, edi
7076 push ecx
7077 push edx
7078 call RemoveMediumFreeBlock
7079 pop edx
7080 pop ecx
7081 @MediumInPlaceNoNextRemove:
7082 {Medium blocks grow a minimum of 25% in in-place upsizes}
7083 mov eax, ecx
7084 shr eax, 2
7085 add eax, ecx
7086 {Get the maximum of the requested size and the minimum growth size}
7087 xor edi, edi
7088 sub eax, edx
7089 adc edi, -1
7090 and eax, edi
7091 {Round up to the nearest block size granularity}
7092 lea eax, [eax + edx + BlockHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset]
7093 and eax, -MediumBlockGranularity
7094 add eax, MediumBlockSizeOffset
7095 {Calculate the size of the second split}
7096 lea edx, [ebp + BlockHeaderSize]
7097 sub edx, eax
7098 {Does it fit?}
7099 ja @MediumInPlaceUpsizeSplit
7100 {Grab the whole block: Mark it as used in the block following it}
7101 and dword ptr [esi + ebp], not PreviousMediumBlockIsFreeFlag
7102 {The block size is the full available size plus header}
7103 add ebp, 4
7104 {Upsize done}
7105 jmp @MediumUpsizeInPlaceDone
7106 {Align branch target}
7107 {$ifndef AssumeMultiThreaded}
7108 nop
7109 nop
7110 nop
7111 {$endif}
7112 @MediumInPlaceUpsizeSplit:
7113 {Store the size of the second split as the second last dword}
7114 mov [esi + ebp - 4], edx
7115 {Set the second split header}
7116 lea edi, [edx + IsMediumBlockFlag + IsFreeBlockFlag]
7117 mov [esi + eax - 4], edi
7118 mov ebp, eax
7119 cmp edx, MinimumMediumBlockSize
7120 jb @MediumUpsizeInPlaceDone
7121 add eax, esi
7122 call InsertMediumBlockIntoBin
7123 @MediumUpsizeInPlaceDone:
7124 {Set the size and flags for this block}
7125 or ebp, ebx
7126 mov [esi - 4], ebp
7127 {Unlock the medium blocks}
7128 mov MediumBlocksLocked, False
7129 {Result = old pointer}
7130 mov eax, esi
7131 @MediumBlockResizeDone2:
7132 {Restore registers}
7133 pop ebp
7134 pop edi
7135 pop esi
7136 pop ebx
7137 {Return}
7138 ret
7139 {Align branch target for "@CannotUpsizeMediumBlockInPlace"}
7140 nop
7141 nop
7142 @NextMediumBlockChanged:
7143 {The next medium block changed while the medium blocks were being locked}
7144 mov MediumBlocksLocked, False
7145 @CannotUpsizeMediumBlockInPlace:
7146 {Couldn't upsize in place. Grab a new block and move the data across:
7147 If we have to reallocate and move medium blocks, we grow by at
7148 least 25%}
7149 mov eax, ecx
7150 shr eax, 2
7151 add eax, ecx
7152 {Get the maximum of the requested size and the minimum growth size}
7153 xor edi, edi
7154 sub eax, edx
7155 adc edi, -1
7156 and eax, edi
7157 add eax, edx
7158 {Save the size to allocate}
7159 mov ebp, eax
7160 {Save the size to move across}
7161 mov edi, ecx
7162 {Get the block}
7163 push edx
7164 call FastGetMem
7165 pop edx
7166 {Success?}
7167 test eax, eax
7168 jz @MediumBlockResizeDone2
7169 {If it's a Large block - store the actual user requested size}
7170 cmp ebp, MaximumMediumBlockSize - BlockHeaderSize
7171 jbe @MediumUpsizeNotLarge
7172 mov [eax - 8], edx
7173 @MediumUpsizeNotLarge:
7174 {Save the result}
7175 mov ebp, eax
7176 {Move the data across}
7177 mov edx, eax
7178 mov eax, esi
7179 mov ecx, edi
7180 {$ifdef UseCustomVariableSizeMoveRoutines}
7181 call MoveX16LP
7182 {$else}
7183 call System.Move
7184 {$endif}
7185 {Free the old block}
7186 mov eax, esi
7187 call FastFreeMem
7188 {Restore the result}
7189 mov eax, ebp
7190 {Restore registers}
7191 pop ebp
7192 pop edi
7193 pop esi
7194 pop ebx
7195 {Return}
7196 ret
7197 {Align branch target}
7198 nop
7199 @PossibleLargeBlock:
7200 {-----------------------Large block------------------------------}
7201 {Restore registers}
7202 pop esi
7203 pop ebx
7204 {Is this a valid large block?}
7205 test cl, IsFreeBlockFlag + IsMediumBlockFlag
7206 jz ReallocateLargeBlock
7207 {-----------------------Invalid block------------------------------}
7208 xor eax, eax
7209 end;
7210
7211 {$else}
7212
7213 {-----------------64-bit BASM FastReallocMem-----------------}
7214 asm
7215 .params 3
7216 .pushnv rbx
7217 .pushnv rsi
7218 .pushnv rdi
7219 .pushnv r14
7220 .pushnv r15
7221 {On entry: rcx = APointer; rdx = ANewSize}
7222 {Save the original pointer in rsi}
7223 mov rsi, rcx
7224 {Get the block header}
7225 mov rcx, [rcx - BlockHeaderSize]
7226 {Is it a small block?}
7227 test cl, IsFreeBlockFlag + IsMediumBlockFlag + IsLargeBlockFlag
7228 jnz @NotASmallBlock
7229 {-----------------------------------Small block-------------------------------------}
7230 {Get the block type in rbx}
7231 mov rbx, TSmallBlockPoolHeader[rcx].BlockType
7232 {Get the available size inside blocks of this type.}
7233 movzx ecx, TSmallBlockType[rbx].BlockSize
7234 sub ecx, BlockHeaderSize
7235 {Is it an upsize or a downsize?}
7236 cmp rcx, rdx
7237 jb @SmallUpsize
7238 {It's a downsize. Do we need to allocate a smaller block? Only if the new
7239 size is less than a quarter of the available size less
7240 SmallBlockDownsizeCheckAdder bytes}
7241 lea ebx, [edx * 4 + SmallBlockDownsizeCheckAdder]
7242 cmp ebx, ecx
7243 jb @NotSmallInPlaceDownsize
7244 {In-place downsize - return the original pointer}
7245 mov rax, rsi
7246 jmp @Done
7247 @NotSmallInPlaceDownsize:
7248 {Save the requested size}
7249 mov rbx, rdx
7250 {Allocate a smaller block}
7251 mov rcx, rdx
7252 call FastGetMem
7253 {Allocated OK?}
7254 test rax, rax
7255 jz @Done
7256 {Move data across: count in r8}
7257 mov r8, rbx
7258 {Destination in edx}
7259 mov rdx, rax
7260 {Save the result in ebx}
7261 mov rbx, rax
7262 {Original pointer in ecx}
7263 mov rcx, rsi
7264 {Move the data across}
7265 {$ifdef UseCustomVariableSizeMoveRoutines}
7266 {$ifdef Align16Bytes}
7267 call MoveX16LP
7268 {$else}
7269 call MoveX8LP
7270 {$endif}
7271 {$else}
7272 call System.Move
7273 {$endif}
7274 {Free the original pointer}
7275 mov rcx, rsi
7276 call FastFreeMem
7277 {Return the pointer}
7278 mov rax, rbx
7279 jmp @Done
7280 @SmallUpsize:
7281 {State: rsi = APointer, rdx = ANewSize, rcx = Current Block Size, rbx = Current Block Type}
7282 {This pointer is being reallocated to a larger block and therefore it is
7283 logical to assume that it may be enlarged again. Since reallocations are
7284 expensive, there is a minimum upsize percentage to avoid unnecessary
7285 future move operations.}
7286 {Small blocks always grow with at least 100% + SmallBlockUpsizeAdder bytes}
7287 lea ecx, [ecx + ecx + SmallBlockUpsizeAdder]
7288 {Save the requested size in rdi}
7289 mov rdi, rdx
7290 {New allocated size is the maximum of the requested size and the minimum
7291 upsize}
7292 xor rax, rax
7293 sub rcx, rdx
7294 adc rax, -1
7295 and rcx, rax
7296 add rcx, rdx
7297 {Allocate the new block}
7298 call FastGetMem
7299 {Allocated OK?}
7300 test rax, rax
7301 jz @Done
7302 {Do we need to store the requested size? Only large blocks store the
7303 requested size.}
7304 cmp rdi, MaximumMediumBlockSize - BlockHeaderSize
7305 jbe @NotSmallUpsizeToLargeBlock
7306 {Store the user requested size}
7307 mov [rax - 2 * BlockHeaderSize], rdi
7308 @NotSmallUpsizeToLargeBlock:
7309 {Get the size to move across}
7310 movzx r8d, TSmallBlockType[rbx].BlockSize
7311 sub r8d, BlockHeaderSize
7312 {Move to the new block}
7313 mov rdx, rax
7314 {Save the result in edi}
7315 mov rdi, rax
7316 {Move from the old block}
7317 mov rcx, rsi
7318 {Move the data across}
7319 {$ifdef UseCustomFixedSizeMoveRoutines}
7320 call TSmallBlockType[rbx].UpsizeMoveProcedure
7321 {$else}
7322 call System.Move
7323 {$endif}
7324 {Free the old pointer}
7325 mov rcx, rsi
7326 call FastFreeMem
7327 {Done}
7328 mov rax, rdi
7329 jmp @Done
7330 @NotASmallBlock:
7331 {Is this a medium block or a large block?}
7332 test cl, IsFreeBlockFlag + IsLargeBlockFlag
7333 jnz @PossibleLargeBlock
7334 {-------------------------------Medium block--------------------------------------}
7335 {Status: rcx = Current Block Size + Flags, rsi = APointer,
7336 rdx = Requested Size}
7337 mov rbx, rcx
7338 {Drop the flags from the header}
7339 and ecx, DropMediumAndLargeFlagsMask
7340 {Get a pointer to the next block in rdi}
7341 lea rdi, [rsi + rcx]
7342 {Subtract the block header size from the old available size}
7343 sub ecx, BlockHeaderSize
7344 {Get the complete flags in ebx}
7345 and ebx, ExtractMediumAndLargeFlagsMask
7346 {Is it an upsize or a downsize?}
7347 cmp rdx, rcx
7348 ja @MediumBlockUpsize
7349 {Status: ecx = Current Block Size - BlockHeaderSize, bl = Current Block Flags,
7350 rdi = @Next Block, rsi = APointer, rdx = Requested Size}
7351 {Must be less than half the current size or we don't bother resizing.}
7352 lea r15, [rdx + rdx]
7353 cmp r15, rcx
7354 jb @MediumMustDownsize
7355 @MediumNoResize:
7356 mov rax, rsi
7357 jmp @Done
7358 @MediumMustDownsize:
7359 {In-place downsize? Balance the cost of moving the data vs. the cost of
7360 fragmenting the memory pool. Medium blocks in use may never be smaller
7361 than MinimumMediumBlockSize.}
7362 cmp edx, MinimumMediumBlockSize - BlockHeaderSize
7363 jae @MediumBlockInPlaceDownsize
7364 {The requested size is less than the minimum medium block size. If the
7365 requested size is less than the threshold value (currently a quarter of the
7366 minimum medium block size), move the data to a small block, otherwise shrink
7367 the medium block to the minimum allowable medium block size.}
7368 cmp edx, MediumInPlaceDownsizeLimit
7369 jb @MediumDownsizeRealloc
7370 {The request is for a size smaller than the minimum medium block size, but
7371 not small enough to justify moving data: Reduce the block size to the
7372 minimum medium block size}
7373 mov edx, MinimumMediumBlockSize - BlockHeaderSize
7374 {Is it already at the minimum medium block size?}
7375 cmp ecx, edx
7376 jna @MediumNoResize
7377 @MediumBlockInPlaceDownsize:
7378 {Round up to the next medium block size}
7379 lea r15, [rdx + BlockHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset]
7380 and r15, -MediumBlockGranularity
7381 add r15, MediumBlockSizeOffset
7382 {Get the size of the second split}
7383 add ecx, BlockHeaderSize
7384 sub ecx, r15d
7385 {Lock the medium blocks}
7386 {$ifndef AssumeMultiThreaded}
7387 lea r8, IsMultiThread
7388 cmp byte ptr [r8], False
7389 je @DoMediumInPlaceDownsize
7390 {$endif}
7391 @DoMediumLockForDownsize:
7392 {Lock the medium blocks}
7393 mov ebx, ecx
7394 call LockMediumBlocks
7395 mov ecx, ebx
7396 {Reread the flags - they may have changed before medium blocks could be
7397 locked.}
7398 mov rbx, ExtractMediumAndLargeFlagsMask
7399 and rbx, [rsi - BlockHeaderSize]
7400 @DoMediumInPlaceDownsize:
7401 {Set the new size}
7402 or rbx, r15
7403 mov [rsi - BlockHeaderSize], rbx
7404 {Get the second split size in ebx}
7405 mov ebx, ecx
7406 {Is the next block in use?}
7407 mov rdx, [rdi - BlockHeaderSize]
7408 test dl, IsFreeBlockFlag
7409 jnz @MediumDownsizeNextBlockFree
7410 {The next block is in use: flag its previous block as free}
7411 or rdx, PreviousMediumBlockIsFreeFlag
7412 mov [rdi - BlockHeaderSize], rdx
7413 jmp @MediumDownsizeDoSplit
7414 @MediumDownsizeNextBlockFree:
7415 {The next block is free: combine it}
7416 mov rcx, rdi
7417 and rdx, DropMediumAndLargeFlagsMask
7418 add rbx, rdx
7419 add rdi, rdx
7420 cmp edx, MinimumMediumBlockSize
7421 jb @MediumDownsizeDoSplit
7422 call RemoveMediumFreeBlock
7423 @MediumDownsizeDoSplit:
7424 {Store the trailing size field}
7425 mov [rdi - 2 * BlockHeaderSize], rbx
7426 {Store the free part's header}
7427 lea rcx, [rbx + IsMediumBlockFlag + IsFreeBlockFlag];
7428 mov [rsi + r15 - BlockHeaderSize], rcx
7429 {Bin this free block}
7430 cmp rbx, MinimumMediumBlockSize
7431 jb @MediumBlockDownsizeDone
7432 lea rcx, [rsi + r15]
7433 mov rdx, rbx
7434 call InsertMediumBlockIntoBin
7435 @MediumBlockDownsizeDone:
7436 {Unlock the medium blocks}
7437 lea rax, MediumBlocksLocked
7438 mov byte ptr [rax], False
7439 {Result = old pointer}
7440 mov rax, rsi
7441 jmp @Done
7442 @MediumDownsizeRealloc:
7443 {Save the requested size}
7444 mov rdi, rdx
7445 mov rcx, rdx
7446 {Allocate the new block}
7447 call FastGetMem
7448 test rax, rax
7449 jz @Done
7450 {Save the result}
7451 mov r15, rax
7452 mov rdx, rax
7453 mov rcx, rsi
7454 mov r8, rdi
7455 {Move the data across}
7456 {$ifdef UseCustomVariableSizeMoveRoutines}
7457 {$ifdef Align16Bytes}
7458 call MoveX16LP
7459 {$else}
7460 call MoveX8LP
7461 {$endif}
7462 {$else}
7463 call System.Move
7464 {$endif}
7465 mov rcx, rsi
7466 call FastFreeMem
7467 {Return the result}
7468 mov rax, r15
7469 jmp @Done
7470 @MediumBlockUpsize:
7471 {Status: ecx = Current Block Size - BlockHeaderSize, bl = Current Block Flags,
7472 rdi = @Next Block, rsi = APointer, rdx = Requested Size}
7473 {Can we do an in-place upsize?}
7474 mov rax, [rdi - BlockHeaderSize]
7475 test al, IsFreeBlockFlag
7476 jz @CannotUpsizeMediumBlockInPlace
7477 {Get the total available size including the next block}
7478 and rax, DropMediumAndLargeFlagsMask
7479 {r15 = total available size including the next block (excluding the header)}
7480 lea r15, [rax + rcx]
7481 {Can the block fit?}
7482 cmp rdx, r15
7483 ja @CannotUpsizeMediumBlockInPlace
7484 {The next block is free and there is enough space to grow this
7485 block in place.}
7486 {$ifndef AssumeMultiThreaded}
7487 lea r8, IsMultiThread
7488 cmp byte ptr [r8], False
7489 je @DoMediumInPlaceUpsize
7490 {$endif}
7491 @DoMediumLockForUpsize:
7492 {Lock the medium blocks.}
7493 mov rbx, rcx
7494 mov r15, rdx
7495 call LockMediumBlocks
7496 mov rcx, rbx
7497 mov rdx, r15
7498 {Re-read the info for this block (since it may have changed before the medium
7499 blocks could be locked)}
7500 mov rbx, ExtractMediumAndLargeFlagsMask
7501 and rbx, [rsi - BlockHeaderSize]
7502 {Re-read the info for the next block}
7503 mov rax, [rdi - BlockheaderSize]
7504 {Next block still free?}
7505 test al, IsFreeBlockFlag
7506 jz @NextMediumBlockChanged
7507 {Recalculate the next block size}
7508 and eax, DropMediumAndLargeFlagsMask
7509 {The available size including the next block}
7510 lea r15, [rax + rcx]
7511 {Can the block still fit?}
7512 cmp rdx, r15
7513 ja @NextMediumBlockChanged
7514 @DoMediumInPlaceUpsize:
7515 {Is the next block binnable?}
7516 cmp eax, MinimumMediumBlockSize
7517 {Remove the next block}
7518 jb @MediumInPlaceNoNextRemove
7519 mov r14, rcx
7520 mov rcx, rdi
7521 mov rdi, rdx
7522 call RemoveMediumFreeBlock
7523 mov rcx, r14
7524 mov rdx, rdi
7525 @MediumInPlaceNoNextRemove:
7526 {Medium blocks grow a minimum of 25% in in-place upsizes}
7527 mov eax, ecx
7528 shr eax, 2
7529 add eax, ecx
7530 {Get the maximum of the requested size and the minimum growth size}
7531 xor edi, edi
7532 sub eax, edx
7533 adc edi, -1
7534 and eax, edi
7535 {Round up to the nearest block size granularity}
7536 lea eax, [eax + edx + BlockHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset]
7537 and eax, -MediumBlockGranularity
7538 add eax, MediumBlockSizeOffset
7539 {Calculate the size of the second split}
7540 lea rdx, [r15 + BlockHeaderSize]
7541 sub edx, eax
7542 {Does it fit?}
7543 ja @MediumInPlaceUpsizeSplit
7544 {Grab the whole block: Mark it as used in the block following it}
7545 and qword ptr [rsi + r15], not PreviousMediumBlockIsFreeFlag
7546 {The block size is the full available size plus header}
7547 add r15, BlockHeaderSize
7548 {Upsize done}
7549 jmp @MediumUpsizeInPlaceDone
7550 @MediumInPlaceUpsizeSplit:
7551 {Store the size of the second split as the second last dword}
7552 mov [rsi + r15 - BlockHeaderSize], rdx
7553 {Set the second split header}
7554 lea edi, [edx + IsMediumBlockFlag + IsFreeBlockFlag]
7555 mov [rsi + rax - BlockHeaderSize], rdi
7556 mov r15, rax
7557 cmp edx, MinimumMediumBlockSize
7558 jb @MediumUpsizeInPlaceDone
7559 lea rcx, [rsi + rax]
7560 call InsertMediumBlockIntoBin
7561 @MediumUpsizeInPlaceDone:
7562 {Set the size and flags for this block}
7563 or r15, rbx
7564 mov [rsi - BlockHeaderSize], r15
7565 {Unlock the medium blocks}
7566 lea rax, MediumBlocksLocked
7567 mov byte ptr [rax], False
7568 {Result = old pointer}
7569 mov rax, rsi
7570 jmp @Done
7571 @NextMediumBlockChanged:
7572 {The next medium block changed while the medium blocks were being locked}
7573 lea rax, MediumBlocksLocked
7574 mov byte ptr [rax], False
7575 @CannotUpsizeMediumBlockInPlace:
7576 {Couldn't upsize in place. Grab a new block and move the data across:
7577 If we have to reallocate and move medium blocks, we grow by at
7578 least 25%}
7579 mov eax, ecx
7580 shr eax, 2
7581 add eax, ecx
7582 {Get the maximum of the requested size and the minimum growth size}
7583 xor rdi, rdi
7584 sub rax, rdx
7585 adc rdi, -1
7586 and rax, rdi
7587 add rax, rdx
7588 {Save the size to allocate}
7589 mov r15, rax
7590 {Save the size to move across}
7591 mov edi, ecx
7592 {Save the requested size}
7593 mov rbx, rdx
7594 {Get the block}
7595 mov rcx, rax
7596 call FastGetMem
7597 mov rdx, rbx
7598 {Success?}
7599 test eax, eax
7600 jz @Done
7601 {If it's a Large block - store the actual user requested size}
7602 cmp r15, MaximumMediumBlockSize - BlockHeaderSize
7603 jbe @MediumUpsizeNotLarge
7604 mov [rax - 2 * BlockHeaderSize], rdx
7605 @MediumUpsizeNotLarge:
7606 {Save the result}
7607 mov r15, rax
7608 {Move the data across}
7609 mov rdx, rax
7610 mov rcx, rsi
7611 mov r8, rdi
7612 {$ifdef UseCustomVariableSizeMoveRoutines}
7613 call MoveX16LP
7614 {$else}
7615 call System.Move
7616 {$endif}
7617 {Free the old block}
7618 mov rcx, rsi
7619 call FastFreeMem
7620 {Restore the result}
7621 mov rax, r15
7622 jmp @Done
7623 @PossibleLargeBlock:
7624 {-----------------------Large block------------------------------}
7625 {Is this a valid large block?}
7626 test cl, IsFreeBlockFlag + IsMediumBlockFlag
7627 jnz @Error
7628 mov rcx, rsi
7629 call ReallocateLargeBlock
7630 jmp @Done
7631 {-----------------------Invalid block------------------------------}
7632 @Error:
7633 xor eax, eax
7634 @Done:
7635 end;
7636 {$endif}
7637 {$endif}
7638 {$endif}
7639
7640 {Allocates a block and fills it with zeroes}
FastAllocMemnull7641 function FastAllocMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Cardinal{$endif}): Pointer;
7642 {$ifndef ASMVersion}
7643 begin
7644 Result := FastGetMem(ASize);
7645 {Large blocks are already zero filled}
7646 if (Result <> nil) and (ASize <= (MaximumMediumBlockSize - BlockHeaderSize)) then
7647 FillChar(Result^, ASize, 0);
7648 end;
7649 {$else}
7650 {$ifdef 32Bit}
7651 asm
7652 push ebx
7653 {Get the size rounded down to the previous multiple of 4 into ebx}
7654 lea ebx, [eax - 1]
7655 and ebx, -4
7656 {Get the block}
7657 call FastGetMem
7658 {Could a block be allocated? ecx = 0 if yes, $ffffffff if no}
7659 cmp eax, 1
7660 sbb ecx, ecx
7661 {Point edx to the last dword}
7662 lea edx, [eax + ebx]
7663 {ebx = $ffffffff if no block could be allocated, otherwise size rounded down
7664 to previous multiple of 4. If ebx = 0 then the block size is 1..4 bytes and
7665 the FPU based clearing loop should not be used (since it clears 8 bytes per
7666 iteration).}
7667 or ebx, ecx
7668 jz @ClearLastDWord
7669 {Large blocks are already zero filled}
7670 cmp ebx, MaximumMediumBlockSize - BlockHeaderSize
7671 jae @Done
7672 {Make the counter negative based}
7673 neg ebx
7674 {Load zero into st(0)}
7675 fldz
7676 {Clear groups of 8 bytes. Block sizes are always four less than a multiple
7677 of 8.}
7678 @FillLoop:
7679 fst qword ptr [edx + ebx]
7680 add ebx, 8
7681 js @FillLoop
7682 {Clear st(0)}
7683 ffree st(0)
7684 {Correct the stack top}
7685 fincstp
7686 {Clear the last four bytes}
7687 @ClearLastDWord:
7688 mov [edx], ecx
7689 @Done:
7690 pop ebx
7691 end;
7692
7693 {$else}
7694
7695 {---------------64-bit BASM FastAllocMem---------------}
7696 asm
7697 .params 1
7698 .pushnv rbx
7699 {Get the size rounded down to the previous multiple of SizeOf(Pointer) into
7700 ebx}
7701 lea rbx, [rcx - 1]
7702 and rbx, -8
7703 {Get the block}
7704 call FastGetMem
7705 {Could a block be allocated? rcx = 0 if yes, -1 if no}
7706 cmp rax, 1
7707 sbb rcx, rcx
7708 {Point rdx to the last dword}
7709 lea rdx, [rax + rbx]
7710 {rbx = -1 if no block could be allocated, otherwise size rounded down
7711 to previous multiple of 8. If rbx = 0 then the block size is 1..8 bytes and
7712 the SSE2 based clearing loop should not be used (since it clears 16 bytes per
7713 iteration).}
7714 or rbx, rcx
7715 jz @ClearLastQWord
7716 {Large blocks are already zero filled}
7717 cmp rbx, MaximumMediumBlockSize - BlockHeaderSize
7718 jae @Done
7719 {Make the counter negative based}
7720 neg rbx
7721 {Load zero into xmm0}
7722 pxor xmm0, xmm0
7723 {Clear groups of 16 bytes. Block sizes are always 8 less than a multiple of
7724 16.}
7725 @FillLoop:
7726 movdqa [rdx + rbx], xmm0
7727 add rbx, 16
7728 js @FillLoop
7729 {Clear the last 8 bytes}
7730 @ClearLastQWord:
7731 xor rcx, rcx
7732 mov [rdx], rcx
7733 @Done:
7734 end;
7735 {$endif}
7736 {$endif}
7737
7738 {-----------------Post Uninstall GetMem/FreeMem/ReallocMem-------------------}
7739
7740 {$ifdef DetectMMOperationsAfterUninstall}
7741
InvalidGetMemnull7742 function InvalidGetMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer;
7743 {$ifndef NoMessageBoxes}
7744 var
7745 LErrorMessageTitle: array[0..1023] of AnsiChar;
7746 {$endif}
7747 begin
7748 {$ifdef UseOutputDebugString}
7749 OutputDebugStringA(InvalidGetMemMsg);
7750 {$endif}
7751 {$ifndef NoMessageBoxes}
7752 AppendStringToModuleName(InvalidOperationTitle, LErrorMessageTitle);
7753 ShowMessageBox(InvalidGetMemMsg, LErrorMessageTitle);
7754 {$endif}
7755 Result := nil;
7756 end;
7757
InvalidFreeMemnull7758 function InvalidFreeMem(APointer: Pointer): Integer;
7759 {$ifndef NoMessageBoxes}
7760 var
7761 LErrorMessageTitle: array[0..1023] of AnsiChar;
7762 {$endif}
7763 begin
7764 {$ifdef UseOutputDebugString}
7765 OutputDebugStringA(InvalidFreeMemMsg);
7766 {$endif}
7767 {$ifndef NoMessageBoxes}
7768 AppendStringToModuleName(InvalidOperationTitle, LErrorMessageTitle);
7769 ShowMessageBox(InvalidFreeMemMsg, LErrorMessageTitle);
7770 {$endif}
7771 Result := -1;
7772 end;
7773
InvalidReallocMemnull7774 function InvalidReallocMem(APointer: Pointer; ANewSize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer;
7775 {$ifndef NoMessageBoxes}
7776 var
7777 LErrorMessageTitle: array[0..1023] of AnsiChar;
7778 {$endif}
7779 begin
7780 {$ifdef UseOutputDebugString}
7781 OutputDebugStringA(InvalidReallocMemMsg);
7782 {$endif}
7783 {$ifndef NoMessageBoxes}
7784 AppendStringToModuleName(InvalidOperationTitle, LErrorMessageTitle);
7785 ShowMessageBox(InvalidReallocMemMsg, LErrorMessageTitle);
7786 {$endif}
7787 Result := nil;
7788 end;
7789
InvalidAllocMemnull7790 function InvalidAllocMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Cardinal{$endif}): Pointer;
7791 {$ifndef NoMessageBoxes}
7792 var
7793 LErrorMessageTitle: array[0..1023] of AnsiChar;
7794 {$endif}
7795 begin
7796 {$ifdef UseOutputDebugString}
7797 OutputDebugStringA(InvalidAllocMemMsg);
7798 {$endif}
7799 {$ifndef NoMessageBoxes}
7800 AppendStringToModuleName(InvalidOperationTitle, LErrorMessageTitle);
7801 ShowMessageBox(InvalidAllocMemMsg, LErrorMessageTitle);
7802 {$endif}
7803 Result := nil;
7804 end;
7805
InvalidRegisterAndUnRegisterMemoryLeaknull7806 function InvalidRegisterAndUnRegisterMemoryLeak(APointer: Pointer): Boolean;
7807 begin
7808 Result := False;
7809 end;
7810
7811 {$endif}
7812
7813 {-----------------Full Debug Mode Memory Manager Interface--------------------}
7814
7815 {$ifdef FullDebugMode}
7816
7817 {Compare [AAddress], CompareVal:
7818 If Equal: [AAddress] := NewVal and result = CompareVal
7819 If Unequal: Result := [AAddress]}
LockCmpxchg32null7820 function LockCmpxchg32(CompareVal, NewVal: Integer; AAddress: PInteger): Integer;
7821 asm
7822 {$ifdef 32Bit}
7823 {On entry:
7824 eax = CompareVal,
7825 edx = NewVal,
7826 ecx = AAddress}
7827 lock cmpxchg [ecx], edx
7828 {$else}
7829 .noframe
7830 {On entry:
7831 ecx = CompareVal,
7832 edx = NewVal,
7833 r8 = AAddress}
7834 mov eax, ecx
7835 lock cmpxchg [r8], edx
7836 {$endif}
7837 end;
7838
7839 {Called by DebugGetMem, DebugFreeMem and DebugReallocMem in order to block a
7840 free block scan operation while the memory pool is being modified.}
7841 procedure StartChangingFullDebugModeBlock;
7842 var
7843 LOldCount: Integer;
7844 begin
7845 while True do
7846 begin
7847 {Get the old thread count}
7848 LOldCount := ThreadsInFullDebugModeRoutine;
7849 if (LOldCount >= 0)
7850 and (LockCmpxchg32(LOldCount, LOldCount + 1, @ThreadsInFullDebugModeRoutine) = LOldCount) then
7851 begin
7852 Break;
7853 end;
7854 {$ifdef NeverSleepOnThreadContention}
7855 {$ifdef UseSwitchToThread}
7856 SwitchToThread;
7857 {$endif}
7858 {$else}
7859 Sleep(InitialSleepTime);
7860 {Try again}
7861 LOldCount := ThreadsInFullDebugModeRoutine;
7862 if (LOldCount >= 0)
7863 and (LockCmpxchg32(LOldCount, LOldCount + 1, @ThreadsInFullDebugModeRoutine) = LOldCount) then
7864 begin
7865 Break;
7866 end;
7867 Sleep(AdditionalSleepTime);
7868 {$endif}
7869 end;
7870 end;
7871
7872 procedure DoneChangingFullDebugModeBlock;
7873 asm
7874 {$ifdef 32Bit}
7875 lock dec ThreadsInFullDebugModeRoutine
7876 {$else}
7877 .noframe
7878 lea rax, ThreadsInFullDebugModeRoutine
7879 lock dec dword ptr [rax]
7880 {$endif}
7881 end;
7882
7883 {Increments the allocation number}
7884 procedure IncrementAllocationNumber;
7885 asm
7886 {$ifdef 32Bit}
7887 lock inc CurrentAllocationNumber
7888 {$else}
7889 .noframe
7890 lea rax, CurrentAllocationNumber
7891 lock inc dword ptr [rax]
7892 {$endif}
7893 end;
7894
7895 {Called by a routine wanting to lock the entire memory pool in FullDebugMode, e.g. before scanning the memory
7896 pool for corruptions.}
7897 procedure BlockFullDebugModeMMRoutines;
7898 begin
7899 while True do
7900 begin
7901 {Get the old thread count}
7902 if LockCmpxchg32(0, -1, @ThreadsInFullDebugModeRoutine) = 0 then
7903 Break;
7904 {$ifdef NeverSleepOnThreadContention}
7905 {$ifdef UseSwitchToThread}
7906 SwitchToThread;
7907 {$endif}
7908 {$else}
7909 Sleep(InitialSleepTime);
7910 {Try again}
7911 if LockCmpxchg32(0, -1, @ThreadsInFullDebugModeRoutine) = 0 then
7912 Break;
7913 Sleep(AdditionalSleepTime);
7914 {$endif}
7915 end;
7916 end;
7917
7918 procedure UnblockFullDebugModeMMRoutines;
7919 begin
7920 {Currently blocked? If so, unblock the FullDebugMode routines.}
7921 if ThreadsInFullDebugModeRoutine = -1 then
7922 ThreadsInFullDebugModeRoutine := 0;
7923 end;
7924
7925 procedure DeleteEventLog;
7926 begin
7927 {Delete the file}
7928 DeleteFileA(MMLogFileName);
7929 end;
7930
7931 {Finds the start and length of the file name given a full path.}
7932 procedure ExtractFileName(APFullPath: PAnsiChar; var APFileNameStart: PAnsiChar; var AFileNameLength: Integer);
7933 var
7934 LChar: AnsiChar;
7935 begin
7936 {Initialize}
7937 APFileNameStart := APFullPath;
7938 AFileNameLength := 0;
7939 {Find the file }
7940 while True do
7941 begin
7942 {Get the next character}
7943 LChar := APFullPath^;
7944 {End of the path string?}
7945 if LChar = #0 then
7946 Break;
7947 {Advance the buffer position}
7948 Inc(APFullPath);
7949 {Found a backslash? -> May be the start of the file name}
7950 if LChar = '\' then
7951 APFileNameStart := APFullPath;
7952 end;
7953 {Calculate the length of the file name}
7954 AFileNameLength := IntPtr(APFullPath) - IntPtr(APFileNameStart);
7955 end;
7956
7957 procedure AppendEventLog(ABuffer: Pointer; ACount: Cardinal);
7958 const
7959 {Declared here, because it is not declared in the SHFolder.pas unit of some older Delphi versions.}
7960 SHGFP_TYPE_CURRENT = 0;
7961 var
7962 LFileHandle, LBytesWritten: Cardinal;
7963 LEventHeader: array[0..1023] of AnsiChar;
7964 LAlternateLogFileName: array[0..2047] of AnsiChar;
7965 LPathLen, LNameLength: Integer;
7966 LMsgPtr, LPFileName: PAnsiChar;
7967 LSystemTime: TSystemTime;
7968 begin
7969 {Try to open the log file in read/write mode.}
7970 LFileHandle := CreateFileA(MMLogFileName, GENERIC_READ or GENERIC_WRITE,
7971 0, nil, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
7972 {Did log file creation fail? If so, the destination folder is perhaps read-only:
7973 Try to redirect logging to a file in the user's "My Documents" folder.}
7974 if (LFileHandle = INVALID_HANDLE_VALUE)
7975 {$ifdef Delphi4or5}
7976 and SHGetSpecialFolderPathA(0, @LAlternateLogFileName, CSIDL_PERSONAL, True) then
7977 {$else}
7978 and (SHGetFolderPathA(0, CSIDL_PERSONAL or CSIDL_FLAG_CREATE, 0,
7979 SHGFP_TYPE_CURRENT, @LAlternateLogFileName) = S_OK) then
7980 {$endif}
7981 begin
7982 {Extract the filename part from MMLogFileName and append it to the path of
7983 the "My Documents" folder.}
7984 LPathLen := StrLen(LAlternateLogFileName);
7985 {Ensure that there is a trailing backslash in the path}
7986 if (LPathLen = 0) or (LAlternateLogFileName[LPathLen - 1] <> '\') then
7987 begin
7988 LAlternateLogFileName[LPathLen] := '\';
7989 Inc(LPathLen);
7990 end;
7991 {Add the filename to the path}
7992 ExtractFileName(@MMLogFileName, LPFileName, LNameLength);
7993 System.Move(LPFileName^, LAlternateLogFileName[LPathLen], LNameLength + 1);
7994 {Try to open the alternate log file}
7995 LFileHandle := CreateFileA(LAlternateLogFileName, GENERIC_READ or GENERIC_WRITE,
7996 0, nil, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
7997 end;
7998 {Was the log file opened/created successfully?}
7999 if LFileHandle <> INVALID_HANDLE_VALUE then
8000 begin
8001 {Seek to the end of the file}
8002 SetFilePointer(LFileHandle, 0, nil, FILE_END);
8003 {Set the separator}
8004 LMsgPtr := AppendStringToBuffer(CRLF, @LEventHeader[0], Length(CRLF));
8005 LMsgPtr := AppendStringToBuffer(EventSeparator, LMsgPtr, Length(EventSeparator));
8006 {Set the date & time}
8007 GetLocalTime(LSystemTime);
8008 LMsgPtr := NativeUIntToStrBuf(LSystemTime.wYear, LMsgPtr);
8009 LMsgPtr^ := '/';
8010 Inc(LMsgPtr);
8011 LMsgPtr := NativeUIntToStrBuf(LSystemTime.wMonth, LMsgPtr);
8012 LMsgPtr^ := '/';
8013 Inc(LMsgPtr);
8014 LMsgPtr := NativeUIntToStrBuf(LSystemTime.wDay, LMsgPtr);
8015 LMsgPtr^ := ' ';
8016 Inc(LMsgPtr);
8017 LMsgPtr := NativeUIntToStrBuf(LSystemTime.wHour, LMsgPtr);
8018 LMsgPtr^ := ':';
8019 Inc(LMsgPtr);
8020 if LSystemTime.wMinute < 10 then
8021 begin
8022 LMsgPtr^ := '0';
8023 Inc(LMsgPtr);
8024 end;
8025 LMsgPtr := NativeUIntToStrBuf(LSystemTime.wMinute, LMsgPtr);
8026 LMsgPtr^ := ':';
8027 Inc(LMsgPtr);
8028 if LSystemTime.wSecond < 10 then
8029 begin
8030 LMsgPtr^ := '0';
8031 Inc(LMsgPtr);
8032 end;
8033 LMsgPtr := NativeUIntToStrBuf(LSystemTime.WSecond, LMsgPtr);
8034 {Write the header}
8035 LMsgPtr := AppendStringToBuffer(EventSeparator, LMsgPtr, Length(EventSeparator));
8036 LMsgPtr := AppendStringToBuffer(CRLF, LMsgPtr, Length(CRLF));
8037 WriteFile(LFileHandle, LEventHeader[0], NativeUInt(LMsgPtr) - NativeUInt(@LEventHeader[0]), LBytesWritten, nil);
8038 {Write the data}
8039 WriteFile(LFileHandle, ABuffer^, ACount, LBytesWritten, nil);
8040 {Close the file}
8041 CloseHandle(LFileHandle);
8042 end;
8043 end;
8044
8045 {Sets the default log filename}
8046 procedure SetDefaultMMLogFileName;
8047 const
8048 LogFileExtAnsi: PAnsiChar = LogFileExtension;
8049 var
8050 LEnvVarLength, LModuleNameLength: Cardinal;
8051 LPathOverride: array[0..2047] of AnsiChar;
8052 LPFileName: PAnsiChar;
8053 LFileNameLength: Integer;
8054 begin
8055 {Get the name of the application}
8056 LModuleNameLength := AppendModuleFileName(@MMLogFileName[0]);
8057 {Replace the last few characters of the module name, and optionally override
8058 the path.}
8059 if LModuleNameLength > 0 then
8060 begin
8061 {Change the filename}
8062 System.Move(LogFileExtAnsi^, MMLogFileName[LModuleNameLength - 4],
8063 StrLen(LogFileExtAnsi) + 1);
8064 {Try to read the FastMMLogFilePath environment variable}
8065 LEnvVarLength := GetEnvironmentVariableA('FastMMLogFilePath',
8066 @LPathOverride, 1023);
8067 {Does the environment variable exist? If so, override the log file path.}
8068 if LEnvVarLength > 0 then
8069 begin
8070 {Ensure that there's a trailing backslash.}
8071 if LPathOverride[LEnvVarLength - 1] <> '\' then
8072 begin
8073 LPathOverride[LEnvVarLength] := '\';
8074 Inc(LEnvVarLength);
8075 end;
8076 {Add the filename to the path override}
8077 ExtractFileName(@MMLogFileName[0], LPFileName, LFileNameLength);
8078 System.Move(LPFileName^, LPathOverride[LEnvVarLength], LFileNameLength + 1);
8079 {Copy the override path back to the filename buffer}
8080 System.Move(LPathOverride, MMLogFileName, SizeOf(MMLogFileName) - 1);
8081 end;
8082 end;
8083 end;
8084
8085 {Specify the full path and name for the filename to be used for logging memory
8086 errors, etc. If ALogFileName is nil or points to an empty string it will
8087 revert to the default log file name.}
8088 procedure SetMMLogFileName(ALogFileName: PAnsiChar = nil);
8089 var
8090 LLogFileNameLen: Integer;
8091 begin
8092 {Is ALogFileName valid?}
8093 if (ALogFileName <> nil) and (ALogFileName^ <> #0) then
8094 begin
8095 LLogFileNameLen := StrLen(ALogFileName);
8096 if LLogFileNameLen < Length(MMLogFileName) then
8097 begin
8098 {Set the log file name}
8099 System.Move(ALogFileName^, MMLogFileName, LLogFileNameLen + 1);
8100 Exit;
8101 end;
8102 end;
8103 {Invalid log file name}
8104 SetDefaultMMLogFileName;
8105 end;
8106
8107 {Returns the current "allocation group". Whenever a GetMem request is serviced
8108 in FullDebugMode, the current "allocation group" is stored in the block header.
8109 This may help with debugging. Note that if a block is subsequently reallocated
8110 that it keeps its original "allocation group" and "allocation number" (all
8111 allocations are also numbered sequentially).}
GetCurrentAllocationGroupnull8112 function GetCurrentAllocationGroup: Cardinal;
8113 begin
8114 Result := AllocationGroupStack[AllocationGroupStackTop];
8115 end;
8116
8117 {Allocation groups work in a stack like fashion. Group numbers are pushed onto
8118 and popped off the stack. Note that the stack size is limited, so every push
8119 should have a matching pop.}
8120 procedure PushAllocationGroup(ANewCurrentAllocationGroup: Cardinal);
8121 begin
8122 if AllocationGroupStackTop < AllocationGroupStackSize - 1 then
8123 begin
8124 Inc(AllocationGroupStackTop);
8125 AllocationGroupStack[AllocationGroupStackTop] := ANewCurrentAllocationGroup;
8126 end
8127 else
8128 begin
8129 {Raise a runtime error if the stack overflows}
8130 {$ifdef BCB6OrDelphi7AndUp}
8131 System.Error(reInvalidPtr);
8132 {$else}
8133 System.RunError(reInvalidPtr);
8134 {$endif}
8135 end;
8136 end;
8137
8138 procedure PopAllocationGroup;
8139 begin
8140 if AllocationGroupStackTop > 0 then
8141 begin
8142 Dec(AllocationGroupStackTop);
8143 end
8144 else
8145 begin
8146 {Raise a runtime error if the stack underflows}
8147 {$ifdef BCB6OrDelphi7AndUp}
8148 System.Error(reInvalidPtr);
8149 {$else}
8150 System.RunError(reInvalidPtr);
8151 {$endif}
8152 end;
8153 end;
8154
8155 {Sums all the dwords starting at the given address. ACount must be > 0 and a
8156 multiple of SizeOf(Pointer).}
SumNativeUIntsnull8157 function SumNativeUInts(AStartValue: NativeUInt; APointer: PNativeUInt;
8158 ACount: NativeUInt): NativeUInt;
8159 asm
8160 {$ifdef 32Bit}
8161 {On entry: eax = AStartValue, edx = APointer; ecx = ACount}
8162 add edx, ecx
8163 neg ecx
8164 @AddLoop:
8165 add eax, [edx + ecx]
8166 add ecx, 4
8167 js @AddLoop
8168 {$else}
8169 {On entry: rcx = AStartValue, rdx = APointer; r8 = ACount}
8170 add rdx, r8
8171 neg r8
8172 mov rax, rcx
8173 @AddLoop:
8174 add rax, [rdx + r8]
8175 add r8, 8
8176 js @AddLoop
8177 {$endif}
8178 end;
8179
8180 {Checks the memory starting at the given address for the fill pattern.
8181 Returns True if all bytes are all valid. ACount must be >0 and a multiple of
8182 SizeOf(Pointer).}
CheckFillPatternnull8183 function CheckFillPattern(APointer: Pointer; ACount: NativeUInt;
8184 AFillPattern: NativeUInt): Boolean;
8185 asm
8186 {$ifdef 32Bit}
8187 {On entry: eax = APointer; edx = ACount; ecx = AFillPattern}
8188 add eax, edx
8189 neg edx
8190 @CheckLoop:
8191 cmp [eax + edx], ecx
8192 jne @Done
8193 add edx, 4
8194 js @CheckLoop
8195 @Done:
8196 sete al
8197 {$else}
8198 {On entry: rcx = APointer; rdx = ACount; r8 = AFillPattern}
8199 add rcx, rdx
8200 neg rdx
8201 @CheckLoop:
8202 cmp [rcx + rdx], r8
8203 jne @Done
8204 add rdx, 8
8205 js @CheckLoop
8206 @Done:
8207 sete al
8208 {$endif}
8209 end;
8210
8211 {Calculates the checksum for the debug header. Adds all dwords in the debug
8212 header to the start address of the block.}
CalculateHeaderCheckSumnull8213 function CalculateHeaderCheckSum(APointer: PFullDebugBlockHeader): NativeUInt;
8214 begin
8215 Result := SumNativeUInts(
8216 NativeUInt(APointer),
8217 PNativeUInt(PByte(APointer) + 2 * SizeOf(Pointer)),
8218 SizeOf(TFullDebugBlockHeader) - 2 * SizeOf(Pointer) - SizeOf(NativeUInt));
8219 end;
8220
8221 procedure UpdateHeaderAndFooterCheckSums(APointer: PFullDebugBlockHeader);
8222 var
8223 LHeaderCheckSum: NativeUInt;
8224 begin
8225 LHeaderCheckSum := CalculateHeaderCheckSum(APointer);
8226 APointer.HeaderCheckSum := LHeaderCheckSum;
8227 PNativeUInt(PByte(APointer) + SizeOf(TFullDebugBlockHeader) + APointer.UserSize)^ := not LHeaderCheckSum;
8228 end;
8229
LogCurrentThreadAndStackTracenull8230 function LogCurrentThreadAndStackTrace(ASkipFrames: Cardinal; ABuffer: PAnsiChar): PAnsiChar;
8231 var
8232 LCurrentStackTrace: TStackTrace;
8233 begin
8234 {Get the current call stack}
8235 GetStackTrace(@LCurrentStackTrace[0], StackTraceDepth, ASkipFrames);
8236 {Log the thread ID}
8237 Result := AppendStringToBuffer(CurrentThreadIDMsg, ABuffer, Length(CurrentThreadIDMsg));
8238 Result := NativeUIntToHexBuf(GetThreadID, Result);
8239 {List the stack trace}
8240 Result := AppendStringToBuffer(CurrentStackTraceMsg, Result, Length(CurrentStackTraceMsg));
8241 Result := LogStackTrace(@LCurrentStackTrace, StackTraceDepth, Result);
8242 end;
8243
8244 {$ifndef DisableLoggingOfMemoryDumps}
LogMemoryDumpnull8245 function LogMemoryDump(APointer: PFullDebugBlockHeader; ABuffer: PAnsiChar): PAnsiChar;
8246 var
8247 LByteNum, LVal: Cardinal;
8248 LDataPtr: PByte;
8249 begin
8250 Result := AppendStringToBuffer(MemoryDumpMsg, ABuffer, Length(MemoryDumpMsg));
8251 Result := NativeUIntToHexBuf(NativeUInt(APointer) + SizeOf(TFullDebugBlockHeader), Result);
8252 Result^ := ':';
8253 Inc(Result);
8254 {Add the bytes}
8255 LDataPtr := PByte(PByte(APointer) + SizeOf(TFullDebugBlockHeader));
8256 for LByteNum := 0 to 255 do
8257 begin
8258 if LByteNum and 31 = 0 then
8259 begin
8260 Result^ := #13;
8261 Inc(Result);
8262 Result^ := #10;
8263 Inc(Result);
8264 end
8265 else
8266 begin
8267 Result^ := ' ';
8268 Inc(Result);
8269 end;
8270 {Set the hex data}
8271 LVal := Byte(LDataPtr^);
8272 Result^ := HexTable[LVal shr 4];
8273 Inc(Result);
8274 Result^ := HexTable[LVal and $f];
8275 Inc(Result);
8276 {Next byte}
8277 Inc(LDataPtr);
8278 end;
8279 {Dump ASCII}
8280 LDataPtr := PByte(PByte(APointer) + SizeOf(TFullDebugBlockHeader));
8281 for LByteNum := 0 to 255 do
8282 begin
8283 if LByteNum and 31 = 0 then
8284 begin
8285 Result^ := #13;
8286 Inc(Result);
8287 Result^ := #10;
8288 Inc(Result);
8289 end
8290 else
8291 begin
8292 Result^ := ' ';
8293 Inc(Result);
8294 Result^ := ' ';
8295 Inc(Result);
8296 end;
8297 {Set the hex data}
8298 LVal := Byte(LDataPtr^);
8299 if LVal < 32 then
8300 Result^ := '.'
8301 else
8302 Result^ := AnsiChar(LVal);
8303 Inc(Result);
8304 {Next byte}
8305 Inc(LDataPtr);
8306 end;
8307 end;
8308 {$endif}
8309
8310 {Rotates AValue ABitCount bits to the right}
RotateRightnull8311 function RotateRight(AValue, ABitCount: NativeUInt): NativeUInt;
8312 asm
8313 {$ifdef 32Bit}
8314 mov ecx, edx
8315 ror eax, cl
8316 {$else}
8317 mov rax, rcx
8318 mov rcx, rdx
8319 ror rax, cl
8320 {$endif}
8321 end;
8322
8323 {Determines whether a byte in the user portion of the freed block has been modified. Does not work beyond
8324 the end of the user portion (i.e. footer and beyond).}
FreeBlockByteWasModifiednull8325 function FreeBlockByteWasModified(APointer: PFullDebugBlockHeader; AUserOffset: NativeUInt): Boolean;
8326 var
8327 LFillPattern: NativeUInt;
8328 begin
8329 {Get the expected fill pattern}
8330 if AUserOffset < SizeOf(Pointer) then
8331 begin
8332 LFillPattern := NativeUInt(@FreedObjectVMT.VMTMethods[0]);
8333 end
8334 else
8335 begin
8336 {$ifndef CatchUseOfFreedInterfaces}
8337 LFillPattern := DebugFillPattern;
8338 {$else}
8339 LFillPattern := NativeUInt(@VMTBadInterface);
8340 {$endif}
8341 end;
8342 {Compare the byte value}
8343 Result := Byte(PByte(PByte(APointer) + SizeOf(TFullDebugBlockHeader) + AUserOffset)^) <>
8344 Byte(RotateRight(LFillPattern, (AUserOffset and (SizeOf(Pointer) - 1)) * 8));
8345 end;
8346
LogBlockChangesnull8347 function LogBlockChanges(APointer: PFullDebugBlockHeader; ABuffer: PAnsiChar): PAnsiChar;
8348 var
8349 LOffset, LChangeStart, LCount: NativeUInt;
8350 LLogCount: Integer;
8351 begin
8352 {No errors logged so far}
8353 LLogCount := 0;
8354 {Log a maximum of 32 changes}
8355 LOffset := 0;
8356 while (LOffset < APointer.UserSize) and (LLogCount < 32) do
8357 begin
8358 {Has the byte been modified?}
8359 if FreeBlockByteWasModified(APointer, LOffset) then
8360 begin
8361 {Found the start of a changed block, now find the length}
8362 LChangeStart := LOffset;
8363 LCount := 0;
8364 while True do
8365 begin
8366 Inc(LCount);
8367 Inc(LOffset);
8368 if (LOffset >= APointer.UserSize)
8369 or (not FreeBlockByteWasModified(APointer, LOffset)) then
8370 begin
8371 Break;
8372 end;
8373 end;
8374 {Got the offset and length, now log it.}
8375 if LLogCount = 0 then
8376 begin
8377 ABuffer := AppendStringToBuffer(FreeModifiedDetailMsg, ABuffer, Length(FreeModifiedDetailMsg));
8378 end
8379 else
8380 begin
8381 ABuffer^ := ',';
8382 Inc(ABuffer);
8383 ABuffer^ := ' ';
8384 Inc(ABuffer);
8385 end;
8386 ABuffer := NativeUIntToStrBuf(LChangeStart, ABuffer);
8387 ABuffer^ := '(';
8388 Inc(ABuffer);
8389 ABuffer := NativeUIntToStrBuf(LCount, ABuffer);
8390 ABuffer^ := ')';
8391 Inc(ABuffer);
8392 {Increment the log count}
8393 Inc(LLogCount);
8394 end;
8395 {Next byte}
8396 Inc(LOffset);
8397 end;
8398 {Return the current buffer position}
8399 Result := ABuffer;
8400 end;
8401
8402 procedure LogBlockError(APointer: PFullDebugBlockHeader; AOperation: TBlockOperation; LHeaderValid, LFooterValid: Boolean);
8403 var
8404 LMsgPtr: PAnsiChar;
8405 LErrorMessage: array[0..32767] of AnsiChar;
8406 {$ifndef NoMessageBoxes}
8407 LErrorMessageTitle: array[0..1023] of AnsiChar;
8408 {$endif}
8409 LClass: TClass;
8410 {$ifdef CheckCppObjectTypeEnabled}
8411 LCppObjectTypeName: PAnsiChar;
8412 {$endif}
8413 begin
8414 {Display the error header and the operation type.}
8415 LMsgPtr := AppendStringToBuffer(ErrorMsgHeader, @LErrorMessage[0], Length(ErrorMsgHeader));
8416 case AOperation of
8417 boGetMem: LMsgPtr := AppendStringToBuffer(GetMemMsg, LMsgPtr, Length(GetMemMsg));
8418 boFreeMem: LMsgPtr := AppendStringToBuffer(FreeMemMsg, LMsgPtr, Length(FreeMemMsg));
8419 boReallocMem: LMsgPtr := AppendStringToBuffer(ReallocMemMsg, LMsgPtr, Length(ReallocMemMsg));
8420 boBlockCheck: LMsgPtr := AppendStringToBuffer(BlockCheckMsg, LMsgPtr, Length(BlockCheckMsg));
8421 end;
8422 LMsgPtr := AppendStringToBuffer(OperationMsg, LMsgPtr, Length(OperationMsg));
8423 {Is the header still intact?}
8424 if LHeaderValid then
8425 begin
8426 {Is the footer still valid?}
8427 if LFooterValid then
8428 begin
8429 {A freed block has been modified, a double free has occurred, or an
8430 attempt was made to free a memory block allocated by a different
8431 instance of FastMM.}
8432 if AOperation <= boGetMem then
8433 begin
8434 LMsgPtr := AppendStringToBuffer(FreeModifiedErrorMsg, LMsgPtr, Length(FreeModifiedErrorMsg));
8435 {Log the exact changes that caused the error.}
8436 LMsgPtr := LogBlockChanges(APointer, LMsgPtr);
8437 end
8438 else
8439 begin
8440 {It is either a double free, or an attempt was made to free a block
8441 that was allocated via a different memory manager.}
8442 if APointer.AllocatedByRoutine = nil then
8443 LMsgPtr := AppendStringToBuffer(DoubleFreeErrorMsg, LMsgPtr, Length(DoubleFreeErrorMsg))
8444 else
8445 LMsgPtr := AppendStringToBuffer(WrongMMFreeErrorMsg, LMsgPtr, Length(WrongMMFreeErrorMsg));
8446 end;
8447 end
8448 else
8449 begin
8450 LMsgPtr := AppendStringToBuffer(BlockFooterCorruptedMsg, LMsgPtr, Length(BlockFooterCorruptedMsg))
8451 end;
8452 {Set the block size message}
8453 if AOperation <= boGetMem then
8454 LMsgPtr := AppendStringToBuffer(PreviousBlockSizeMsg, LMsgPtr, Length(PreviousBlockSizeMsg))
8455 else
8456 LMsgPtr := AppendStringToBuffer(CurrentBlockSizeMsg, LMsgPtr, Length(CurrentBlockSizeMsg));
8457 LMsgPtr := NativeUIntToStrBuf(APointer.UserSize, LMsgPtr);
8458 {The header is still intact - display info about the this/previous allocation}
8459 if APointer.AllocationStackTrace[0] <> 0 then
8460 begin
8461 if AOperation <= boGetMem then
8462 LMsgPtr := AppendStringToBuffer(ThreadIDPrevAllocMsg, LMsgPtr, Length(ThreadIDPrevAllocMsg))
8463 else
8464 LMsgPtr := AppendStringToBuffer(ThreadIDAtAllocMsg, LMsgPtr, Length(ThreadIDAtAllocMsg));
8465 LMsgPtr := NativeUIntToHexBuf(APointer.AllocatedByThread, LMsgPtr);
8466 LMsgPtr := AppendStringToBuffer(StackTraceMsg, LMsgPtr, Length(StackTraceMsg));
8467 LMsgPtr := LogStackTrace(@APointer.AllocationStackTrace, StackTraceDepth, LMsgPtr);
8468 end;
8469 {Get the class this block was used for previously}
8470 LClass := DetectClassInstance(@APointer.PreviouslyUsedByClass);
8471 if (LClass <> nil) and (IntPtr(LClass) <> IntPtr(@FreedObjectVMT.VMTMethods[0])) then
8472 begin
8473 LMsgPtr := AppendStringToBuffer(PreviousObjectClassMsg, LMsgPtr, Length(PreviousObjectClassMsg));
8474 LMsgPtr := AppendClassNameToBuffer(LClass, LMsgPtr);
8475 end;
8476 {$ifdef CheckCppObjectTypeEnabled}
8477 if (LClass = nil) and Assigned(GetCppVirtObjTypeNameByVTablePtrFunc) then
8478 begin
8479 LCppObjectTypeName := GetCppVirtObjTypeNameByVTablePtrFunc(Pointer(APointer.PreviouslyUsedByClass), 0);
8480 if Assigned(LCppObjectTypeName) then
8481 begin
8482 LMsgPtr := AppendStringToBuffer(PreviousObjectClassMsg, LMsgPtr, Length(PreviousObjectClassMsg));
8483 LMsgPtr := AppendStringToBuffer(LCppObjectTypeName, LMsgPtr, StrLen(LCppObjectTypeName));
8484 end;
8485 end;
8486 {$endif}
8487 {Get the current class for this block}
8488 if (AOperation > boGetMem) and (APointer.AllocatedByRoutine <> nil) then
8489 begin
8490 LMsgPtr := AppendStringToBuffer(CurrentObjectClassMsg, LMsgPtr, Length(CurrentObjectClassMsg));
8491 LClass := DetectClassInstance(Pointer(PByte(APointer) + SizeOf(TFullDebugBlockHeader)));
8492 if IntPtr(LClass) = IntPtr(@FreedObjectVMT.VMTMethods[0]) then
8493 LClass := nil;
8494 {$ifndef CheckCppObjectTypeEnabled}
8495 LMsgPtr := AppendClassNameToBuffer(LClass, LMsgPtr);
8496 {$else}
8497 if (LClass = nil) and Assigned(GetCppVirtObjTypeNameFunc) then
8498 begin
8499 LCppObjectTypeName := GetCppVirtObjTypeNameFunc(Pointer(PByte(APointer) + SizeOf(TFullDebugBlockHeader)),
8500 APointer.UserSize);
8501 if LCppObjectTypeName <> nil then
8502 LMsgPtr := AppendStringToBuffer(LCppObjectTypeName, LMsgPtr, StrLen(LCppObjectTypeName))
8503 else
8504 LMsgPtr := AppendClassNameToBuffer(LClass, LMsgPtr);
8505 end
8506 else
8507 begin
8508 LMsgPtr := AppendClassNameToBuffer(LClass, LMsgPtr);
8509 end;
8510 {$endif}
8511 {Log the allocation group}
8512 if APointer.AllocationGroup > 0 then
8513 begin
8514 LMsgPtr := AppendStringToBuffer(CurrentAllocationGroupMsg, LMsgPtr, Length(CurrentAllocationGroupMsg));
8515 LMsgPtr := NativeUIntToStrBuf(APointer.AllocationGroup, LMsgPtr);
8516 end;
8517 {Log the allocation number}
8518 LMsgPtr := AppendStringToBuffer(CurrentAllocationNumberMsg, LMsgPtr, Length(CurrentAllocationNumberMsg));
8519 LMsgPtr := NativeUIntToStrBuf(APointer.AllocationNumber, LMsgPtr);
8520 end
8521 else
8522 begin
8523 {Log the allocation group}
8524 if APointer.AllocationGroup > 0 then
8525 begin
8526 LMsgPtr := AppendStringToBuffer(PreviousAllocationGroupMsg, LMsgPtr, Length(PreviousAllocationGroupMsg));
8527 LMsgPtr := NativeUIntToStrBuf(APointer.AllocationGroup, LMsgPtr);
8528 end;
8529 {Log the allocation number}
8530 LMsgPtr := AppendStringToBuffer(PreviousAllocationNumberMsg, LMsgPtr, Length(PreviousAllocationNumberMsg));
8531 LMsgPtr := NativeUIntToStrBuf(APointer.AllocationNumber, LMsgPtr);
8532 end;
8533 {Get the call stack for the previous free}
8534 if APointer.FreeStackTrace[0] <> 0 then
8535 begin
8536 LMsgPtr := AppendStringToBuffer(ThreadIDAtFreeMsg, LMsgPtr, Length(ThreadIDAtFreeMsg));
8537 LMsgPtr := NativeUIntToHexBuf(APointer.FreedByThread, LMsgPtr);
8538 LMsgPtr := AppendStringToBuffer(StackTraceMsg, LMsgPtr, Length(StackTraceMsg));
8539 LMsgPtr := LogStackTrace(@APointer.FreeStackTrace, StackTraceDepth, LMsgPtr);
8540 end;
8541 end
8542 else
8543 begin
8544 {Header has been corrupted}
8545 LMsgPtr := AppendStringToBuffer(BlockHeaderCorruptedMsg, LMsgPtr, Length(BlockHeaderCorruptedMsg));
8546 end;
8547 {Add the current stack trace}
8548 LMsgPtr := LogCurrentThreadAndStackTrace(3 + Ord(AOperation <> boGetMem) + Ord(AOperation = boReallocMem), LMsgPtr);
8549 {$ifndef DisableLoggingOfMemoryDumps}
8550 {Add the memory dump}
8551 LMsgPtr := LogMemoryDump(APointer, LMsgPtr);
8552 {$endif}
8553 {Trailing CRLF}
8554 LMsgPtr^ := #13;
8555 Inc(LMsgPtr);
8556 LMsgPtr^ := #10;
8557 Inc(LMsgPtr);
8558 {Trailing #0}
8559 LMsgPtr^ := #0;
8560 {$ifdef LogErrorsToFile}
8561 {Log the error}
8562 AppendEventLog(@LErrorMessage[0], NativeUInt(LMsgPtr) - NativeUInt(@LErrorMessage[0]));
8563 {$endif}
8564 {$ifdef UseOutputDebugString}
8565 OutputDebugStringA(LErrorMessage);
8566 {$endif}
8567 {Show the message}
8568 {$ifndef NoMessageBoxes}
8569 AppendStringToModuleName(BlockErrorMsgTitle, LErrorMessageTitle);
8570 ShowMessageBox(LErrorMessage, LErrorMessageTitle);
8571 {$endif}
8572 end;
8573
8574 {Logs the stack traces for a memory leak to file}
8575 procedure LogMemoryLeakOrAllocatedBlock(APointer: PFullDebugBlockHeader; IsALeak: Boolean);
8576 var
8577 LHeaderValid: Boolean;
8578 LMsgPtr: PAnsiChar;
8579 LErrorMessage: array[0..32767] of AnsiChar;
8580 LClass: TClass;
8581 {$ifdef CheckCppObjectTypeEnabled}
8582 LCppObjectTypeName: PAnsiChar;
8583 {$endif}
8584 begin
8585 {Display the error header and the operation type.}
8586 if IsALeak then
8587 LMsgPtr := AppendStringToBuffer(LeakLogHeader, @LErrorMessage[0], Length(LeakLogHeader))
8588 else
8589 LMsgPtr := AppendStringToBuffer(BlockScanLogHeader, @LErrorMessage[0], Length(BlockScanLogHeader));
8590 LMsgPtr := NativeUIntToStrBuf(GetAvailableSpaceInBlock(APointer) - FullDebugBlockOverhead, LMsgPtr);
8591 {Is the debug info surrounding the block valid?}
8592 LHeaderValid := CalculateHeaderCheckSum(APointer) = APointer.HeaderCheckSum;
8593 {Is the header still intact?}
8594 if LHeaderValid then
8595 begin
8596 {The header is still intact - display info about this/previous allocation}
8597 if APointer.AllocationStackTrace[0] <> 0 then
8598 begin
8599 LMsgPtr := AppendStringToBuffer(ThreadIDAtAllocMsg, LMsgPtr, Length(ThreadIDAtAllocMsg));
8600 LMsgPtr := NativeUIntToHexBuf(APointer.AllocatedByThread, LMsgPtr);
8601 LMsgPtr := AppendStringToBuffer(StackTraceMsg, LMsgPtr, Length(StackTraceMsg));
8602 LMsgPtr := LogStackTrace(@APointer.AllocationStackTrace, StackTraceDepth, LMsgPtr);
8603 end;
8604 LMsgPtr := AppendStringToBuffer(CurrentObjectClassMsg, LMsgPtr, Length(CurrentObjectClassMsg));
8605 {Get the current class for this block}
8606 LClass := DetectClassInstance(Pointer(PByte(APointer) + SizeOf(TFullDebugBlockHeader)));
8607 if IntPtr(LClass) = IntPtr(@FreedObjectVMT.VMTMethods[0]) then
8608 LClass := nil;
8609 {$ifndef CheckCppObjectTypeEnabled}
8610 if LClass <> nil then
8611 begin
8612 LMsgPtr := AppendClassNameToBuffer(LClass, LMsgPtr);
8613 end
8614 else
8615 begin
8616 case DetectStringData(Pointer(PByte(APointer) + SizeOf(TFullDebugBlockHeader)), APointer.UserSize) of
8617 stUnknown: LMsgPtr := AppendClassNameToBuffer(nil, LMsgPtr);
8618 stAnsiString: LMsgPtr := AppendStringToBuffer(AnsiStringBlockMessage, LMsgPtr, Length(AnsiStringBlockMessage));
8619 stUnicodeString: LMsgPtr := AppendStringToBuffer(UnicodeStringBlockMessage, LMsgPtr, Length(UnicodeStringBlockMessage));
8620 end;
8621 end;
8622 {$else}
8623 if (LClass = nil) and Assigned(GetCppVirtObjTypeNameFunc) then
8624 begin
8625 LCppObjectTypeName := GetCppVirtObjTypeNameFunc(Pointer(PByte(APointer) + SizeOf(TFullDebugBlockHeader)),
8626 APointer.UserSize);
8627 if LCppObjectTypeName <> nil then
8628 LMsgPtr := AppendStringToBuffer(LCppObjectTypeName, LMsgPtr, StrLen(LCppObjectTypeName))
8629 else
8630 begin
8631 case DetectStringData(Pointer(PByte(APointer) + SizeOf(TFullDebugBlockHeader)), APointer.UserSize) of
8632 stUnknown: LMsgPtr := AppendClassNameToBuffer(nil, LMsgPtr);
8633 stAnsiString: LMsgPtr := AppendStringToBuffer(AnsiStringBlockMessage, LMsgPtr, Length(AnsiStringBlockMessage));
8634 stUnicodeString: LMsgPtr := AppendStringToBuffer(UnicodeStringBlockMessage, LMsgPtr, Length(UnicodeStringBlockMessage));
8635 end;
8636 end;
8637 end
8638 else
8639 LMsgPtr := AppendClassNameToBuffer(LClass, LMsgPtr);
8640 {$endif}
8641 {Log the allocation group}
8642 if APointer.AllocationGroup > 0 then
8643 begin
8644 LMsgPtr := AppendStringToBuffer(CurrentAllocationGroupMsg, LMsgPtr, Length(CurrentAllocationGroupMsg));
8645 LMsgPtr := NativeUIntToStrBuf(APointer.AllocationGroup, LMsgPtr);
8646 end;
8647 {Log the allocation number}
8648 LMsgPtr := AppendStringToBuffer(CurrentAllocationNumberMsg, LMsgPtr, Length(CurrentAllocationNumberMsg));
8649 LMsgPtr := NativeUIntToStrBuf(APointer.AllocationNumber, LMsgPtr);
8650 end
8651 else
8652 begin
8653 {Header has been corrupted}
8654 LMsgPtr^ := '.';
8655 Inc(LMsgPtr);
8656 LMsgPtr^ := ' ';
8657 Inc(LMsgPtr);
8658 LMsgPtr := AppendStringToBuffer(BlockHeaderCorruptedMsg, LMsgPtr, Length(BlockHeaderCorruptedMsg));
8659 end;
8660 {$ifndef DisableLoggingOfMemoryDumps}
8661 {Add the memory dump}
8662 LMsgPtr := LogMemoryDump(APointer, LMsgPtr);
8663 {$endif}
8664 {Trailing CRLF}
8665 LMsgPtr^ := #13;
8666 Inc(LMsgPtr);
8667 LMsgPtr^ := #10;
8668 Inc(LMsgPtr);
8669 {Trailing #0}
8670 LMsgPtr^ := #0;
8671 {Log the error}
8672 AppendEventLog(@LErrorMessage[0], NativeUInt(LMsgPtr) - NativeUInt(@LErrorMessage[0]));
8673 end;
8674
8675 {Checks that a free block is unmodified}
CheckFreeBlockUnmodifiednull8676 function CheckFreeBlockUnmodified(APBlock: PFullDebugBlockHeader; ABlockSize: NativeUInt;
8677 AOperation: TBlockOperation): Boolean;
8678 var
8679 LHeaderCheckSum: NativeUInt;
8680 LHeaderValid, LFooterValid, LBlockUnmodified: Boolean;
8681 begin
8682 LHeaderCheckSum := CalculateHeaderCheckSum(APBlock);
8683 LHeaderValid := LHeaderCheckSum = APBlock.HeaderCheckSum;
8684 {Is the footer itself still in place}
8685 LFooterValid := LHeaderValid
8686 and (PNativeUInt(PByte(APBlock) + SizeOf(TFullDebugBlockHeader) + APBlock.UserSize)^ = (not LHeaderCheckSum));
8687 {Is the footer and debug VMT in place? The debug VMT is only valid if the user size is greater than the size of a pointer.}
8688 if LFooterValid
8689 and (APBlock.UserSize < SizeOf(Pointer)) or (PNativeUInt(PByte(APBlock) + SizeOf(TFullDebugBlockHeader))^ = NativeUInt(@FreedObjectVMT.VMTMethods[0])) then
8690 begin
8691 {Store the debug fill pattern in place of the footer in order to simplify
8692 checking for block modifications.}
8693 PNativeUInt(PByte(APBlock) + SizeOf(TFullDebugBlockHeader) + APBlock.UserSize)^ :=
8694 {$ifndef CatchUseOfFreedInterfaces}
8695 DebugFillPattern;
8696 {$else}
8697 RotateRight(NativeUInt(@VMTBadInterface), (APBlock.UserSize and (SizeOf(Pointer) - 1)) * 8);
8698 {$endif}
8699 {Check that all the filler bytes are valid inside the block, except for
8700 the "dummy" class header}
8701 LBlockUnmodified := CheckFillPattern(PNativeUInt(PByte(APBlock) + (SizeOf(TFullDebugBlockHeader) + SizeOf(Pointer))),
8702 ABlockSize - (FullDebugBlockOverhead + SizeOf(Pointer)),
8703 {$ifndef CatchUseOfFreedInterfaces}DebugFillPattern{$else}NativeUInt(@VMTBadInterface){$endif});
8704 {Reset the old footer}
8705 PNativeUInt(PByte(APBlock) + SizeOf(TFullDebugBlockHeader) + APBlock.UserSize)^ := not LHeaderCheckSum;
8706 end
8707 else
8708 LBlockUnmodified := False;
8709 if (not LHeaderValid) or (not LFooterValid) or (not LBlockUnmodified) then
8710 begin
8711 LogBlockError(APBlock, AOperation, LHeaderValid, LFooterValid);
8712 Result := False;
8713 end
8714 else
8715 Result := True;
8716 end;
8717
DebugGetMemnull8718 function DebugGetMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer;
8719 begin
8720 {Scan the entire memory pool first?}
8721 if FullDebugModeScanMemoryPoolBeforeEveryOperation then
8722 ScanMemoryPoolForCorruptions;
8723 {Enter the memory manager: block scans may not be performed now}
8724 StartChangingFullDebugModeBlock;
8725 try
8726 {We need extra space for (a) The debug header, (b) the block debug trailer
8727 and (c) the trailing block size pointer for free blocks}
8728 Result := FastGetMem(ASize + FullDebugBlockOverhead);
8729 if Result <> nil then
8730 begin
8731 {Large blocks are always newly allocated (and never reused), so checking
8732 for a modify-after-free is not necessary.}
8733 if (ASize > (MaximumMediumBlockSize - BlockHeaderSize - FullDebugBlockOverhead))
8734 or CheckFreeBlockUnmodified(Result, GetAvailableSpaceInBlock(Result) + BlockHeaderSize, boGetMem) then
8735 begin
8736 {Set the allocation call stack}
8737 GetStackTrace(@PFullDebugBlockHeader(Result).AllocationStackTrace, StackTraceDepth, 1);
8738 {Set the thread ID of the thread that allocated the block}
8739 PFullDebugBlockHeader(Result).AllocatedByThread := GetThreadID;
8740 {Block is now in use: It was allocated by this routine}
8741 PFullDebugBlockHeader(Result).AllocatedByRoutine := @DebugGetMem;
8742 {Set the group number}
8743 PFullDebugBlockHeader(Result).AllocationGroup := AllocationGroupStack[AllocationGroupStackTop];
8744 {Set the allocation number}
8745 IncrementAllocationNumber;
8746 PFullDebugBlockHeader(Result).AllocationNumber := CurrentAllocationNumber;
8747 {Clear the previous block trailer}
8748 PNativeUInt(PByte(Result) + SizeOf(TFullDebugBlockHeader) + PFullDebugBlockHeader(Result).UserSize)^ :=
8749 {$ifndef CatchUseOfFreedInterfaces}
8750 DebugFillPattern;
8751 {$else}
8752 RotateRight(NativeUInt(@VMTBadInterface), (PFullDebugBlockHeader(Result).UserSize and (SizeOf(Pointer) - 1)) * 8);
8753 {$endif}
8754 {Set the user size for the block}
8755 PFullDebugBlockHeader(Result).UserSize := ASize;
8756 {Set the checksums}
8757 UpdateHeaderAndFooterCheckSums(Result);
8758 {$ifdef FullDebugModeCallBacks}
8759 if Assigned(OnDebugGetMemFinish) then
8760 OnDebugGetMemFinish(PFullDebugBlockHeader(Result), ASize);
8761 {$endif}
8762 {Return the start of the actual block}
8763 Result := Pointer(PByte(Result) + SizeOf(TFullDebugBlockHeader));
8764 {$ifdef EnableMemoryLeakReporting}
8765 {Should this block be marked as an expected leak automatically?}
8766 if FullDebugModeRegisterAllAllocsAsExpectedMemoryLeak then
8767 RegisterExpectedMemoryLeak(Result);
8768 {$endif}
8769 end
8770 else
8771 begin
8772 Result := nil;
8773 end;
8774 end;
8775 finally
8776 {Leaving the memory manager routine: Block scans may be performed again.}
8777 DoneChangingFullDebugModeBlock;
8778 end;
8779 end;
8780
CheckBlockBeforeFreeOrReallocnull8781 function CheckBlockBeforeFreeOrRealloc(APBlock: PFullDebugBlockHeader;
8782 AOperation: TBlockOperation): Boolean;
8783 var
8784 LHeaderValid, LFooterValid: Boolean;
8785 LPFooter: PNativeUInt;
8786 {$ifndef CatchUseOfFreedInterfaces}
8787 LBlockSize: NativeUInt;
8788 LPTrailingByte, LPFillPatternEnd: PByte;
8789 {$endif}
8790 begin
8791 {Is the checksum for the block header valid?}
8792 LHeaderValid := CalculateHeaderCheckSum(APBlock) = APBlock.HeaderCheckSum;
8793 {If the header is corrupted then the footer is assumed to be corrupt too.}
8794 if LHeaderValid then
8795 begin
8796 {Check the footer checksum: The footer checksum should equal the header
8797 checksum with all bits inverted.}
8798 LPFooter := PNativeUInt(PByte(APBlock) + SizeOf(TFullDebugBlockHeader) + PFullDebugBlockHeader(APBlock).UserSize);
8799 if APBlock.HeaderCheckSum = (not (LPFooter^)) then
8800 begin
8801 LFooterValid := True;
8802 {$ifndef CatchUseOfFreedInterfaces}
8803 {Large blocks do not have the debug fill pattern, since they are never reused.}
8804 if PNativeUInt(PByte(APBlock) - BlockHeaderSize)^ and (IsMediumBlockFlag or IsLargeBlockFlag) <> IsLargeBlockFlag then
8805 begin
8806 {Check that the application has not modified bytes beyond the block
8807 footer. The $80 fill pattern should extend up to 2 nativeints before
8808 the start of the next block (leaving space for the free block size and
8809 next block header.)}
8810 LBlockSize := GetAvailableSpaceInBlock(APBlock);
8811 LPFillPatternEnd := PByte(PByte(APBlock) + LBlockSize - SizeOf(Pointer));
8812 LPTrailingByte := PByte(PByte(LPFooter) + SizeOf(NativeUInt));
8813 while UIntPtr(LPTrailingByte) < UIntPtr(LPFillPatternEnd) do
8814 begin
8815 if Byte(LPTrailingByte^) <> DebugFillByte then
8816 begin
8817 LFooterValid := False;
8818 Break;
8819 end;
8820 Inc(LPTrailingByte);
8821 end;
8822 end;
8823 {$endif}
8824 end
8825 else
8826 LFooterValid := False;
8827 end
8828 else
8829 LFooterValid := False;
8830 {The header and footer must be intact and the block must have been allocated
8831 by this memory manager instance.}
8832 if LFooterValid and (APBlock.AllocatedByRoutine = @DebugGetMem) then
8833 begin
8834 Result := True;
8835 end
8836 else
8837 begin
8838 {Log the error}
8839 LogBlockError(APBlock, AOperation, LHeaderValid, LFooterValid);
8840 {Return an error}
8841 Result := False;
8842 end;
8843 end;
8844
DebugFreeMemnull8845 function DebugFreeMem(APointer: Pointer): Integer;
8846 var
8847 LActualBlock: PFullDebugBlockHeader;
8848 LBlockHeader: NativeUInt;
8849 begin
8850 {Scan the entire memory pool first?}
8851 if FullDebugModeScanMemoryPoolBeforeEveryOperation then
8852 ScanMemoryPoolForCorruptions;
8853 {Get a pointer to the start of the actual block}
8854 LActualBlock := PFullDebugBlockHeader(PByte(APointer)
8855 - SizeOf(TFullDebugBlockHeader));
8856 {Is the debug info surrounding the block valid?}
8857 if CheckBlockBeforeFreeOrRealloc(LActualBlock, boFreeMem) then
8858 begin
8859 {Enter the memory manager: block scans may not be performed now}
8860 StartChangingFullDebugModeBlock;
8861 try
8862 {$ifdef FullDebugModeCallBacks}
8863 if Assigned(OnDebugFreeMemStart) then
8864 OnDebugFreeMemStart(LActualBlock);
8865 {$endif}
8866 {Large blocks are never reused, so there is no point in updating their
8867 headers and fill pattern.}
8868 LBlockHeader := PNativeUInt(PByte(LActualBlock) - BlockHeaderSize)^;
8869 if LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag or IsLargeBlockFlag) <> IsLargeBlockFlag then
8870 begin
8871 {Get the class the block was used for}
8872 LActualBlock.PreviouslyUsedByClass := PNativeUInt(APointer)^;
8873 {Set the free call stack}
8874 GetStackTrace(@LActualBlock.FreeStackTrace, StackTraceDepth, 1);
8875 {Set the thread ID of the thread that freed the block}
8876 LActualBlock.FreedByThread := GetThreadID;
8877 {Block is now free}
8878 LActualBlock.AllocatedByRoutine := nil;
8879 {Clear the user area of the block}
8880 DebugFillMem(APointer^, LActualBlock.UserSize,
8881 {$ifndef CatchUseOfFreedInterfaces}DebugFillPattern{$else}NativeUInt(@VMTBadInterface){$endif});
8882 {Set a pointer to the dummy VMT}
8883 PNativeUInt(APointer)^ := NativeUInt(@FreedObjectVMT.VMTMethods[0]);
8884 {Recalculate the checksums}
8885 UpdateHeaderAndFooterCheckSums(LActualBlock);
8886 end;
8887 {$ifdef EnableMemoryLeakReporting}
8888 {Automatically deregister the expected memory leak?}
8889 if FullDebugModeRegisterAllAllocsAsExpectedMemoryLeak then
8890 UnregisterExpectedMemoryLeak(APointer);
8891 {$endif}
8892 {Free the actual block}
8893 Result := FastFreeMem(LActualBlock);
8894 {$ifdef FullDebugModeCallBacks}
8895 if Assigned(OnDebugFreeMemFinish) then
8896 OnDebugFreeMemFinish(LActualBlock, Result);
8897 {$endif}
8898 finally
8899 {Leaving the memory manager routine: Block scans may be performed again.}
8900 DoneChangingFullDebugModeBlock;
8901 end;
8902 end
8903 else
8904 begin
8905 {$ifdef SuppressFreeMemErrorsInsideException}
8906 if {$ifdef BDS2006AndUp}ExceptObject{$else}RaiseList{$endif} <> nil then
8907 Result := 0
8908 else
8909 {$endif}
8910 Result := -1;
8911 end;
8912 end;
8913
DebugReallocMemnull8914 function DebugReallocMem(APointer: Pointer; ANewSize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer;
8915 var
8916 LMoveSize, LBlockSpace: NativeUInt;
8917 LActualBlock, LNewActualBlock: PFullDebugBlockHeader;
8918 begin
8919 {Scan the entire memory pool first?}
8920 if FullDebugModeScanMemoryPoolBeforeEveryOperation then
8921 ScanMemoryPoolForCorruptions;
8922 {Get a pointer to the start of the actual block}
8923 LActualBlock := PFullDebugBlockHeader(PByte(APointer)
8924 - SizeOf(TFullDebugBlockHeader));
8925 {Is the debug info surrounding the block valid?}
8926 if CheckBlockBeforeFreeOrRealloc(LActualBlock, boReallocMem) then
8927 begin
8928 {Get the current block size}
8929 LBlockSpace := GetAvailableSpaceInBlock(LActualBlock);
8930 {Can the block fit? We need space for the debug overhead and the block header
8931 of the next block}
8932 if LBlockSpace < (NativeUInt(ANewSize) + FullDebugBlockOverhead) then
8933 begin
8934 {Get a new block of the requested size.}
8935 Result := DebugGetMem(ANewSize);
8936 if Result <> nil then
8937 begin
8938 {Block scans may not be performed now}
8939 StartChangingFullDebugModeBlock;
8940 try
8941 {$ifdef FullDebugModeCallBacks}
8942 if Assigned(OnDebugReallocMemStart) then
8943 OnDebugReallocMemStart(LActualBlock, ANewSize);
8944 {$endif}
8945 {We reuse the old allocation number. Since DebugGetMem always bumps
8946 CurrentAllocationGroup, there may be gaps in the sequence of
8947 allocation numbers.}
8948 LNewActualBlock := PFullDebugBlockHeader(PByte(Result)
8949 - SizeOf(TFullDebugBlockHeader));
8950 LNewActualBlock.AllocationGroup := LActualBlock.AllocationGroup;
8951 LNewActualBlock.AllocationNumber := LActualBlock.AllocationNumber;
8952 {Recalculate the header and footer checksums}
8953 UpdateHeaderAndFooterCheckSums(LNewActualBlock);
8954 {$ifdef FullDebugModeCallBacks}
8955 if Assigned(OnDebugReallocMemFinish) then
8956 OnDebugReallocMemFinish(LNewActualBlock, ANewSize);
8957 {$endif}
8958 finally
8959 {Block scans can again be performed safely}
8960 DoneChangingFullDebugModeBlock;
8961 end;
8962 {How many bytes to move?}
8963 LMoveSize := LActualBlock.UserSize;
8964 if LMoveSize > NativeUInt(ANewSize) then
8965 LMoveSize := ANewSize;
8966 {Move the data across}
8967 System.Move(APointer^, Result^, LMoveSize);
8968 {Free the old block}
8969 DebugFreeMem(APointer);
8970 end
8971 else
8972 begin
8973 Result := nil;
8974 end;
8975 end
8976 else
8977 begin
8978 {Block scans may not be performed now}
8979 StartChangingFullDebugModeBlock;
8980 try
8981 {$ifdef FullDebugModeCallBacks}
8982 if Assigned(OnDebugReallocMemStart) then
8983 OnDebugReallocMemStart(LActualBlock, ANewSize);
8984 {$endif}
8985 {Clear all data after the new end of the block up to the old end of the
8986 block, including the trailer.}
8987 DebugFillMem(Pointer(PByte(APointer) + NativeUInt(ANewSize) + SizeOf(NativeUInt))^,
8988 NativeInt(LActualBlock.UserSize) - ANewSize,
8989 {$ifndef CatchUseOfFreedInterfaces}
8990 DebugFillPattern);
8991 {$else}
8992 RotateRight(NativeUInt(@VMTBadInterface), (ANewSize and (SizeOf(Pointer) - 1)) * 8));
8993 {$endif}
8994 {Update the user size}
8995 LActualBlock.UserSize := ANewSize;
8996 {Set the new checksums}
8997 UpdateHeaderAndFooterCheckSums(LActualBlock);
8998 {$ifdef FullDebugModeCallBacks}
8999 if Assigned(OnDebugReallocMemFinish) then
9000 OnDebugReallocMemFinish(LActualBlock, ANewSize);
9001 {$endif}
9002 finally
9003 {Block scans can again be performed safely}
9004 DoneChangingFullDebugModeBlock;
9005 end;
9006 {Return the old pointer}
9007 Result := APointer;
9008 end;
9009 end
9010 else
9011 begin
9012 Result := nil;
9013 end;
9014 end;
9015
9016 {Allocates a block and fills it with zeroes}
DebugAllocMemnull9017 function DebugAllocMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Cardinal{$endif}): Pointer;
9018 begin
9019 Result := DebugGetMem(ASize);
9020 {Clear the block}
9021 if Result <> nil then
9022 FillChar(Result^, ASize, 0);
9023 end;
9024
9025 {Raises a runtime error if a memory corruption was encountered. Subroutine for
9026 InternalScanMemoryPool and InternalScanSmallBlockPool.}
9027 procedure RaiseMemoryCorruptionError;
9028 begin
9029 {Disable exhaustive checking in order to prevent recursive exceptions.}
9030 FullDebugModeScanMemoryPoolBeforeEveryOperation := False;
9031 {Unblock the memory manager in case the creation of the exception below
9032 causes an attempt to be made to allocate memory.}
9033 UnblockFullDebugModeMMRoutines;
9034 {Raise the runtime error}
9035 {$ifdef BCB6OrDelphi7AndUp}
9036 System.Error(reOutOfMemory);
9037 {$else}
9038 System.RunError(reOutOfMemory);
9039 {$endif}
9040 end;
9041
9042 {Subroutine for InternalScanMemoryPool: Checks the given small block pool for
9043 allocated blocks}
9044 procedure InternalScanSmallBlockPool(APSmallBlockPool: PSmallBlockPoolHeader;
9045 AFirstAllocationGroupToLog, ALastAllocationGroupToLog: Cardinal);
9046 var
9047 LCurPtr, LEndPtr: Pointer;
9048 begin
9049 {Get the first and last pointer for the pool}
9050 GetFirstAndLastSmallBlockInPool(APSmallBlockPool, LCurPtr, LEndPtr);
9051 {Step through all blocks}
9052 while UIntPtr(LCurPtr) <= UIntPtr(LEndPtr) do
9053 begin
9054 {Is this block in use? If so, is the debug info intact?}
9055 if ((PNativeUInt(PByte(LCurPtr) - BlockHeaderSize)^ and IsFreeBlockFlag) = 0) then
9056 begin
9057 if CheckBlockBeforeFreeOrRealloc(LCurPtr, boBlockCheck) then
9058 begin
9059 if (PFullDebugBlockHeader(LCurPtr).AllocationGroup >= AFirstAllocationGroupToLog)
9060 and (PFullDebugBlockHeader(LCurPtr).AllocationGroup <= ALastAllocationGroupToLog) then
9061 begin
9062 LogMemoryLeakOrAllocatedBlock(LCurPtr, False);
9063 end;
9064 end
9065 else
9066 RaiseMemoryCorruptionError;
9067 end
9068 else
9069 begin
9070 {Check that the block has not been modified since being freed}
9071 if not CheckFreeBlockUnmodified(LCurPtr, APSmallBlockPool.BlockType.BlockSize, boBlockCheck) then
9072 RaiseMemoryCorruptionError;
9073 end;
9074 {Next block}
9075 Inc(PByte(LCurPtr), APSmallBlockPool.BlockType.BlockSize);
9076 end;
9077 end;
9078
9079 {Subroutine for LogAllocatedBlocksToFile and ScanMemoryPoolForCorruptions:
9080 Scans the memory pool for corruptions and optionally logs allocated blocks
9081 in the allocation group range.}
9082 procedure InternalScanMemoryPool(AFirstAllocationGroupToLog, ALastAllocationGroupToLog: Cardinal);
9083 var
9084 LPLargeBlock: PLargeBlockHeader;
9085 LPMediumBlock: Pointer;
9086 LPMediumBlockPoolHeader: PMediumBlockPoolHeader;
9087 LMediumBlockHeader: NativeUInt;
9088 begin
9089 {Block all the memory manager routines while performing the scan. No memory
9090 block may be allocated or freed, and no FullDebugMode block header or
9091 footer may be modified, while the scan is in progress.}
9092 BlockFullDebugModeMMRoutines;
9093 try
9094 {Step through all the medium block pools}
9095 LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader;
9096 while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do
9097 begin
9098 LPMediumBlock := GetFirstMediumBlockInPool(LPMediumBlockPoolHeader);
9099 while LPMediumBlock <> nil do
9100 begin
9101 LMediumBlockHeader := PNativeUInt(PByte(LPMediumBlock) - BlockHeaderSize)^;
9102 {Is the block in use?}
9103 if LMediumBlockHeader and IsFreeBlockFlag = 0 then
9104 begin
9105 {Block is in use: Is it a medium block or small block pool?}
9106 if (LMediumBlockHeader and IsSmallBlockPoolInUseFlag) <> 0 then
9107 begin
9108 {Get all the leaks for the small block pool}
9109 InternalScanSmallBlockPool(LPMediumBlock, AFirstAllocationGroupToLog, ALastAllocationGroupToLog);
9110 end
9111 else
9112 begin
9113 if CheckBlockBeforeFreeOrRealloc(LPMediumBlock, boBlockCheck) then
9114 begin
9115 if (PFullDebugBlockHeader(LPMediumBlock).AllocationGroup >= AFirstAllocationGroupToLog)
9116 and (PFullDebugBlockHeader(LPMediumBlock).AllocationGroup <= ALastAllocationGroupToLog) then
9117 begin
9118 LogMemoryLeakOrAllocatedBlock(LPMediumBlock, False);
9119 end;
9120 end
9121 else
9122 RaiseMemoryCorruptionError;
9123 end;
9124 end
9125 else
9126 begin
9127 {Check that the block has not been modified since being freed}
9128 if not CheckFreeBlockUnmodified(LPMediumBlock, LMediumBlockHeader and DropMediumAndLargeFlagsMask, boBlockCheck) then
9129 RaiseMemoryCorruptionError;
9130 end;
9131 {Next medium block}
9132 LPMediumBlock := NextMediumBlock(LPMediumBlock);
9133 end;
9134 {Get the next medium block pool}
9135 LPMediumBlockPoolHeader := LPMediumBlockPoolHeader.NextMediumBlockPoolHeader;
9136 end;
9137 {Scan large blocks}
9138 LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader;
9139 while LPLargeBlock <> @LargeBlocksCircularList do
9140 begin
9141 if CheckBlockBeforeFreeOrRealloc(Pointer(PByte(LPLargeBlock) + LargeBlockHeaderSize), boBlockCheck) then
9142 begin
9143 if (PFullDebugBlockHeader(PByte(LPLargeBlock) + LargeBlockHeaderSize).AllocationGroup >= AFirstAllocationGroupToLog)
9144 and (PFullDebugBlockHeader(PByte(LPLargeBlock) + LargeBlockHeaderSize).AllocationGroup <= ALastAllocationGroupToLog) then
9145 begin
9146 LogMemoryLeakOrAllocatedBlock(Pointer(PByte(LPLargeBlock) + LargeBlockHeaderSize), False);
9147 end;
9148 end
9149 else
9150 RaiseMemoryCorruptionError;
9151 {Get the next large block}
9152 LPLargeBlock := LPLargeBlock.NextLargeBlockHeader;
9153 end;
9154 finally
9155 {Unblock the FullDebugMode memory manager routines.}
9156 UnblockFullDebugModeMMRoutines;
9157 end;
9158 end;
9159
9160 {Logs detail about currently allocated memory blocks for the specified range of
9161 allocation groups. if ALastAllocationGroupToLog is less than
9162 AFirstAllocationGroupToLog or it is zero, then all allocation groups are
9163 logged. This routine also checks the memory pool for consistency at the same
9164 time, raising an "Out of Memory" error if the check fails.}
9165 procedure LogAllocatedBlocksToFile(AFirstAllocationGroupToLog, ALastAllocationGroupToLog: Cardinal);
9166 begin
9167 {Validate input}
9168 if (ALastAllocationGroupToLog = 0) or (ALastAllocationGroupToLog < AFirstAllocationGroupToLog) then
9169 begin
9170 {Bad input: log all groups}
9171 AFirstAllocationGroupToLog := 0;
9172 ALastAllocationGroupToLog := $ffffffff;
9173 end;
9174 {Scan the memory pool, logging allocated blocks in the requested range.}
9175 InternalScanMemoryPool(AFirstAllocationGroupToLog, ALastAllocationGroupToLog);
9176 end;
9177
9178 {Scans the memory pool for any corruptions. If a corruption is encountered an "Out of Memory" exception is
9179 raised.}
9180 procedure ScanMemoryPoolForCorruptions;
9181 begin
9182 {Scan the memory pool for corruptions, but don't log any allocated blocks}
9183 InternalScanMemoryPool($ffffffff, 0);
9184 end;
9185
9186 {-----------------------Invalid Virtual Method Calls-------------------------}
9187
9188 { TFreedObject }
9189
9190 {Used to determine the index of the virtual method call on the freed object.
9191 Do not change this without updating MaxFakeVMTEntries. Currently 200.}
9192 procedure TFreedObject.GetVirtualMethodIndex;
9193 asm
9194 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9195 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9196 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9197 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9198 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9199
9200 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9201 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9202 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9203 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9204 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9205
9206 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9207 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9208 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9209 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9210 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9211
9212 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9213 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9214 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9215 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9216 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9217
9218 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9219 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9220 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9221 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9222 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9223
9224 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9225 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9226 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9227 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9228 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9229
9230 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9231 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9232 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9233 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9234 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9235
9236 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9237 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9238 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9239 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9240 Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
9241
9242 jmp TFreedObject.VirtualMethodError
9243 end;
9244
9245 procedure TFreedObject.VirtualMethodError;
9246 var
9247 LVMOffset: Integer;
9248 LMsgPtr: PAnsiChar;
9249 LErrorMessage: array[0..32767] of AnsiChar;
9250 {$ifndef NoMessageBoxes}
9251 LErrorMessageTitle: array[0..1023] of AnsiChar;
9252 {$endif}
9253 LClass: TClass;
9254 LActualBlock: PFullDebugBlockHeader;
9255 begin
9256 {Get the offset of the virtual method}
9257 LVMOffset := (MaxFakeVMTEntries - VMIndex) * SizeOf(Pointer) + vmtParent + SizeOf(Pointer);
9258 {Reset the index for the next error}
9259 VMIndex := 0;
9260 {Get the address of the actual block}
9261 LActualBlock := PFullDebugBlockHeader(PByte(Self) - SizeOf(TFullDebugBlockHeader));
9262 {Display the error header}
9263 LMsgPtr := AppendStringToBuffer(VirtualMethodErrorHeader, @LErrorMessage[0], Length(VirtualMethodErrorHeader));
9264 {Is the debug info surrounding the block valid?}
9265 if CalculateHeaderCheckSum(LActualBlock) = LActualBlock.HeaderCheckSum then
9266 begin
9267 {Get the class this block was used for previously}
9268 LClass := DetectClassInstance(@LActualBlock.PreviouslyUsedByClass);
9269 if (LClass <> nil) and (IntPtr(LClass) <> IntPtr(@FreedObjectVMT.VMTMethods[0])) then
9270 begin
9271 LMsgPtr := AppendStringToBuffer(FreedObjectClassMsg, LMsgPtr, Length(FreedObjectClassMsg));
9272 LMsgPtr := AppendClassNameToBuffer(LClass, LMsgPtr);
9273 end;
9274 {Get the virtual method name}
9275 LMsgPtr := AppendStringToBuffer(VirtualMethodName, LMsgPtr, Length(VirtualMethodName));
9276 if LVMOffset < 0 then
9277 begin
9278 LMsgPtr := AppendStringToBuffer(StandardVirtualMethodNames[LVMOffset div SizeOf(Pointer)], LMsgPtr, Length(StandardVirtualMethodNames[LVMOffset div SizeOf(Pointer)]));
9279 end
9280 else
9281 begin
9282 LMsgPtr := AppendStringToBuffer(VirtualMethodOffset, LMsgPtr, Length(VirtualMethodOffset));
9283 LMsgPtr := NativeUIntToStrBuf(LVMOffset, LMsgPtr);
9284 end;
9285 {Virtual method address}
9286 if (LClass <> nil) and (IntPtr(LClass) <> IntPtr(@FreedObjectVMT.VMTMethods[0])) then
9287 begin
9288 LMsgPtr := AppendStringToBuffer(VirtualMethodAddress, LMsgPtr, Length(VirtualMethodAddress));
9289 LMsgPtr := NativeUIntToHexBuf(PNativeUInt(PByte(LClass) + LVMOffset)^, LMsgPtr);
9290 end;
9291 {Log the allocation group}
9292 if LActualBlock.AllocationGroup > 0 then
9293 begin
9294 LMsgPtr := AppendStringToBuffer(PreviousAllocationGroupMsg, LMsgPtr, Length(PreviousAllocationGroupMsg));
9295 LMsgPtr := NativeUIntToStrBuf(LActualBlock.AllocationGroup, LMsgPtr);
9296 end;
9297 {Log the allocation number}
9298 LMsgPtr := AppendStringToBuffer(PreviousAllocationNumberMsg, LMsgPtr, Length(PreviousAllocationNumberMsg));
9299 LMsgPtr := NativeUIntToStrBuf(LActualBlock.AllocationNumber, LMsgPtr);
9300 {The header is still intact - display info about the this/previous allocation}
9301 if LActualBlock.AllocationStackTrace[0] <> 0 then
9302 begin
9303 LMsgPtr := AppendStringToBuffer(ThreadIDAtObjectAllocMsg, LMsgPtr, Length(ThreadIDAtObjectAllocMsg));
9304 LMsgPtr := NativeUIntToHexBuf(LActualBlock.AllocatedByThread, LMsgPtr);
9305 LMsgPtr := AppendStringToBuffer(StackTraceMsg, LMsgPtr, Length(StackTraceMsg));
9306 LMsgPtr := LogStackTrace(@LActualBlock.AllocationStackTrace, StackTraceDepth, LMsgPtr);
9307 end;
9308 {Get the call stack for the previous free}
9309 if LActualBlock.FreeStackTrace[0] <> 0 then
9310 begin
9311 LMsgPtr := AppendStringToBuffer(ThreadIDAtObjectFreeMsg, LMsgPtr, Length(ThreadIDAtObjectFreeMsg));
9312 LMsgPtr := NativeUIntToHexBuf(LActualBlock.FreedByThread, LMsgPtr);
9313 LMsgPtr := AppendStringToBuffer(StackTraceMsg, LMsgPtr, Length(StackTraceMsg));
9314 LMsgPtr := LogStackTrace(@LActualBlock.FreeStackTrace, StackTraceDepth, LMsgPtr);
9315 end;
9316 end
9317 else
9318 begin
9319 {Header has been corrupted}
9320 LMsgPtr := AppendStringToBuffer(BlockHeaderCorruptedNoHistoryMsg, LMsgPtr, Length(BlockHeaderCorruptedNoHistoryMsg));
9321 end;
9322 {Add the current stack trace}
9323 LMsgPtr := LogCurrentThreadAndStackTrace(2, LMsgPtr);
9324 {$ifndef DisableLoggingOfMemoryDumps}
9325 {Add the pointer address}
9326 LMsgPtr := LogMemoryDump(LActualBlock, LMsgPtr);
9327 {$endif}
9328 {Trailing CRLF}
9329 LMsgPtr^ := #13;
9330 Inc(LMsgPtr);
9331 LMsgPtr^ := #10;
9332 Inc(LMsgPtr);
9333 {Trailing #0}
9334 LMsgPtr^ := #0;
9335 {$ifdef LogErrorsToFile}
9336 {Log the error}
9337 AppendEventLog(@LErrorMessage[0], NativeUInt(LMsgPtr) - NativeUInt(@LErrorMessage[0]));
9338 {$endif}
9339 {$ifdef UseOutputDebugString}
9340 OutputDebugStringA(LErrorMessage);
9341 {$endif}
9342 {$ifndef NoMessageBoxes}
9343 {Show the message}
9344 AppendStringToModuleName(BlockErrorMsgTitle, LErrorMessageTitle);
9345 ShowMessageBox(LErrorMessage, LErrorMessageTitle);
9346 {$endif}
9347 {Raise an access violation}
9348 RaiseException(EXCEPTION_ACCESS_VIOLATION, 0, 0, nil);
9349 end;
9350
9351 {$ifdef CatchUseOfFreedInterfaces}
9352 procedure TFreedObject.InterfaceError;
9353 var
9354 LMsgPtr: PAnsiChar;
9355 {$ifndef NoMessageBoxes}
9356 LErrorMessageTitle: array[0..1023] of AnsiChar;
9357 {$endif}
9358 LErrorMessage: array[0..4000] of AnsiChar;
9359 begin
9360 {Display the error header}
9361 LMsgPtr := AppendStringToBuffer(InterfaceErrorHeader, @LErrorMessage[0], Length(InterfaceErrorHeader));
9362 {Add the current stack trace}
9363 LMsgPtr := LogCurrentThreadAndStackTrace(2, LMsgPtr);
9364 {Trailing CRLF}
9365 LMsgPtr^ := #13;
9366 Inc(LMsgPtr);
9367 LMsgPtr^ := #10;
9368 Inc(LMsgPtr);
9369 {Trailing #0}
9370 LMsgPtr^ := #0;
9371 {$ifdef LogErrorsToFile}
9372 {Log the error}
9373 AppendEventLog(@LErrorMessage[0], NativeUInt(LMsgPtr) - NativeUInt(@LErrorMessage[0]));
9374 {$endif}
9375 {$ifdef UseOutputDebugString}
9376 OutputDebugStringA(LErrorMessage);
9377 {$endif}
9378 {$ifndef NoMessageBoxes}
9379 {Show the message}
9380 AppendStringToModuleName(BlockErrorMsgTitle, LErrorMessageTitle);
9381 ShowMessageBox(LErrorMessage, LErrorMessageTitle);
9382 {$endif}
9383 {Raise an access violation}
9384 RaiseException(EXCEPTION_ACCESS_VIOLATION, 0, 0, nil);
9385 end;
9386 {$endif}
9387
9388 {$endif}
9389
9390 {----------------------------Memory Leak Checking-----------------------------}
9391
9392 {$ifdef EnableMemoryLeakReporting}
9393
9394 {Adds a leak to the specified list}
UpdateExpectedLeakListnull9395 function UpdateExpectedLeakList(APLeakList: PPExpectedMemoryLeak;
9396 APNewEntry: PExpectedMemoryLeak; AExactSizeMatch: Boolean = True): Boolean;
9397 var
9398 LPInsertAfter, LPNewEntry: PExpectedMemoryLeak;
9399 begin
9400 {Default to error}
9401 Result := False;
9402 {Find the insertion spot}
9403 LPInsertAfter := APLeakList^;
9404 while LPInsertAfter <> nil do
9405 begin
9406 {Too big?}
9407 if LPInsertAfter.LeakSize > APNewEntry.LeakSize then
9408 begin
9409 LPInsertAfter := LPInsertAfter.PreviousLeak;
9410 Break;
9411 end;
9412 {Find a matching entry. If an exact size match is not required and the leak
9413 is larger than the current entry, use it if the expected size of the next
9414 entry is too large.}
9415 if (IntPtr(LPInsertAfter.LeakAddress) = IntPtr(APNewEntry.LeakAddress))
9416 and ((IntPtr(LPInsertAfter.LeakedClass) = IntPtr(APNewEntry.LeakedClass))
9417 {$ifdef CheckCppObjectTypeEnabled}
9418 or (LPInsertAfter.LeakedCppTypeIdPtr = APNewEntry.LeakedCppTypeIdPtr)
9419 {$endif}
9420 )
9421 and ((LPInsertAfter.LeakSize = APNewEntry.LeakSize)
9422 or ((not AExactSizeMatch)
9423 and (LPInsertAfter.LeakSize < APNewEntry.LeakSize)
9424 and ((LPInsertAfter.NextLeak = nil)
9425 or (LPInsertAfter.NextLeak.LeakSize > APNewEntry.LeakSize))
9426 )) then
9427 begin
9428 if (LPInsertAfter.LeakCount + APNewEntry.LeakCount) >= 0 then
9429 begin
9430 Inc(LPInsertAfter.LeakCount, APNewEntry.LeakCount);
9431 {Is the count now 0?}
9432 if LPInsertAfter.LeakCount = 0 then
9433 begin
9434 {Delete the entry}
9435 if LPInsertAfter.NextLeak <> nil then
9436 LPInsertAfter.NextLeak.PreviousLeak := LPInsertAfter.PreviousLeak;
9437 if LPInsertAfter.PreviousLeak <> nil then
9438 LPInsertAfter.PreviousLeak.NextLeak := LPInsertAfter.NextLeak
9439 else
9440 APLeakList^ := LPInsertAfter.NextLeak;
9441 {Insert it as the first free slot}
9442 LPInsertAfter.NextLeak := ExpectedMemoryLeaks.FirstFreeSlot;
9443 ExpectedMemoryLeaks.FirstFreeSlot := LPInsertAfter;
9444 end;
9445 Result := True;
9446 end;
9447 Exit;
9448 end;
9449 {Next entry}
9450 if LPInsertAfter.NextLeak <> nil then
9451 LPInsertAfter := LPInsertAfter.NextLeak
9452 else
9453 Break;
9454 end;
9455 if APNewEntry.LeakCount > 0 then
9456 begin
9457 {Get a position for the entry}
9458 LPNewEntry := ExpectedMemoryLeaks.FirstFreeSlot;
9459 if LPNewEntry <> nil then
9460 begin
9461 ExpectedMemoryLeaks.FirstFreeSlot := LPNewEntry.NextLeak;
9462 end
9463 else
9464 begin
9465 if ExpectedMemoryLeaks.EntriesUsed < Length(ExpectedMemoryLeaks.ExpectedLeaks) then
9466 begin
9467 LPNewEntry := @ExpectedMemoryLeaks.ExpectedLeaks[ExpectedMemoryLeaks.EntriesUsed];
9468 Inc(ExpectedMemoryLeaks.EntriesUsed);
9469 end
9470 else
9471 begin
9472 {No more space}
9473 Exit;
9474 end;
9475 end;
9476 {Set the entry}
9477 LPNewEntry^ := APNewEntry^;
9478 {Insert it into the list}
9479 LPNewEntry.PreviousLeak := LPInsertAfter;
9480 if LPInsertAfter <> nil then
9481 begin
9482 LPNewEntry.NextLeak := LPInsertAfter.NextLeak;
9483 if LPNewEntry.NextLeak <> nil then
9484 LPNewEntry.NextLeak.PreviousLeak := LPNewEntry;
9485 LPInsertAfter.NextLeak := LPNewEntry;
9486 end
9487 else
9488 begin
9489 LPNewEntry.NextLeak := APLeakList^;
9490 if LPNewEntry.NextLeak <> nil then
9491 LPNewEntry.NextLeak.PreviousLeak := LPNewEntry;
9492 APLeakList^ := LPNewEntry;
9493 end;
9494 Result := True;
9495 end;
9496 end;
9497
9498 {Locks the expected leaks. Returns false if the list could not be allocated.}
LockExpectedMemoryLeaksListnull9499 function LockExpectedMemoryLeaksList: Boolean;
9500 begin
9501 {Lock the expected leaks list}
9502 {$ifndef AssumeMultiThreaded}
9503 if IsMultiThread then
9504 {$endif}
9505 begin
9506 while LockCmpxchg(0, 1, @ExpectedMemoryLeaksListLocked) <> 0 do
9507 begin
9508 {$ifdef NeverSleepOnThreadContention}
9509 {$ifdef UseSwitchToThread}
9510 SwitchToThread;
9511 {$endif}
9512 {$else}
9513 Sleep(InitialSleepTime);
9514 if LockCmpxchg(0, 1, @ExpectedMemoryLeaksListLocked) = 0 then
9515 Break;
9516 Sleep(AdditionalSleepTime);
9517 {$endif}
9518 end;
9519 end;
9520 {Allocate the list if it does not exist}
9521 if ExpectedMemoryLeaks = nil then
9522 ExpectedMemoryLeaks := VirtualAlloc(nil, ExpectedMemoryLeaksListSize, MEM_COMMIT, PAGE_READWRITE);
9523 {Done}
9524 Result := ExpectedMemoryLeaks <> nil;
9525 end;
9526
9527 {Registers expected memory leaks. Returns true on success. The list of leaked
9528 blocks is limited, so failure is possible if the list is full.}
RegisterExpectedMemoryLeaknull9529 function RegisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; overload;
9530 var
9531 LNewEntry: TExpectedMemoryLeak;
9532 begin
9533 {Fill out the structure}
9534 {$ifndef FullDebugMode}
9535 LNewEntry.LeakAddress := ALeakedPointer;
9536 {$else}
9537 LNewEntry.LeakAddress := Pointer(PByte(ALeakedPointer) - SizeOf(TFullDebugBlockHeader));
9538 {$endif}
9539 LNewEntry.LeakedClass := nil;
9540 {$ifdef CheckCppObjectTypeEnabled}
9541 LNewEntry.LeakedCppTypeIdPtr := nil;
9542 {$endif}
9543 LNewEntry.LeakSize := 0;
9544 LNewEntry.LeakCount := 1;
9545 {Add it to the correct list}
9546 Result := LockExpectedMemoryLeaksList
9547 and UpdateExpectedLeakList(@ExpectedMemoryLeaks.FirstEntryByAddress, @LNewEntry);
9548 ExpectedMemoryLeaksListLocked := False;
9549 end;
9550
RegisterExpectedMemoryLeaknull9551 function RegisterExpectedMemoryLeak(ALeakedObjectClass: TClass; ACount: Integer = 1): Boolean; overload;
9552 var
9553 LNewEntry: TExpectedMemoryLeak;
9554 begin
9555 {Fill out the structure}
9556 LNewEntry.LeakAddress := nil;
9557 LNewEntry.LeakedClass := ALeakedObjectClass;
9558 {$ifdef CheckCppObjectTypeEnabled}
9559 LNewEntry.LeakedCppTypeIdPtr := nil;
9560 {$endif}
9561 LNewEntry.LeakSize := ALeakedObjectClass.InstanceSize;
9562 LNewEntry.LeakCount := ACount;
9563 {Add it to the correct list}
9564 Result := LockExpectedMemoryLeaksList
9565 and UpdateExpectedLeakList(@ExpectedMemoryLeaks.FirstEntryByClass, @LNewEntry);
9566 ExpectedMemoryLeaksListLocked := False;
9567 end;
9568
9569 {$ifdef CheckCppObjectTypeEnabled}
RegisterExpectedMemoryLeaknull9570 function RegisterExpectedMemoryLeak(ALeakedCppVirtObjTypeIdPtr: Pointer; ACount: Integer): Boolean; overload;
9571 var
9572 LNewEntry: TExpectedMemoryLeak;
9573 begin
9574 {Fill out the structure}
9575 if Assigned(GetCppVirtObjSizeByTypeIdPtrFunc) then
9576 begin
9577 //Return 0 if not a proper type
9578 LNewEntry.LeakSize := GetCppVirtObjSizeByTypeIdPtrFunc(ALeakedCppVirtObjTypeIdPtr);
9579 if LNewEntry.LeakSize > 0 then
9580 begin
9581 LNewEntry.LeakAddress := nil;
9582 LNewEntry.LeakedClass := nil;
9583 LNewEntry.LeakedCppTypeIdPtr := ALeakedCppVirtObjTypeIdPtr;
9584 LNewEntry.LeakCount := ACount;
9585 {Add it to the correct list}
9586 Result := LockExpectedMemoryLeaksList
9587 and UpdateExpectedLeakList(@ExpectedMemoryLeaks.FirstEntryByClass, @LNewEntry);
9588 ExpectedMemoryLeaksListLocked := False;
9589 end
9590 else
9591 begin
9592 Result := False;
9593 end;
9594 end
9595 else
9596 begin
9597 Result := False;
9598 end;
9599 end;
9600 {$endif}
9601
RegisterExpectedMemoryLeaknull9602 function RegisterExpectedMemoryLeak(ALeakedBlockSize: NativeInt; ACount: Integer = 1): Boolean; overload;
9603 var
9604 LNewEntry: TExpectedMemoryLeak;
9605 begin
9606 {Fill out the structure}
9607 LNewEntry.LeakAddress := nil;
9608 LNewEntry.LeakedClass := nil;
9609 {$ifdef CheckCppObjectTypeEnabled}
9610 LNewEntry.LeakedCppTypeIdPtr := nil;
9611 {$endif}
9612 LNewEntry.LeakSize := ALeakedBlockSize;
9613 LNewEntry.LeakCount := ACount;
9614 {Add it to the correct list}
9615 Result := LockExpectedMemoryLeaksList
9616 and UpdateExpectedLeakList(@ExpectedMemoryLeaks.FirstEntryBySizeOnly, @LNewEntry);
9617 ExpectedMemoryLeaksListLocked := False;
9618 end;
9619
UnregisterExpectedMemoryLeaknull9620 function UnregisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; overload;
9621 var
9622 LNewEntry: TExpectedMemoryLeak;
9623 begin
9624 {Fill out the structure}
9625 {$ifndef FullDebugMode}
9626 LNewEntry.LeakAddress := ALeakedPointer;
9627 {$else}
9628 LNewEntry.LeakAddress := Pointer(PByte(ALeakedPointer) - SizeOf(TFullDebugBlockHeader));
9629 {$endif}
9630 LNewEntry.LeakedClass := nil;
9631 {$ifdef CheckCppObjectTypeEnabled}
9632 LNewEntry.LeakedCppTypeIdPtr := nil;
9633 {$endif}
9634 LNewEntry.LeakSize := 0;
9635 LNewEntry.LeakCount := -1;
9636 {Remove it from the list}
9637 Result := LockExpectedMemoryLeaksList
9638 and UpdateExpectedLeakList(@ExpectedMemoryLeaks.FirstEntryByAddress, @LNewEntry);
9639 ExpectedMemoryLeaksListLocked := False;
9640 end;
9641
UnregisterExpectedMemoryLeaknull9642 function UnregisterExpectedMemoryLeak(ALeakedObjectClass: TClass; ACount: Integer = 1): Boolean; overload;
9643 begin
9644 Result := RegisterExpectedMemoryLeak(ALeakedObjectClass, - ACount);
9645 end;
9646
9647 {$ifdef CheckCppObjectTypeEnabled}
UnregisterExpectedMemoryLeaknull9648 function UnregisterExpectedMemoryLeak(ALeakedCppVirtObjTypeIdPtr: Pointer; ACount: Integer): Boolean; overload;
9649 begin
9650 Result := RegisterExpectedMemoryLeak(ALeakedCppVirtObjTypeIdPtr, - ACount);
9651 end;
9652 {$endif}
9653
UnregisterExpectedMemoryLeaknull9654 function UnregisterExpectedMemoryLeak(ALeakedBlockSize: NativeInt; ACount: Integer = 1): Boolean; overload;
9655 begin
9656 Result := RegisterExpectedMemoryLeak(ALeakedBlockSize, - ACount);
9657 end;
9658
9659 {Returns a list of all expected memory leaks}
GetRegisteredMemoryLeaksnull9660 function GetRegisteredMemoryLeaks: TRegisteredMemoryLeaks;
9661
9662 procedure AddEntries(AEntry: PExpectedMemoryLeak);
9663 var
9664 LInd: Integer;
9665 begin
9666 while AEntry <> nil do
9667 begin
9668 LInd := Length(Result);
9669 SetLength(Result, LInd + 1);
9670 {Add the entry}
9671 {$ifndef FullDebugMode}
9672 Result[LInd].LeakAddress := AEntry.LeakAddress;
9673 {$else}
9674 Result[LInd].LeakAddress := Pointer(PByte(AEntry.LeakAddress) + SizeOf(TFullDebugBlockHeader));
9675 {$endif}
9676 Result[LInd].LeakedClass := AEntry.LeakedClass;
9677 {$ifdef CheckCppObjectTypeEnabled}
9678 Result[LInd].LeakedCppTypeIdPtr := AEntry.LeakedCppTypeIdPtr;
9679 {$endif}
9680 Result[LInd].LeakSize := AEntry.LeakSize;
9681 Result[LInd].LeakCount := AEntry.LeakCount;
9682 {Next entry}
9683 AEntry := AEntry.NextLeak;
9684 end;
9685 end;
9686
9687 begin
9688 SetLength(Result, 0);
9689 if (ExpectedMemoryLeaks <> nil) and LockExpectedMemoryLeaksList then
9690 begin
9691 {Add all entries}
9692 AddEntries(ExpectedMemoryLeaks.FirstEntryByAddress);
9693 AddEntries(ExpectedMemoryLeaks.FirstEntryByClass);
9694 AddEntries(ExpectedMemoryLeaks.FirstEntryBySizeOnly);
9695 {Unlock the list}
9696 ExpectedMemoryLeaksListLocked := False;
9697 end;
9698 end;
9699
9700 {$else}
9701 {$ifdef BDS2006AndUp}
NoOpRegisterExpectedMemoryLeaknull9702 function NoOpRegisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean;
9703 begin
9704 {Do nothing. Used when memory leak reporting is disabled under Delphi 2006 and later.}
9705 Result := False;
9706 end;
9707
NoOpUnregisterExpectedMemoryLeaknull9708 function NoOpUnregisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean;
9709 begin
9710 {Do nothing. Used when memory leak reporting is disabled under Delphi 2006 and later.}
9711 Result := False;
9712 end;
9713 {$endif}
9714 {$endif}
9715
9716 {Detects the probable string data type for a memory block.}
DetectStringDatanull9717 function DetectStringData(APMemoryBlock: Pointer;
9718 AAvailableSpaceInBlock: NativeInt): TStringDataType;
9719 const
9720 {If the string reference count field contains a value greater than this,
9721 then it is assumed that the block is not a string.}
9722 MaxRefCount = 255;
9723 {The lowest ASCII character code considered valid string data. If there are
9724 any characters below this code point then the data is assumed not to be a
9725 string. #9 = Tab.}
9726 MinCharCode = #9;
9727 var
9728 LStringLength, LElemSize, LCharInd: Integer;
9729 LPAnsiStr: PAnsiChar;
9730 LPUniStr: PWideChar;
9731 begin
9732 {Check that the reference count is within a reasonable range}
9733 if PStrRec(APMemoryBlock).refCnt > MaxRefCount then
9734 begin
9735 Result := stUnknown;
9736 Exit;
9737 end;
9738 {$ifdef BCB6OrDelphi6AndUp}
9739 {$if RTLVersion >= 20}
9740 LElemSize := PStrRec(APMemoryBlock).elemSize;
9741 {Element size must be either 1 (Ansi) or 2 (Unicode)}
9742 if (LElemSize <> 1) and (LElemSize <> 2) then
9743 begin
9744 Result := stUnknown;
9745 Exit;
9746 end;
9747 {$ifend}
9748 {$if RTLVersion < 20}
9749 LElemSize := 1;
9750 {$ifend}
9751 {$else}
9752 LElemSize := 1;
9753 {$endif}
9754 {Get the string length}
9755 LStringLength := PStrRec(APMemoryBlock).length;
9756 {Does the string fit?}
9757 if (LStringLength <= 0)
9758 or (LStringLength >= (AAvailableSpaceInBlock - SizeOf(StrRec)) div LElemSize) then
9759 begin
9760 Result := stUnknown;
9761 Exit;
9762 end;
9763 {Check for no characters outside the expected range. If there are,
9764 then it is probably not a string.}
9765 if LElemSize = 1 then
9766 begin
9767 {Check that all characters are in the range considered valid.}
9768 LPAnsiStr := PAnsiChar(PByte(APMemoryBlock) + SizeOf(StrRec));
9769 for LCharInd := 1 to LStringLength do
9770 begin
9771 if LPAnsiStr^ < MinCharCode then
9772 begin
9773 Result := stUnknown;
9774 Exit;
9775 end;
9776 Inc(LPAnsiStr);
9777 end;
9778 {Must have a trailing #0}
9779 if LPAnsiStr^ = #0 then
9780 Result := stAnsiString
9781 else
9782 Result := stUnknown;
9783 end
9784 else
9785 begin
9786 {Check that all characters are in the range considered valid.}
9787 LPUniStr := PWideChar(PByte(APMemoryBlock) + SizeOf(StrRec));
9788 for LCharInd := 1 to LStringLength do
9789 begin
9790 if LPUniStr^ < MinCharCode then
9791 begin
9792 Result := stUnknown;
9793 Exit;
9794 end;
9795 Inc(LPUniStr);
9796 end;
9797 {Must have a trailing #0}
9798 if LPUniStr^ = #0 then
9799 Result := stUnicodeString
9800 else
9801 Result := stUnknown;
9802 end;
9803 end;
9804
9805 {Walks all allocated blocks, calling ACallBack for each. Passes the user block size and AUserData to the callback.
9806 Important note: All block types will be locked during the callback, so the memory manager cannot be used inside it.}
9807 procedure WalkAllocatedBlocks(ACallBack: TWalkAllocatedBlocksCallback; AUserData: Pointer);
9808 const
9809 DebugHeaderSize = {$ifdef FullDebugMode}SizeOf(TFullDebugBlockHeader){$else}0{$endif};
9810 TotalDebugOverhead = {$ifdef FullDebugMode}FullDebugBlockOverhead{$else}0{$endif};
9811 var
9812 LPMediumBlock: Pointer;
9813 LPMediumBlockPoolHeader: PMediumBlockPoolHeader;
9814 LMediumBlockHeader: NativeUInt;
9815 LPLargeBlock: PLargeBlockHeader;
9816 LBlockSize: NativeInt;
9817 LPSmallBlockPool: PSmallBlockPoolHeader;
9818 LCurPtr, LEndPtr: Pointer;
9819 LInd: Integer;
9820 begin
9821 {Lock all small block types}
9822 LockAllSmallBlockTypes;
9823 {Lock the medium blocks}
9824 LockMediumBlocks;
9825 try
9826 {Step through all the medium block pools}
9827 LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader;
9828 while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do
9829 begin
9830 LPMediumBlock := GetFirstMediumBlockInPool(LPMediumBlockPoolHeader);
9831 while LPMediumBlock <> nil do
9832 begin
9833 LMediumBlockHeader := PNativeUInt(PByte(LPMediumBlock) - BlockHeaderSize)^;
9834 {Is the block in use?}
9835 if LMediumBlockHeader and IsFreeBlockFlag = 0 then
9836 begin
9837 if (LMediumBlockHeader and IsSmallBlockPoolInUseFlag) <> 0 then
9838 begin
9839 {Step through all the blocks in the small block pool}
9840 LPSmallBlockPool := LPMediumBlock;
9841 {Get the useable size inside a block}
9842 LBlockSize := LPSmallBlockPool.BlockType.BlockSize - BlockHeaderSize - TotalDebugOverhead;
9843 {Get the first and last pointer for the pool}
9844 GetFirstAndLastSmallBlockInPool(LPSmallBlockPool, LCurPtr, LEndPtr);
9845 {Step through all blocks}
9846 while UIntPtr(LCurPtr) <= UIntPtr(LEndPtr) do
9847 begin
9848 {Is this block in use?}
9849 if (PNativeUInt(PByte(LCurPtr) - BlockHeaderSize)^ and IsFreeBlockFlag) = 0 then
9850 begin
9851 ACallBack(PByte(LCurPtr) + DebugHeaderSize, LBlockSize, AUserData);
9852 end;
9853 {Next block}
9854 Inc(PByte(LCurPtr), LPSmallBlockPool.BlockType.BlockSize);
9855 end;
9856 end
9857 else
9858 begin
9859 LBlockSize := (LMediumBlockHeader and DropMediumAndLargeFlagsMask) - BlockHeaderSize - TotalDebugOverhead;
9860 ACallBack(PByte(LPMediumBlock) + DebugHeaderSize, LBlockSize, AUserData);
9861 end;
9862 end;
9863 {Next medium block}
9864 LPMediumBlock := NextMediumBlock(LPMediumBlock);
9865 end;
9866 {Get the next medium block pool}
9867 LPMediumBlockPoolHeader := LPMediumBlockPoolHeader.NextMediumBlockPoolHeader;
9868 end;
9869 finally
9870 {Unlock medium blocks}
9871 MediumBlocksLocked := False;
9872 {Unlock all the small block types}
9873 for LInd := 0 to NumSmallBlockTypes - 1 do
9874 SmallBlockTypes[LInd].BlockTypeLocked := False;
9875 end;
9876 {Step through all the large blocks}
9877 LockLargeBlocks;
9878 try
9879 {Get all leaked large blocks}
9880 LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader;
9881 while LPLargeBlock <> @LargeBlocksCircularList do
9882 begin
9883 LBlockSize := (LPLargeBlock.BlockSizeAndFlags and DropMediumAndLargeFlagsMask) - BlockHeaderSize - LargeBlockHeaderSize - TotalDebugOverhead;
9884 ACallBack(PByte(LPLargeBlock) + LargeBlockHeaderSize + DebugHeaderSize, LBlockSize, AUserData);
9885 {Get the next large block}
9886 LPLargeBlock := LPLargeBlock.NextLargeBlockHeader;
9887 end;
9888 finally
9889 LargeBlocksLocked := False;
9890 end;
9891 end;
9892
9893 {-----------LogMemoryManagerStateToFile implementation------------}
9894 const
9895 MaxMemoryLogNodes = 100000;
9896 QuickSortMinimumItemsInPartition = 4;
9897
9898 type
9899 {While scanning the memory pool the list of classes is built up in a binary search tree.}
9900 PMemoryLogNode = ^TMemoryLogNode;
9901 TMemoryLogNode = record
9902 {The left and right child nodes}
9903 LeftAndRightNodePointers: array[Boolean] of PMemoryLogNode;
9904 {The class this node belongs to}
9905 ClassPtr: Pointer;
9906 {The number of instances of the class}
9907 InstanceCount: NativeInt;
9908 {The total memory usage for this class}
9909 TotalMemoryUsage: NativeInt;
9910 end;
9911 TMemoryLogNodes = array[0..MaxMemoryLogNodes - 1] of TMemoryLogNode;
9912 PMemoryLogNodes = ^TMemoryLogNodes;
9913
9914 TMemoryLogInfo = record
9915 {The number of nodes in "Nodes" that are used.}
9916 NodeCount: Integer;
9917 {The root node of the binary search tree. The content of this node is not actually used, it just simplifies the
9918 binary search code.}
9919 RootNode: TMemoryLogNode;
9920 Nodes: TMemoryLogNodes;
9921 end;
9922 PMemoryLogInfo = ^TMemoryLogInfo;
9923
9924 {LogMemoryManagerStateToFile callback subroutine}
9925 procedure LogMemoryManagerStateCallBack(APBlock: Pointer; ABlockSize: NativeInt; AUserData: Pointer);
9926 var
9927 LClass, LClassHashBits: NativeUInt;
9928 LPLogInfo: PMemoryLogInfo;
9929 LPParentNode, LPClassNode: PMemoryLogNode;
9930 LChildNodeDirection: Boolean;
9931 begin
9932 LPLogInfo := AUserData;
9933 {Detecting an object is very expensive (due to the VirtualQuery call), so we do some basic checks and try to find
9934 the "class" in the tree first.}
9935 LClass := PNativeUInt(APBlock)^;
9936 {Do some basic pointer checks: The "class" must be dword aligned and beyond 64K}
9937 if (LClass > 65535)
9938 and (LClass and 3 = 0) then
9939 begin
9940 LPParentNode := @LPLogInfo.RootNode;
9941 LClassHashBits := LClass;
9942 repeat
9943 LChildNodeDirection := Boolean(LClassHashBits and 1);
9944 {Split off the next bit of the class pointer and traverse in the appropriate direction.}
9945 LPClassNode := LPParentNode.LeftAndRightNodePointers[LChildNodeDirection];
9946 {Is this child node the node the class we're looking for?}
9947 if (LPClassNode = nil) or (NativeUInt(LPClassNode.ClassPtr) = LClass) then
9948 Break;
9949 {The node was not found: Keep on traversing the tree.}
9950 LClassHashBits := LClassHashBits shr 1;
9951 LPParentNode := LPClassNode;
9952 until False;
9953 end
9954 else
9955 LPClassNode := nil;
9956 {Was the "class" found?}
9957 if LPClassNode = nil then
9958 begin
9959 {The "class" is not yet in the tree: Determine if it is actually a class.}
9960 LClass := NativeUInt(DetectClassInstance(APBlock));
9961 {If it is not a class, try to detect the string type.}
9962 if LClass = 0 then
9963 LClass := Ord(DetectStringData(APBlock, ABlockSize));
9964 {Is this class already in the tree?}
9965 LPParentNode := @LPLogInfo.RootNode;
9966 LClassHashBits := LClass;
9967 repeat
9968 LChildNodeDirection := Boolean(LClassHashBits and 1);
9969 {Split off the next bit of the class pointer and traverse in the appropriate direction.}
9970 LPClassNode := LPParentNode.LeftAndRightNodePointers[LChildNodeDirection];
9971 {Is this child node the node the class we're looking for?}
9972 if LPClassNode = nil then
9973 begin
9974 {The end of the tree was reached: Add a new child node.}
9975 LPClassNode := @LPLogInfo.Nodes[LPLogInfo.NodeCount];
9976 Inc(LPLogInfo.NodeCount);
9977 LPParentNode.LeftAndRightNodePointers[LChildNodeDirection] := LPClassNode;
9978 LPClassNode.ClassPtr := Pointer(LClass);
9979 Break;
9980 end
9981 else
9982 begin
9983 if NativeUInt(LPClassNode.ClassPtr) = LClass then
9984 Break;
9985 end;
9986 {The node was not found: Keep on traversing the tree.}
9987 LClassHashBits := LClassHashBits shr 1;
9988 LPParentNode := LPClassNode;
9989 until False;
9990 end;
9991 {Update the statistics for the class}
9992 Inc(LPClassNode.InstanceCount);
9993 Inc(LPClassNode.TotalMemoryUsage, ABlockSize);
9994 end;
9995
9996 {LogMemoryManagerStateToFile subroutine: A median-of-3 quicksort routine for sorting a TMemoryLogNodes array.}
9997 procedure QuickSortLogNodes(APLeftItem: PMemoryLogNodes; ARightIndex: Integer);
9998 var
9999 M, I, J: Integer;
10000 LPivot, LTempItem: TMemoryLogNode;
10001 begin
10002 while True do
10003 begin
10004 {Order the left, middle and right items in ascending order}
10005 M := ARightIndex shr 1;
10006 {Is the middle item larger than the left item?}
10007 if APLeftItem[0].TotalMemoryUsage > APLeftItem[M].TotalMemoryUsage then
10008 begin
10009 {Swap items 0 and M}
10010 LTempItem := APLeftItem[0];
10011 APLeftItem[0] := APLeftItem[M];
10012 APLeftItem[M] := LTempItem;
10013 end;
10014 {Is the middle item larger than the right?}
10015 if APLeftItem[M].TotalMemoryUsage > APLeftItem[ARightIndex].TotalMemoryUsage then
10016 begin
10017 {The right-hand item is not larger - swap it with the middle}
10018 LTempItem := APLeftItem[ARightIndex];
10019 APLeftItem[ARightIndex] := APLeftItem[M];
10020 APLeftItem[M] := LTempItem;
10021 {Is the left larger than the new middle?}
10022 if APLeftItem[0].TotalMemoryUsage > APLeftItem[M].TotalMemoryUsage then
10023 begin
10024 {Swap items 0 and M}
10025 LTempItem := APLeftItem[0];
10026 APLeftItem[0] := APLeftItem[M];
10027 APLeftItem[M] := LTempItem;
10028 end;
10029 end;
10030 {Move the pivot item out of the way by swapping M with R - 1}
10031 LPivot := APLeftItem[M];
10032 APLeftItem[M] := APLeftItem[ARightIndex - 1];
10033 APLeftItem[ARightIndex - 1] := LPivot;
10034 {Set up the loop counters}
10035 I := 0;
10036 J := ARightIndex - 1;
10037 while true do
10038 begin
10039 {Find the first item from the left that is not smaller than the pivot}
10040 repeat
10041 Inc(I);
10042 until APLeftItem[I].TotalMemoryUsage >= LPivot.TotalMemoryUsage;
10043 {Find the first item from the right that is not larger than the pivot}
10044 repeat
10045 Dec(J);
10046 until APLeftItem[J].TotalMemoryUsage <= LPivot.TotalMemoryUsage;
10047 {Stop the loop when the two indexes cross}
10048 if J < I then
10049 Break;
10050 {Swap item I and J}
10051 LTempItem := APLeftItem[I];
10052 APLeftItem[I] := APLeftItem[J];
10053 APLeftItem[J] := LTempItem;
10054 end;
10055 {Put the pivot item back in the correct position by swapping I with R - 1}
10056 APLeftItem[ARightIndex - 1] := APLeftItem[I];
10057 APLeftItem[I] := LPivot;
10058 {Sort the left-hand partition}
10059 if J >= (QuickSortMinimumItemsInPartition - 1) then
10060 QuickSortLogNodes(APLeftItem, J);
10061 {Sort the right-hand partition}
10062 APLeftItem := @APLeftItem[I + 1];
10063 ARightIndex := ARightIndex - I - 1;
10064 if ARightIndex < (QuickSortMinimumItemsInPartition - 1) then
10065 Break;
10066 end;
10067 end;
10068
10069 {LogMemoryManagerStateToFile subroutine: An InsertionSort routine for sorting a TMemoryLogNodes array.}
10070 procedure InsertionSortLogNodes(APLeftItem: PMemoryLogNodes; ARightIndex: Integer);
10071 var
10072 I, J: Integer;
10073 LCurNode: TMemoryLogNode;
10074 begin
10075 for I := 1 to ARightIndex do
10076 begin
10077 LCurNode := APLeftItem[I];
10078 {Scan backwards to find the best insertion spot}
10079 J := I;
10080 while (J > 0) and (APLeftItem[J - 1].TotalMemoryUsage > LCurNode.TotalMemoryUsage) do
10081 begin
10082 APLeftItem[J] := APLeftItem[J - 1];
10083 Dec(J);
10084 end;
10085 APLeftItem[J] := LCurNode;
10086 end;
10087 end;
10088
10089 {Writes a log file containing a summary of the memory mananger state and a summary of allocated blocks grouped by
10090 class. The file will be saved in UTF-8 encoding (in supported Delphi versions). Returns True on success. }
LogMemoryManagerStateToFilenull10091 function LogMemoryManagerStateToFile(const AFileName: string; const AAdditionalDetails: string): Boolean;
10092 const
10093 MsgBufferSize = 65536;
10094 MaxLineLength = 512;
10095 {Write the UTF-8 BOM in Delphi versions that support UTF-8 conversion.}
10096 LogStateHeaderMsg = {$ifdef BCB6OrDelphi7AndUp}#$EF#$BB#$BF + {$endif}
10097 'FastMM State Capture:'#13#10'---------------------'#13#10#13#10;
10098 LogStateAllocatedMsg = 'K Allocated'#13#10;
10099 LogStateOverheadMsg = 'K Overhead'#13#10;
10100 LogStateEfficiencyMsg = '% Efficiency'#13#10#13#10'Usage Detail:'#13#10;
10101 LogStateAdditionalInfoMsg = #13#10'Additional Information:'#13#10'-----------------------'#13#10;
10102 var
10103 LPLogInfo: PMemoryLogInfo;
10104 LInd: Integer;
10105 LPNode: PMemoryLogNode;
10106 LMsgBuffer: array[0..MsgBufferSize - 1] of AnsiChar;
10107 LPMsg: PAnsiChar;
10108 LBufferSpaceUsed, LBytesWritten: Cardinal;
10109 LFileHandle: NativeUInt;
10110 LMemoryManagerUsageSummary: TMemoryManagerUsageSummary;
10111 LUTF8Str: AnsiString;
10112 begin
10113 {Get the current memory manager usage summary.}
10114 GetMemoryManagerUsageSummary(LMemoryManagerUsageSummary);
10115 {Allocate the memory required to capture detailed allocation information.}
10116 LPLogInfo := VirtualAlloc(nil, SizeOf(TMemoryLogInfo), MEM_COMMIT or MEM_TOP_DOWN, PAGE_READWRITE);
10117 if LPLogInfo <> nil then
10118 begin
10119 try
10120 {Log all allocated blocks by class.}
10121 WalkAllocatedBlocks(LogMemoryManagerStateCallBack, LPLogInfo);
10122 {Sort the classes by total memory usage: Do the initial QuickSort pass over the list to sort the list in groups
10123 of QuickSortMinimumItemsInPartition size.}
10124 if LPLogInfo.NodeCount >= QuickSortMinimumItemsInPartition then
10125 QuickSortLogNodes(@LPLogInfo.Nodes[0], LPLogInfo.NodeCount - 1);
10126 {Do the final InsertionSort pass.}
10127 InsertionSortLogNodes(@LPLogInfo.Nodes[0], LPLogInfo.NodeCount - 1);
10128 {Create the output file}
10129 {$ifdef POSIX}
10130 lFileHandle := FileCreate(AFilename);
10131 {$else}
10132 LFileHandle := CreateFile(PChar(AFilename), GENERIC_READ or GENERIC_WRITE, 0,
10133 nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
10134 {$endif}
10135 if LFileHandle <> INVALID_HANDLE_VALUE then
10136 begin
10137 try
10138 {Log the usage summary}
10139 LPMsg := @LMsgBuffer;
10140 LPMsg := AppendStringToBuffer(LogStateHeaderMsg, LPMsg, Length(LogStateHeaderMsg));
10141 LPMsg := NativeUIntToStrBuf(LMemoryManagerUsageSummary.AllocatedBytes shr 10, LPMsg);
10142 LPMsg := AppendStringToBuffer(LogStateAllocatedMsg, LPMsg, Length(LogStateAllocatedMsg));
10143 LPMsg := NativeUIntToStrBuf(LMemoryManagerUsageSummary.OverheadBytes shr 10, LPMsg);
10144 LPMsg := AppendStringToBuffer(LogStateOverheadMsg, LPMsg, Length(LogStateOverheadMsg));
10145 LPMsg := NativeUIntToStrBuf(Round(LMemoryManagerUsageSummary.EfficiencyPercentage), LPMsg);
10146 LPMsg := AppendStringToBuffer(LogStateEfficiencyMsg, LPMsg, Length(LogStateEfficiencyMsg));
10147 {Log the allocation detail}
10148 for LInd := LPLogInfo.NodeCount - 1 downto 0 do
10149 begin
10150 LPNode := @LPLogInfo.Nodes[LInd];
10151 {Add the allocated size}
10152 LPMsg^ := ' ';
10153 Inc(LPMsg);
10154 LPMsg := NativeUIntToStrBuf(LPNode.TotalMemoryUsage, LPMsg);
10155 LPMsg := AppendStringToBuffer(BytesMessage, LPMsg, Length(BytesMessage));
10156 {Add the class type}
10157 case NativeInt(LPNode.ClassPtr) of
10158 {Unknown}
10159 0:
10160 begin
10161 LPMsg := AppendStringToBuffer(UnknownClassNameMsg, LPMsg, Length(UnknownClassNameMsg));
10162 end;
10163 {AnsiString}
10164 1:
10165 begin
10166 LPMsg := AppendStringToBuffer(AnsiStringBlockMessage, LPMsg, Length(AnsiStringBlockMessage));
10167 end;
10168 {UnicodeString}
10169 2:
10170 begin
10171 LPMsg := AppendStringToBuffer(UnicodeStringBlockMessage, LPMsg, Length(UnicodeStringBlockMessage));
10172 end;
10173 {Classes}
10174 else
10175 begin
10176 LPMsg := AppendClassNameToBuffer(LPNode.ClassPtr, LPMsg);
10177 end;
10178 end;
10179 {Add the count}
10180 LPMsg^ := ' ';
10181 Inc(LPMsg);
10182 LPMsg^ := 'x';
10183 Inc(LPMsg);
10184 LPMsg^ := ' ';
10185 Inc(LPMsg);
10186 LPMsg := NativeUIntToStrBuf(LPNode.InstanceCount, LPMsg);
10187 LPMsg^ := #13;
10188 Inc(LPMsg);
10189 LPMsg^ := #10;
10190 Inc(LPMsg);
10191 {Flush the buffer?}
10192 LBufferSpaceUsed := NativeInt(LPMsg) - NativeInt(@LMsgBuffer);
10193 if LBufferSpaceUsed > (MsgBufferSize - MaxLineLength) then
10194 begin
10195 WriteFile(LFileHandle, LMsgBuffer, LBufferSpaceUsed, LBytesWritten, nil);
10196 LPMsg := @LMsgBuffer;
10197 end;
10198 end;
10199 if AAdditionalDetails <> '' then
10200 LPMsg := AppendStringToBuffer(LogStateAdditionalInfoMsg, LPMsg, Length(LogStateAdditionalInfoMsg));
10201 {Flush any remaining bytes}
10202 LBufferSpaceUsed := NativeInt(LPMsg) - NativeInt(@LMsgBuffer);
10203 if LBufferSpaceUsed > 0 then
10204 WriteFile(LFileHandle, LMsgBuffer, LBufferSpaceUsed, LBytesWritten, nil);
10205 {Write the additional info}
10206 if AAdditionalDetails <> '' then
10207 begin
10208 {$ifdef BCB6OrDelphi7AndUp}
10209 LUTF8Str := UTF8Encode(AAdditionalDetails);
10210 {$else}
10211 LUTF8Str := AAdditionalDetails;
10212 {$endif}
10213 WriteFile(LFileHandle, LUTF8Str[1], Length(LUTF8Str), LBytesWritten, nil);
10214 end;
10215 {Success}
10216 Result := True;
10217 finally
10218 {Close the file}
10219 {$ifdef POSIX}
10220 __close(LFileHandle)
10221 {$else}
10222 CloseHandle(LFileHandle);
10223 {$endif}
10224 end;
10225 end
10226 else
10227 Result := False;
10228 finally
10229 VirtualFree(LPLogInfo, 0, MEM_RELEASE);
10230 end;
10231 end
10232 else
10233 Result := False;
10234 end;
10235
10236 {-----------CheckBlocksOnShutdown implementation------------}
10237
10238 {Checks blocks for modification after free and also for memory leaks}
10239 procedure CheckBlocksOnShutdown(ACheckForLeakedBlocks: Boolean);
10240 {$ifdef EnableMemoryLeakReporting}
10241 type
10242 {Leaked class type}
10243 TLeakedClass = record
10244 ClassPointer: TClass;
10245 {$ifdef CheckCppObjectTypeEnabled}
10246 CppTypeIdPtr: Pointer;
10247 {$endif}
10248 NumLeaks: Cardinal;
10249 end;
10250 TLeakedClasses = array[0..255] of TLeakedClass;
10251 PLeakedClasses = ^TLeakedClasses;
10252 {Leak statistics for a small block type}
10253 TSmallBlockLeaks = array[0..NumSmallBlockTypes - 1] of TLeakedClasses;
10254 {A leaked medium or large block}
10255 TMediumAndLargeBlockLeaks = array[0..4095] of NativeUInt;
10256 {$endif}
10257 var
10258 {$ifdef EnableMemoryLeakReporting}
10259 {The leaked classes for small blocks}
10260 LSmallBlockLeaks: TSmallBlockLeaks;
10261 LLeakType: TMemoryLeakType;
10262 {$ifdef CheckCppObjectTypeEnabled}
10263 LLeakedCppTypeIdPtr: Pointer;
10264 LCppTypeName: PAnsiChar;
10265 {$endif}
10266 LMediumAndLargeBlockLeaks: TMediumAndLargeBlockLeaks;
10267 LNumMediumAndLargeLeaks: Integer;
10268 LPLargeBlock: PLargeBlockHeader;
10269 LLeakMessage: array[0..32767] of AnsiChar;
10270 {$ifndef NoMessageBoxes}
10271 LMessageTitleBuffer: array[0..1023] of AnsiChar;
10272 {$endif}
10273 LMsgPtr: PAnsiChar;
10274 LExpectedLeaksOnly, LSmallLeakHeaderAdded, LBlockSizeHeaderAdded: Boolean;
10275 LBlockTypeInd, LClassInd, LBlockInd: Cardinal;
10276 LMediumBlockSize, LPreviousBlockSize, LLargeBlockSize, LThisBlockSize: NativeUInt;
10277 {$endif}
10278 LPMediumBlock: Pointer;
10279 LPMediumBlockPoolHeader: PMediumBlockPoolHeader;
10280 LMediumBlockHeader: NativeUInt;
10281
10282 {$ifdef EnableMemoryLeakReporting}
10283 {Tries to account for a memory leak. Returns true if the leak is expected and
10284 removes the leak from the list}
GetMemoryLeakTypenull10285 function GetMemoryLeakType(AAddress: Pointer; ASpaceInsideBlock: NativeUInt): TMemoryLeakType;
10286 var
10287 LLeak: TExpectedMemoryLeak;
10288 begin
10289 {Default to not found}
10290 Result := mltUnexpectedLeak;
10291 if ExpectedMemoryLeaks <> nil then
10292 begin
10293 {Check by pointer address}
10294 LLeak.LeakAddress := AAddress;
10295 LLeak.LeakedClass := nil;
10296 {$ifdef CheckCppObjectTypeEnabled}
10297 LLeak.LeakedCppTypeIdPtr := nil;
10298 {$endif}
10299 LLeak.LeakSize := 0;
10300 LLeak.LeakCount := -1;
10301 if UpdateExpectedLeakList(@ExpectedMemoryLeaks.FirstEntryByAddress, @LLeak, False) then
10302 begin
10303 Result := mltExpectedLeakRegisteredByPointer;
10304 Exit;
10305 end;
10306 {Check by class}
10307 LLeak.LeakAddress := nil;
10308 {$ifdef FullDebugMode}
10309 LLeak.LeakedClass := TClass(PNativeUInt(PByte(AAddress)+ SizeOf(TFullDebugBlockHeader))^);
10310 {$else}
10311 LLeak.LeakedClass := TClass(PNativeUInt(AAddress)^);
10312 {$endif}
10313 {$ifdef CheckCppObjectTypeEnabled}
10314 if Assigned(GetCppVirtObjTypeIdPtrFunc) then
10315 begin
10316 {$ifdef FullDebugMode}
10317 LLeak.LeakedCppTypeIdPtr := GetCppVirtObjTypeIdPtrFunc(Pointer(PByte(AAddress)
10318 + SizeOf(TFullDebugBlockHeader)), ASpaceInsideBlock);
10319 {$else}
10320 LLeak.LeakedCppTypeIdPtr := GetCppVirtObjTypeIdPtrFunc(AAddress, ASpaceInsideBlock);
10321 {$endif}
10322 end;
10323 LLeakedCppTypeIdPtr := LLeak.LeakedCppTypeIdPtr;
10324 {$endif}
10325 LLeak.LeakSize := ASpaceInsideBlock;
10326 if UpdateExpectedLeakList(@ExpectedMemoryLeaks.FirstEntryByClass, @LLeak, False) then
10327 begin
10328 Result := mltExpectedLeakRegisteredByClass;
10329 Exit;
10330 end;
10331 {Check by size: the block must be large enough to hold the leak}
10332 LLeak.LeakedClass := nil;
10333 if UpdateExpectedLeakList(@ExpectedMemoryLeaks.FirstEntryBySizeOnly, @LLeak, False) then
10334 Result := mltExpectedLeakRegisteredBySize;
10335 end;
10336 end;
10337
10338 {Checks the small block pool for leaks.}
10339 procedure CheckSmallBlockPoolForLeaks(APSmallBlockPool: PSmallBlockPoolHeader);
10340 var
10341 LLeakedClass: TClass;
10342 {$ifdef CheckCppObjectTypeEnabled}
10343 LLeakedCppObjectTypeId: Pointer;
10344 {$endif}
10345 LSmallBlockLeakType: TMemoryLeakType;
10346 LClassIndex: Integer;
10347 LCurPtr, LEndPtr, LDataPtr: Pointer;
10348 LBlockTypeIndex: Cardinal;
10349 LPLeakedClasses: PLeakedClasses;
10350 LSmallBlockSize: Cardinal;
10351 begin
10352 {Get the useable size inside a block}
10353 LSmallBlockSize := APSmallBlockPool.BlockType.BlockSize - BlockHeaderSize;
10354 {$ifdef FullDebugMode}
10355 Dec(LSmallBlockSize, FullDebugBlockOverhead);
10356 {$endif}
10357 {Get the block type index}
10358 LBlockTypeIndex := (UIntPtr(APSmallBlockPool.BlockType) - UIntPtr(@SmallBlockTypes[0])) div SizeOf(TSmallBlockType);
10359 LPLeakedClasses := @LSmallBlockLeaks[LBlockTypeIndex];
10360 {Get the first and last pointer for the pool}
10361 GetFirstAndLastSmallBlockInPool(APSmallBlockPool, LCurPtr, LEndPtr);
10362 {Step through all blocks}
10363 while UIntPtr(LCurPtr) <= UIntPtr(LEndPtr) do
10364 begin
10365 {Is this block in use? If so, is the debug info intact?}
10366 if ((PNativeUInt(PByte(LCurPtr) - BlockHeaderSize)^ and IsFreeBlockFlag) = 0) then
10367 begin
10368 {$ifdef FullDebugMode}
10369 if CheckBlockBeforeFreeOrRealloc(LCurPtr, boBlockCheck) then
10370 {$endif}
10371 begin
10372 {$ifdef CheckCppObjectTypeEnabled}
10373 LLeakedCppTypeIdPtr := nil;
10374 {$endif}
10375 {Get the leak type}
10376 LSmallBlockLeakType := GetMemoryLeakType(LCurPtr, LSmallBlockSize);
10377 {$ifdef LogMemoryLeakDetailToFile}
10378 {$ifdef HideExpectedLeaksRegisteredByPointer}
10379 if LSmallBlockLeakType <> mltExpectedLeakRegisteredByPointer then
10380 {$endif}
10381 LogMemoryLeakOrAllocatedBlock(LCurPtr, True);
10382 {$endif}
10383 {Only expected leaks?}
10384 LExpectedLeaksOnly := LExpectedLeaksOnly and (LSmallBlockLeakType <> mltUnexpectedLeak);
10385 {$ifdef HideExpectedLeaksRegisteredByPointer}
10386 if LSmallBlockLeakType <> mltExpectedLeakRegisteredByPointer then
10387 {$endif}
10388 begin
10389 {Get a pointer to the user data}
10390 {$ifndef FullDebugMode}
10391 LDataPtr := LCurPtr;
10392 {$else}
10393 LDataPtr := Pointer(PByte(LCurPtr) + SizeOf(TFullDebugBlockHeader));
10394 {$endif}
10395 {Default to an unknown block}
10396 LClassIndex := 0;
10397 {Get the class contained by the block}
10398 LLeakedClass := DetectClassInstance(LDataPtr);
10399 {Not a Delphi class? -> is it perhaps a string or C++ object type?}
10400 if LLeakedClass = nil then
10401 begin
10402 {$ifdef CheckCppObjectTypeEnabled}
10403 LLeakedCppObjectTypeId := LLeakedCppTypeIdPtr;
10404 if (LLeakedCppObjectTypeId = nil) and (ExpectedMemoryLeaks = nil) then
10405 begin
10406 if Assigned(GetCppVirtObjTypeIdPtrFunc) then
10407 begin
10408 LLeakedCppObjectTypeId := GetCppVirtObjTypeIdPtrFunc(LDataPtr, LSmallBlockSize);
10409 end;
10410 end;
10411 if Assigned(LLeakedCppObjectTypeId) then
10412 begin
10413 LClassIndex := 3;
10414 while LClassIndex <= High(TLeakedClasses) do
10415 begin
10416 if (Pointer(LPLeakedClasses[LClassIndex].CppTypeIdPtr) = LLeakedCppObjectTypeId)
10417 or ((LPLeakedClasses[LClassIndex].CppTypeIdPtr = nil)
10418 and (LPLeakedClasses[LClassIndex].ClassPointer = nil)) then
10419 begin
10420 Break;
10421 end;
10422 Inc(LClassIndex);
10423 end;
10424 if LClassIndex <= High(TLeakedClasses) then
10425 Pointer(LPLeakedClasses[LClassIndex].CppTypeIdPtr) := LLeakedCppObjectTypeId
10426 else
10427 LClassIndex := 0;
10428 end
10429 else
10430 begin
10431 {$endif}
10432 {Not a known class: Is it perhaps string data?}
10433 case DetectStringData(LDataPtr, APSmallBlockPool.BlockType.BlockSize - (BlockHeaderSize {$ifdef FullDebugMode} + FullDebugBlockOverhead{$endif})) of
10434 stAnsiString: LClassIndex := 1;
10435 stUnicodeString: LClassIndex := 2;
10436 end;
10437 {$ifdef CheckCppObjectTypeEnabled}
10438 end;
10439 {$endif}
10440 end
10441 else
10442 begin
10443 LClassIndex := 3;
10444 while LClassIndex <= High(TLeakedClasses) do
10445 begin
10446 if (LPLeakedClasses[LClassIndex].ClassPointer = LLeakedClass)
10447 or ((LPLeakedClasses[LClassIndex].ClassPointer = nil)
10448 {$ifdef CheckCppObjectTypeEnabled}
10449 and (LPLeakedClasses[LClassIndex].CppTypeIdPtr = nil)
10450 {$endif}
10451 ) then
10452 begin
10453 Break;
10454 end;
10455 Inc(LClassIndex);
10456 end;
10457 if LClassIndex <= High(TLeakedClasses) then
10458 LPLeakedClasses[LClassIndex].ClassPointer := LLeakedClass
10459 else
10460 LClassIndex := 0;
10461 end;
10462 {Add to the number of leaks for the class}
10463 Inc(LPLeakedClasses[LClassIndex].NumLeaks);
10464 end;
10465 end;
10466 end
10467 else
10468 begin
10469 {$ifdef CheckUseOfFreedBlocksOnShutdown}
10470 {Check that the block has not been modified since being freed}
10471 CheckFreeBlockUnmodified(LCurPtr, APSmallBlockPool.BlockType.BlockSize, boBlockCheck);
10472 {$endif}
10473 end;
10474 {Next block}
10475 Inc(PByte(LCurPtr), APSmallBlockPool.BlockType.BlockSize);
10476 end;
10477 end;
10478 {$endif}
10479
10480 begin
10481 {$ifdef EnableMemoryLeakReporting}
10482 {Clear the leak arrays}
10483 FillChar(LSmallBlockLeaks, SizeOf(LSmallBlockLeaks), 0);
10484 FillChar(LMediumAndLargeBlockLeaks, SizeOf(LMediumAndLargeBlockLeaks), 0);
10485 {Step through all the medium block pools}
10486 LNumMediumAndLargeLeaks := 0;
10487 {No unexpected leaks so far}
10488 LExpectedLeaksOnly := True;
10489 {$endif}
10490 {Step through all the medium block pools}
10491 LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader;
10492 while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do
10493 begin
10494 LPMediumBlock := GetFirstMediumBlockInPool(LPMediumBlockPoolHeader);
10495 while LPMediumBlock <> nil do
10496 begin
10497 LMediumBlockHeader := PNativeUInt(PByte(LPMediumBlock) - BlockHeaderSize)^;
10498 {Is the block in use?}
10499 if LMediumBlockHeader and IsFreeBlockFlag = 0 then
10500 begin
10501 {$ifdef EnableMemoryLeakReporting}
10502 if ACheckForLeakedBlocks then
10503 begin
10504 if (LMediumBlockHeader and IsSmallBlockPoolInUseFlag) <> 0 then
10505 begin
10506 {Get all the leaks for the small block pool}
10507 CheckSmallBlockPoolForLeaks(LPMediumBlock);
10508 end
10509 else
10510 begin
10511 if (LNumMediumAndLargeLeaks < Length(LMediumAndLargeBlockLeaks))
10512 {$ifdef FullDebugMode}
10513 and CheckBlockBeforeFreeOrRealloc(LPMediumBlock, boBlockCheck)
10514 {$endif}
10515 then
10516 begin
10517 LMediumBlockSize := (LMediumBlockHeader and DropMediumAndLargeFlagsMask) - BlockHeaderSize;
10518 {$ifdef FullDebugMode}
10519 Dec(LMediumBlockSize, FullDebugBlockOverhead);
10520 {$endif}
10521 {Get the leak type}
10522 LLeakType := GetMemoryLeakType(LPMediumBlock, LMediumBlockSize);
10523 {Is it an expected leak?}
10524 LExpectedLeaksOnly := LExpectedLeaksOnly and (LLeakType <> mltUnexpectedLeak);
10525 {$ifdef LogMemoryLeakDetailToFile}
10526 {$ifdef HideExpectedLeaksRegisteredByPointer}
10527 if LLeakType <> mltExpectedLeakRegisteredByPointer then
10528 {$endif}
10529 LogMemoryLeakOrAllocatedBlock(LPMediumBlock, True);
10530 {$endif}
10531 {$ifdef HideExpectedLeaksRegisteredByPointer}
10532 if LLeakType <> mltExpectedLeakRegisteredByPointer then
10533 {$endif}
10534 begin
10535 {Add the leak to the list}
10536 LMediumAndLargeBlockLeaks[LNumMediumAndLargeLeaks] := LMediumBlockSize;
10537 Inc(LNumMediumAndLargeLeaks);
10538 end;
10539 end;
10540 end;
10541 end;
10542 {$endif}
10543 end
10544 else
10545 begin
10546 {$ifdef CheckUseOfFreedBlocksOnShutdown}
10547 {Check that the block has not been modified since being freed}
10548 CheckFreeBlockUnmodified(LPMediumBlock, LMediumBlockHeader and DropMediumAndLargeFlagsMask, boBlockCheck);
10549 {$endif}
10550 end;
10551 {Next medium block}
10552 LPMediumBlock := NextMediumBlock(LPMediumBlock);
10553 end;
10554 {Get the next medium block pool}
10555 LPMediumBlockPoolHeader := LPMediumBlockPoolHeader.NextMediumBlockPoolHeader;
10556 end;
10557 {$ifdef EnableMemoryLeakReporting}
10558 if ACheckForLeakedBlocks then
10559 begin
10560 {Get all leaked large blocks}
10561 LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader;
10562 while LPLargeBlock <> @LargeBlocksCircularList do
10563 begin
10564 if (LNumMediumAndLargeLeaks < length(LMediumAndLargeBlockLeaks))
10565 {$ifdef FullDebugMode}
10566 and CheckBlockBeforeFreeOrRealloc(Pointer(PByte(LPLargeBlock) + LargeBlockHeaderSize), boBlockCheck)
10567 {$endif}
10568 then
10569 begin
10570 LLargeBlockSize := (LPLargeBlock.BlockSizeAndFlags and DropMediumAndLargeFlagsMask) - BlockHeaderSize - LargeBlockHeaderSize;
10571 {$ifdef FullDebugMode}
10572 Dec(LLargeBlockSize, FullDebugBlockOverhead);
10573 {$endif}
10574 {Get the leak type}
10575 LLeakType := GetMemoryLeakType(Pointer(PByte(LPLargeBlock) + LargeBlockHeaderSize), LLargeBlockSize);
10576 {Is it an expected leak?}
10577 LExpectedLeaksOnly := LExpectedLeaksOnly and (LLeakType <> mltUnexpectedLeak);
10578 {$ifdef LogMemoryLeakDetailToFile}
10579 {$ifdef HideExpectedLeaksRegisteredByPointer}
10580 if LLeakType <> mltExpectedLeakRegisteredByPointer then
10581 {$endif}
10582 LogMemoryLeakOrAllocatedBlock(Pointer(PByte(LPLargeBlock) + LargeBlockHeaderSize), True);
10583 {$endif}
10584 {$ifdef HideExpectedLeaksRegisteredByPointer}
10585 if LLeakType <> mltExpectedLeakRegisteredByPointer then
10586 {$endif}
10587 begin
10588 {Add the leak}
10589 LMediumAndLargeBlockLeaks[LNumMediumAndLargeLeaks] := LLargeBlockSize;
10590 Inc(LNumMediumAndLargeLeaks);
10591 end;
10592 end;
10593 {Get the next large block}
10594 LPLargeBlock := LPLargeBlock.NextLargeBlockHeader;
10595 end;
10596 {Display the leak message if required}
10597 if not LExpectedLeaksOnly then
10598 begin
10599 {Small leak header has not been added}
10600 LSmallLeakHeaderAdded := False;
10601 LPreviousBlockSize := 0;
10602 {Set up the leak message header so long}
10603 LMsgPtr := AppendStringToBuffer(LeakMessageHeader, @LLeakMessage[0], length(LeakMessageHeader));
10604 {Step through all the small block types}
10605 for LBlockTypeInd := 0 to NumSmallBlockTypes - 1 do
10606 begin
10607 LThisBlockSize := SmallBlockTypes[LBlockTypeInd].BlockSize - BlockHeaderSize;
10608 {$ifdef FullDebugMode}
10609 Dec(LThisBlockSize, FullDebugBlockOverhead);
10610 if NativeInt(LThisBlockSize) < 0 then
10611 LThisBlockSize := 0;
10612 {$endif}
10613 LBlockSizeHeaderAdded := False;
10614 {Any leaks?}
10615 for LClassInd := High(LSmallBlockLeaks[LBlockTypeInd]) downto 0 do
10616 begin
10617 {Is there still space in the message buffer? Reserve space for the message
10618 footer.}
10619 if LMsgPtr > @LLeakMessage[High(LLeakMessage) - 2048] then
10620 Break;
10621 {Check the count}
10622 if LSmallBlockLeaks[LBlockTypeInd][LClassInd].NumLeaks > 0 then
10623 begin
10624 {Need to add the header?}
10625 if not LSmallLeakHeaderAdded then
10626 begin
10627 LMsgPtr := AppendStringToBuffer(SmallLeakDetail, LMsgPtr, Length(SmallLeakDetail));
10628 LSmallLeakHeaderAdded := True;
10629 end;
10630 {Need to add the size header?}
10631 if not LBlockSizeHeaderAdded then
10632 begin
10633 LMsgPtr^ := #13;
10634 Inc(LMsgPtr);
10635 LMsgPtr^ := #10;
10636 Inc(LMsgPtr);
10637 LMsgPtr := NativeUIntToStrBuf(LPreviousBlockSize + 1, LMsgPtr);
10638 LMsgPtr^ := ' ';
10639 Inc(LMsgPtr);
10640 LMsgPtr^ := '-';
10641 Inc(LMsgPtr);
10642 LMsgPtr^ := ' ';
10643 Inc(LMsgPtr);
10644 LMsgPtr := NativeUIntToStrBuf(LThisBlockSize, LMsgPtr);
10645 LMsgPtr := AppendStringToBuffer(BytesMessage, LMsgPtr, Length(BytesMessage));
10646 LBlockSizeHeaderAdded := True;
10647 end
10648 else
10649 begin
10650 LMsgPtr^ := ',';
10651 Inc(LMsgPtr);
10652 LMsgPtr^ := ' ';
10653 Inc(LMsgPtr);
10654 end;
10655 {Show the count}
10656 case LClassInd of
10657 {Unknown}
10658 0:
10659 begin
10660 LMsgPtr := AppendStringToBuffer(UnknownClassNameMsg, LMsgPtr, Length(UnknownClassNameMsg));
10661 end;
10662 {AnsiString}
10663 1:
10664 begin
10665 LMsgPtr := AppendStringToBuffer(AnsiStringBlockMessage, LMsgPtr, Length(AnsiStringBlockMessage));
10666 end;
10667 {UnicodeString}
10668 2:
10669 begin
10670 LMsgPtr := AppendStringToBuffer(UnicodeStringBlockMessage, LMsgPtr, Length(UnicodeStringBlockMessage));
10671 end;
10672 {Classes}
10673 else
10674 begin
10675 {$ifdef CheckCppObjectTypeEnabled}
10676 if LSmallBlockLeaks[LBlockTypeInd][LClassInd].CppTypeIdPtr <> nil then
10677 begin
10678 if Assigned(GetCppVirtObjTypeNameByTypeIdPtrFunc) then
10679 begin
10680 LCppTypeName := GetCppVirtObjTypeNameByTypeIdPtrFunc(LSmallBlockLeaks[LBlockTypeInd][LClassInd].CppTypeIdPtr);
10681 LMsgPtr := AppendStringToBuffer(LCppTypeName, LMsgPtr, StrLen(LCppTypeName));
10682 end
10683 else
10684 LMsgPtr := AppendClassNameToBuffer(nil, LMsgPtr);
10685 end
10686 else
10687 begin
10688 {$endif}
10689 LMsgPtr := AppendClassNameToBuffer(LSmallBlockLeaks[LBlockTypeInd][LClassInd].ClassPointer, LMsgPtr);
10690 {$ifdef CheckCppObjectTypeEnabled}
10691 end;
10692 {$endif}
10693 end;
10694 end;
10695 {Add the count}
10696 LMsgPtr^ := ' ';
10697 Inc(LMsgPtr);
10698 LMsgPtr^ := 'x';
10699 Inc(LMsgPtr);
10700 LMsgPtr^ := ' ';
10701 Inc(LMsgPtr);
10702 LMsgPtr := NativeUIntToStrBuf(LSmallBlockLeaks[LBlockTypeInd][LClassInd].NumLeaks, LMsgPtr);
10703 end;
10704 end;
10705 LPreviousBlockSize := LThisBlockSize;
10706 end;
10707 {Add the medium/large block leak message}
10708 if LNumMediumAndLargeLeaks > 0 then
10709 begin
10710 {Any non-small leaks?}
10711 if LSmallLeakHeaderAdded then
10712 begin
10713 LMsgPtr^ := #13;
10714 Inc(LMsgPtr);
10715 LMsgPtr^ := #10;
10716 Inc(LMsgPtr);
10717 LMsgPtr^ := #13;
10718 Inc(LMsgPtr);
10719 LMsgPtr^ := #10;
10720 Inc(LMsgPtr);
10721 end;
10722 {Add the medium/large block leak message}
10723 LMsgPtr := AppendStringToBuffer(LargeLeakDetail, LMsgPtr, Length(LargeLeakDetail));
10724 {List all the blocks}
10725 for LBlockInd := 0 to LNumMediumAndLargeLeaks - 1 do
10726 begin
10727 if LBlockInd <> 0 then
10728 begin
10729 LMsgPtr^ := ',';
10730 Inc(LMsgPtr);
10731 LMsgPtr^ := ' ';
10732 Inc(LMsgPtr);
10733 end;
10734 LMsgPtr := NativeUIntToStrBuf(LMediumAndLargeBlockLeaks[LBlockInd], LMsgPtr);
10735 {Is there still space in the message buffer? Reserve space for the
10736 message footer.}
10737 if LMsgPtr > @LLeakMessage[High(LLeakMessage) - 2048] then
10738 Break;
10739 end;
10740 end;
10741 {$ifdef LogErrorsToFile}
10742 {Set the message footer}
10743 LMsgPtr := AppendStringToBuffer(LeakMessageFooter, LMsgPtr, Length(LeakMessageFooter));
10744 {Append the message to the memory errors file}
10745 AppendEventLog(@LLeakMessage[0], UIntPtr(LMsgPtr) - UIntPtr(@LLeakMessage[1]));
10746 {$else}
10747 {Set the message footer}
10748 AppendStringToBuffer(LeakMessageFooter, LMsgPtr, Length(LeakMessageFooter));
10749 {$endif}
10750 {$ifdef UseOutputDebugString}
10751 OutputDebugStringA(LLeakMessage);
10752 {$endif}
10753 {$ifndef NoMessageBoxes}
10754 {Show the message}
10755 AppendStringToModuleName(LeakMessageTitle, LMessageTitleBuffer);
10756 ShowMessageBox(LLeakMessage, LMessageTitleBuffer);
10757 {$endif}
10758 end;
10759 end;
10760 {$endif}
10761 end;
10762
10763 {Returns statistics about the current state of the memory manager}
10764 procedure GetMemoryManagerState(var AMemoryManagerState: TMemoryManagerState);
10765 var
10766 LPMediumBlockPoolHeader: PMediumBlockPoolHeader;
10767 LPMediumBlock: Pointer;
10768 LInd: Integer;
10769 LBlockTypeIndex, LMediumBlockSize: Cardinal;
10770 LMediumBlockHeader, LLargeBlockSize: NativeUInt;
10771 LPLargeBlock: PLargeBlockHeader;
10772 begin
10773 {Clear the structure}
10774 FillChar(AMemoryManagerState, SizeOf(AMemoryManagerState), 0);
10775 {Set the small block size stats}
10776 for LInd := 0 to NumSmallBlockTypes - 1 do
10777 begin
10778 AMemoryManagerState.SmallBlockTypeStates[LInd].InternalBlockSize :=
10779 SmallBlockTypes[LInd].BlockSize;
10780 AMemoryManagerState.SmallBlockTypeStates[LInd].UseableBlockSize :=
10781 SmallBlockTypes[LInd].BlockSize - BlockHeaderSize{$ifdef FullDebugMode} - FullDebugBlockOverhead{$endif};
10782 if NativeInt(AMemoryManagerState.SmallBlockTypeStates[LInd].UseableBlockSize) < 0 then
10783 AMemoryManagerState.SmallBlockTypeStates[LInd].UseableBlockSize := 0;
10784 end;
10785 {Lock all small block types}
10786 LockAllSmallBlockTypes;
10787 {Lock the medium blocks}
10788 LockMediumBlocks;
10789 {Step through all the medium block pools}
10790 LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader;
10791 while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do
10792 begin
10793 {Add to the medium block used space}
10794 Inc(AMemoryManagerState.ReservedMediumBlockAddressSpace, MediumBlockPoolSize);
10795 LPMediumBlock := GetFirstMediumBlockInPool(LPMediumBlockPoolHeader);
10796 while LPMediumBlock <> nil do
10797 begin
10798 LMediumBlockHeader := PNativeUInt(PByte(LPMediumBlock) - BlockHeaderSize)^;
10799 {Is the block in use?}
10800 if LMediumBlockHeader and IsFreeBlockFlag = 0 then
10801 begin
10802 {Get the block size}
10803 LMediumBlockSize := LMediumBlockHeader and DropMediumAndLargeFlagsMask;
10804 if (LMediumBlockHeader and IsSmallBlockPoolInUseFlag) <> 0 then
10805 begin
10806 {Get the block type index}
10807 LBlockTypeIndex := (UIntPtr(PSmallBlockPoolHeader(LPMediumBlock).BlockType) - UIntPtr(@SmallBlockTypes[0])) div SizeOf(TSmallBlockType);
10808 {Subtract from medium block usage}
10809 Dec(AMemoryManagerState.ReservedMediumBlockAddressSpace, LMediumBlockSize);
10810 {Add it to the reserved space for the block size}
10811 Inc(AMemoryManagerState.SmallBlockTypeStates[LBlockTypeIndex].ReservedAddressSpace, LMediumBlockSize);
10812 {Add the usage for the pool}
10813 Inc(AMemoryManagerState.SmallBlockTypeStates[LBlockTypeIndex].AllocatedBlockCount,
10814 PSmallBlockPoolHeader(LPMediumBlock).BlocksInUse);
10815 end
10816 else
10817 begin
10818 {$ifdef FullDebugMode}
10819 Dec(LMediumBlockSize, FullDebugBlockOverhead);
10820 {$endif}
10821 Inc(AMemoryManagerState.AllocatedMediumBlockCount);
10822 Inc(AMemoryManagerState.TotalAllocatedMediumBlockSize, LMediumBlockSize - BlockHeaderSize);
10823 end;
10824 end;
10825 {Next medium block}
10826 LPMediumBlock := NextMediumBlock(LPMediumBlock);
10827 end;
10828 {Get the next medium block pool}
10829 LPMediumBlockPoolHeader := LPMediumBlockPoolHeader.NextMediumBlockPoolHeader;
10830 end;
10831 {Unlock medium blocks}
10832 MediumBlocksLocked := False;
10833 {Unlock all the small block types}
10834 for LInd := 0 to NumSmallBlockTypes - 1 do
10835 SmallBlockTypes[LInd].BlockTypeLocked := False;
10836 {Step through all the large blocks}
10837 LockLargeBlocks;
10838 LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader;
10839 while LPLargeBlock <> @LargeBlocksCircularList do
10840 begin
10841 LLargeBlockSize := LPLargeBlock.BlockSizeAndFlags and DropMediumAndLargeFlagsMask;
10842 Inc(AMemoryManagerState.AllocatedLargeBlockCount);
10843 Inc(AMemoryManagerState.ReservedLargeBlockAddressSpace, LLargeBlockSize);
10844 Inc(AMemoryManagerState.TotalAllocatedLargeBlockSize, LPLargeBlock.UserAllocatedSize);
10845 {Get the next large block}
10846 LPLargeBlock := LPLargeBlock.NextLargeBlockHeader;
10847 end;
10848 LargeBlocksLocked := False;
10849 end;
10850
10851 {Returns a summary of the information returned by GetMemoryManagerState}
10852 procedure GetMemoryManagerUsageSummary(
10853 var AMemoryManagerUsageSummary: TMemoryManagerUsageSummary);
10854 var
10855 LMMS: TMemoryManagerState;
10856 LAllocatedBytes, LReservedBytes: NativeUInt;
10857 LSBTIndex: Integer;
10858 begin
10859 {Get the memory manager state}
10860 GetMemoryManagerState(LMMS);
10861 {Add up the totals}
10862 LAllocatedBytes := LMMS.TotalAllocatedMediumBlockSize
10863 + LMMS.TotalAllocatedLargeBlockSize;
10864 LReservedBytes := LMMS.ReservedMediumBlockAddressSpace
10865 + LMMS.ReservedLargeBlockAddressSpace;
10866 for LSBTIndex := 0 to NumSmallBlockTypes - 1 do
10867 begin
10868 Inc(LAllocatedBytes, LMMS.SmallBlockTypeStates[LSBTIndex].UseableBlockSize
10869 * LMMS.SmallBlockTypeStates[LSBTIndex].AllocatedBlockCount);
10870 Inc(LReservedBytes, LMMS.SmallBlockTypeStates[LSBTIndex].ReservedAddressSpace);
10871 end;
10872 {Set the structure values}
10873 AMemoryManagerUsageSummary.AllocatedBytes := LAllocatedBytes;
10874 AMemoryManagerUsageSummary.OverheadBytes := LReservedBytes - LAllocatedBytes;
10875 if LReservedBytes > 0 then
10876 begin
10877 AMemoryManagerUsageSummary.EfficiencyPercentage :=
10878 LAllocatedBytes / LReservedBytes * 100;
10879 end
10880 else
10881 AMemoryManagerUsageSummary.EfficiencyPercentage := 100;
10882 end;
10883
10884 {$ifndef POSIX}
10885 {Gets the state of every 64K block in the 4GB address space. Under 64-bit this
10886 returns only the state for the low 4GB.}
10887 procedure GetMemoryMap(var AMemoryMap: TMemoryMap);
10888 var
10889 LPMediumBlockPoolHeader: PMediumBlockPoolHeader;
10890 LPLargeBlock: PLargeBlockHeader;
10891 LInd, LChunkIndex, LNextChunk, LLargeBlockSize: NativeUInt;
10892 LMBI: TMemoryBasicInformation;
10893 begin
10894 {Clear the map}
10895 FillChar(AMemoryMap, SizeOf(AMemoryMap), Ord(csUnallocated));
10896 {Step through all the medium block pools}
10897 LockMediumBlocks;
10898 LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader;
10899 while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do
10900 begin
10901 {Add to the medium block used space}
10902 LChunkIndex := NativeUInt(LPMediumBlockPoolHeader) shr 16;
10903 for LInd := 0 to (MediumBlockPoolSize - 1) shr 16 do
10904 begin
10905 if (LChunkIndex + LInd) > High(AMemoryMap) then
10906 Break;
10907 AMemoryMap[LChunkIndex + LInd] := csAllocated;
10908 end;
10909 {Get the next medium block pool}
10910 LPMediumBlockPoolHeader := LPMediumBlockPoolHeader.NextMediumBlockPoolHeader;
10911 end;
10912 MediumBlocksLocked := False;
10913 {Step through all the large blocks}
10914 LockLargeBlocks;
10915 LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader;
10916 while LPLargeBlock <> @LargeBlocksCircularList do
10917 begin
10918 LChunkIndex := UIntPtr(LPLargeBlock) shr 16;
10919 LLargeBlockSize := LPLargeBlock.BlockSizeAndFlags and DropMediumAndLargeFlagsMask;
10920 for LInd := 0 to (LLargeBlockSize - 1) shr 16 do
10921 begin
10922 if (LChunkIndex + LInd) > High(AMemoryMap) then
10923 Break;
10924 AMemoryMap[LChunkIndex + LInd] := csAllocated;
10925 end;
10926 {Get the next large block}
10927 LPLargeBlock := LPLargeBlock.NextLargeBlockHeader;
10928 end;
10929 LargeBlocksLocked := False;
10930 {Fill in the rest of the map}
10931 LInd := 0;
10932 while LInd <= 65535 do
10933 begin
10934 {If the chunk is not allocated by this MM, what is its status?}
10935 if AMemoryMap[LInd] = csUnallocated then
10936 begin
10937 {Query the address space starting at the chunk boundary}
10938 if VirtualQuery(Pointer(LInd * 65536), LMBI, SizeOf(LMBI)) = 0 then
10939 begin
10940 {VirtualQuery may fail for addresses >2GB if a large address space is
10941 not enabled.}
10942 FillChar(AMemoryMap[LInd], 65536 - LInd, csSysReserved);
10943 Break;
10944 end;
10945 {Get the chunk number after the region}
10946 LNextChunk := (LMBI.RegionSize - 1) shr 16 + LInd + 1;
10947 {Validate}
10948 if LNextChunk > 65536 then
10949 LNextChunk := 65536;
10950 {Set the status of all the chunks in the region}
10951 if LMBI.State = MEM_COMMIT then
10952 begin
10953 FillChar(AMemoryMap[LInd], LNextChunk - LInd, csSysAllocated);
10954 end
10955 else
10956 begin
10957 if LMBI.State = MEM_RESERVE then
10958 FillChar(AMemoryMap[LInd], LNextChunk - LInd, csSysReserved);
10959 end;
10960 {Point to the start of the next chunk}
10961 LInd := LNextChunk;
10962 end
10963 else
10964 begin
10965 {Next chunk}
10966 Inc(LInd);
10967 end;
10968 end;
10969 end;
10970 {$endif}
10971
10972 {Returns summarised information about the state of the memory manager. (For
10973 backward compatibility.)}
FastGetHeapStatusnull10974 function FastGetHeapStatus: THeapStatus;
10975 var
10976 LPMediumBlockPoolHeader: PMediumBlockPoolHeader;
10977 LPMediumBlock: Pointer;
10978 LBlockTypeIndex, LMediumBlockSize: Cardinal;
10979 LSmallBlockUsage, LSmallBlockOverhead, LMediumBlockHeader, LLargeBlockSize: NativeUInt;
10980 LInd: Integer;
10981 LPLargeBlock: PLargeBlockHeader;
10982 begin
10983 {Clear the structure}
10984 FillChar(Result, SizeOf(Result), 0);
10985 {Lock all small block types}
10986 LockAllSmallBlockTypes;
10987 {Lock the medium blocks}
10988 LockMediumBlocks;
10989 {Step through all the medium block pools}
10990 LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader;
10991 while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do
10992 begin
10993 {Add to the total and committed address space}
10994 Inc(Result.TotalAddrSpace, ((MediumBlockPoolSize + $ffff) and $ffff0000));
10995 Inc(Result.TotalCommitted, ((MediumBlockPoolSize + $ffff) and $ffff0000));
10996 {Add the medium block pool overhead}
10997 Inc(Result.Overhead, (((MediumBlockPoolSize + $ffff) and $ffff0000)
10998 - MediumBlockPoolSize + MediumBlockPoolHeaderSize));
10999 {Get the first medium block in the pool}
11000 LPMediumBlock := GetFirstMediumBlockInPool(LPMediumBlockPoolHeader);
11001 while LPMediumBlock <> nil do
11002 begin
11003 {Get the block header}
11004 LMediumBlockHeader := PNativeUInt(PByte(LPMediumBlock) - BlockHeaderSize)^;
11005 {Get the block size}
11006 LMediumBlockSize := LMediumBlockHeader and DropMediumAndLargeFlagsMask;
11007 {Is the block in use?}
11008 if LMediumBlockHeader and IsFreeBlockFlag = 0 then
11009 begin
11010 if (LMediumBlockHeader and IsSmallBlockPoolInUseFlag) <> 0 then
11011 begin
11012 {Get the block type index}
11013 LBlockTypeIndex := (UIntPtr(PSmallBlockPoolHeader(LPMediumBlock).BlockType) - UIntPtr(@SmallBlockTypes[0])) div SizeOf(TSmallBlockType);
11014 {Get the usage in the block}
11015 LSmallBlockUsage := PSmallBlockPoolHeader(LPMediumBlock).BlocksInUse
11016 * SmallBlockTypes[LBlockTypeIndex].BlockSize;
11017 {Get the total overhead for all the small blocks}
11018 LSmallBlockOverhead := PSmallBlockPoolHeader(LPMediumBlock).BlocksInUse
11019 * (BlockHeaderSize{$ifdef FullDebugMode} + FullDebugBlockOverhead{$endif});
11020 {Add to the totals}
11021 Inc(Result.FreeSmall, LMediumBlockSize - LSmallBlockUsage - BlockHeaderSize);
11022 Inc(Result.Overhead, LSmallBlockOverhead + BlockHeaderSize);
11023 Inc(Result.TotalAllocated, LSmallBlockUsage - LSmallBlockOverhead);
11024 end
11025 else
11026 begin
11027 {$ifdef FullDebugMode}
11028 Dec(LMediumBlockSize, FullDebugBlockOverhead);
11029 Inc(Result.Overhead, FullDebugBlockOverhead);
11030 {$endif}
11031 {Add to the result}
11032 Inc(Result.TotalAllocated, LMediumBlockSize - BlockHeaderSize);
11033 Inc(Result.Overhead, BlockHeaderSize);
11034 end;
11035 end
11036 else
11037 begin
11038 {The medium block is free}
11039 Inc(Result.FreeBig, LMediumBlockSize);
11040 end;
11041 {Next medium block}
11042 LPMediumBlock := NextMediumBlock(LPMediumBlock);
11043 end;
11044 {Get the next medium block pool}
11045 LPMediumBlockPoolHeader := LPMediumBlockPoolHeader.NextMediumBlockPoolHeader;
11046 end;
11047 {Add the sequential feed unused space}
11048 Inc(Result.Unused, MediumSequentialFeedBytesLeft);
11049 {Unlock the medium blocks}
11050 MediumBlocksLocked := False;
11051 {Unlock all the small block types}
11052 for LInd := 0 to NumSmallBlockTypes - 1 do
11053 SmallBlockTypes[LInd].BlockTypeLocked := False;
11054 {Step through all the large blocks}
11055 LockLargeBlocks;
11056 LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader;
11057 while LPLargeBlock <> @LargeBlocksCircularList do
11058 begin
11059 LLargeBlockSize := LPLargeBlock.BlockSizeAndFlags and DropMediumAndLargeFlagsMask;
11060 Inc(Result.TotalAddrSpace, LLargeBlockSize);
11061 Inc(Result.TotalCommitted, LLargeBlockSize);
11062 Inc(Result.TotalAllocated, LPLargeBlock.UserAllocatedSize
11063 {$ifdef FullDebugMode} - FullDebugBlockOverhead{$endif});
11064 Inc(Result.Overhead, LLargeBlockSize - LPLargeBlock.UserAllocatedSize
11065 {$ifdef FullDebugMode} + FullDebugBlockOverhead{$endif});
11066 {Get the next large block}
11067 LPLargeBlock := LPLargeBlock.NextLargeBlockHeader;
11068 end;
11069 LargeBlocksLocked := False;
11070 {Set the total number of free bytes}
11071 Result.TotalFree := Result.FreeSmall + Result.FreeBig + Result.Unused;
11072 end;
11073
11074 {Frees all allocated memory. Does not support segmented large blocks (yet).}
11075 procedure FreeAllMemory;
11076 var
11077 LPMediumBlockPoolHeader, LPNextMediumBlockPoolHeader: PMediumBlockPoolHeader;
11078 LPMediumFreeBlock: PMediumFreeBlock;
11079 LPLargeBlock, LPNextLargeBlock: PLargeBlockHeader;
11080 LInd: Integer;
11081 begin
11082 {Free all block pools}
11083 LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader;
11084 while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do
11085 begin
11086 {Get the next medium block pool so long}
11087 LPNextMediumBlockPoolHeader := LPMediumBlockPoolHeader.NextMediumBlockPoolHeader;
11088 {$ifdef ClearMediumBlockPoolsBeforeReturningToOS}
11089 FillChar(LPMediumBlockPoolHeader^, MediumBlockPoolSize, 0);
11090 {$else}
11091 {$ifdef ClearSmallAndMediumBlocksInFreeMem}
11092 FillChar(LPMediumBlockPoolHeader^, MediumBlockPoolSize, 0);
11093 {$endif}
11094 {$endif}
11095 {Free this pool}
11096 VirtualFree(LPMediumBlockPoolHeader, 0, MEM_RELEASE);
11097 {Next pool}
11098 LPMediumBlockPoolHeader := LPNextMediumBlockPoolHeader;
11099 end;
11100 {Clear all small block types}
11101 for LInd := 0 to High(SmallBlockTypes) do
11102 begin
11103 SmallBlockTypes[Lind].PreviousPartiallyFreePool := @SmallBlockTypes[Lind];
11104 SmallBlockTypes[Lind].NextPartiallyFreePool := @SmallBlockTypes[Lind];
11105 SmallBlockTypes[Lind].NextSequentialFeedBlockAddress := Pointer(1);
11106 SmallBlockTypes[Lind].MaxSequentialFeedBlockAddress := nil;
11107 end;
11108 {Clear all medium block pools}
11109 MediumBlockPoolsCircularList.PreviousMediumBlockPoolHeader := @MediumBlockPoolsCircularList;
11110 MediumBlockPoolsCircularList.NextMediumBlockPoolHeader := @MediumBlockPoolsCircularList;
11111 {All medium bins are empty}
11112 for LInd := 0 to High(MediumBlockBins) do
11113 begin
11114 LPMediumFreeBlock := @MediumBlockBins[LInd];
11115 LPMediumFreeBlock.PreviousFreeBlock := LPMediumFreeBlock;
11116 LPMediumFreeBlock.NextFreeBlock := LPMediumFreeBlock;
11117 end;
11118 MediumBlockBinGroupBitmap := 0;
11119 FillChar(MediumBlockBinBitmaps, SizeOf(MediumBlockBinBitmaps), 0);
11120 MediumSequentialFeedBytesLeft := 0;
11121 {Free all large blocks}
11122 LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader;
11123 while LPLargeBlock <> @LargeBlocksCircularList do
11124 begin
11125 {Get the next large block}
11126 LPNextLargeBlock := LPLargeBlock.NextLargeBlockHeader;
11127 {$ifdef ClearLargeBlocksBeforeReturningToOS}
11128 FillChar(LPLargeBlock^,
11129 LPLargeBlock.BlockSizeAndFlags and DropMediumAndLargeFlagsMask, 0);
11130 {$endif}
11131 {Free this large block}
11132 VirtualFree(LPLargeBlock, 0, MEM_RELEASE);
11133 {Next large block}
11134 LPLargeBlock := LPNextLargeBlock;
11135 end;
11136 {There are no large blocks allocated}
11137 LargeBlocksCircularList.PreviousLargeBlockHeader := @LargeBlocksCircularList;
11138 LargeBlocksCircularList.NextLargeBlockHeader := @LargeBlocksCircularList;
11139 end;
11140
11141 {----------------------------Memory Manager Setup-----------------------------}
11142
11143 {Checks that no other memory manager has been installed after the RTL MM and
11144 that there are currently no live pointers allocated through the RTL MM.}
CheckCanInstallMemoryManagernull11145 function CheckCanInstallMemoryManager: Boolean;
11146 {$ifndef NoMessageBoxes}
11147 var
11148 LErrorMessageTitle: array[0..1023] of AnsiChar;
11149 {$endif}
11150 begin
11151 {Default to error}
11152 Result := False;
11153 {$ifdef FullDebugMode}
11154 {$ifdef LoadDebugDLLDynamically}
11155 {$ifdef DoNotInstallIfDLLMissing}
11156 {Should FastMM be installed only if the FastMM_FullDebugMode.dll file is
11157 available?}
11158 if FullDebugModeDLL = 0 then
11159 Exit;
11160 {$endif}
11161 {$endif}
11162 {$endif}
11163 {Is FastMM already installed?}
11164 if FastMMIsInstalled then
11165 begin
11166 {$ifdef UseOutputDebugString}
11167 OutputDebugStringA(AlreadyInstalledMsg);
11168 {$endif}
11169 {$ifndef NoMessageBoxes}
11170 AppendStringToModuleName(AlreadyInstalledTitle, LErrorMessageTitle);
11171 ShowMessageBox(AlreadyInstalledMsg, LErrorMessageTitle);
11172 {$endif}
11173 Exit;
11174 end;
11175 {Has another MM been set, or has the Embarcadero MM been used? If so, this
11176 file is not the first unit in the uses clause of the project's .dpr file.}
11177 if IsMemoryManagerSet then
11178 begin
11179 {When using runtime packages, another library may already have installed
11180 FastMM: Silently ignore the installation request.}
11181 {$ifndef UseRuntimePackages}
11182 {Another memory manager has been set.}
11183 {$ifdef UseOutputDebugString}
11184 OutputDebugStringA(OtherMMInstalledMsg);
11185 {$endif}
11186 {$ifndef NoMessageBoxes}
11187 AppendStringToModuleName(OtherMMInstalledTitle, LErrorMessageTitle);
11188 ShowMessageBox(OtherMMInstalledMsg, LErrorMessageTitle);
11189 {$endif}
11190 {$endif}
11191 Exit;
11192 end;
11193 {$ifndef POSIX}
11194 if GetHeapStatus.TotalAllocated <> 0 then
11195 begin
11196 {Memory has been already been allocated with the RTL MM}
11197 {$ifdef UseOutputDebugString}
11198 OutputDebugStringA(MemoryAllocatedMsg);
11199 {$endif}
11200 {$ifndef NoMessageBoxes}
11201 AppendStringToModuleName(MemoryAllocatedTitle, LErrorMessageTitle);
11202 ShowMessageBox(MemoryAllocatedMsg, LErrorMessageTitle);
11203 {$endif}
11204 Exit;
11205 end;
11206 {$endif}
11207 {All OK}
11208 Result := True;
11209 end;
11210
11211 {Initializes the lookup tables for the memory manager}
11212 procedure InitializeMemoryManager;
11213 const
11214 {The size of the Inc(VMTIndex) code in TFreedObject.GetVirtualMethodIndex}
11215 VMTIndexIncCodeSize = 6;
11216 var
11217 LInd, LSizeInd, LMinimumPoolSize, LOptimalPoolSize, LGroupNumber,
11218 LBlocksPerPool, LPreviousBlockSize: Cardinal;
11219 LPMediumFreeBlock: PMediumFreeBlock;
11220 begin
11221 {$ifdef FullDebugMode}
11222 {$ifdef LoadDebugDLLDynamically}
11223 {Attempt to load the FullDebugMode DLL dynamically.}
11224 FullDebugModeDLL := LoadLibrary(FullDebugModeLibraryName);
11225 if FullDebugModeDLL <> 0 then
11226 begin
11227 GetStackTrace := GetProcAddress(FullDebugModeDLL,
11228 {$ifdef RawStackTraces}'GetRawStackTrace'{$else}'GetFrameBasedStackTrace'{$endif});
11229 LogStackTrace := GetProcAddress(FullDebugModeDLL, 'LogStackTrace');
11230 end;
11231 {$endif}
11232 {$endif}
11233 {$ifdef EnableMMX}
11234 {$ifndef ForceMMX}
11235 UseMMX := MMX_Supported;
11236 {$endif}
11237 {$endif}
11238 {Initialize the memory manager}
11239 {-------------Set up the small block types-------------}
11240 LPreviousBlockSize := 0;
11241 for LInd := 0 to High(SmallBlockTypes) do
11242 begin
11243 {Set the move procedure}
11244 {$ifdef UseCustomFixedSizeMoveRoutines}
11245 {The upsize move procedure may move chunks in 16 bytes even with 8-byte
11246 alignment, since the new size will always be at least 8 bytes bigger than
11247 the old size.}
11248 if not Assigned(SmallBlockTypes[LInd].UpsizeMoveProcedure) then
11249 {$ifdef UseCustomVariableSizeMoveRoutines}
11250 SmallBlockTypes[LInd].UpsizeMoveProcedure := MoveX16LP;
11251 {$else}
11252 SmallBlockTypes[LInd].UpsizeMoveProcedure := @System.Move;
11253 {$endif}
11254 {$endif}
11255 {Set the first "available pool" to the block type itself, so that the
11256 allocation routines know that there are currently no pools with free
11257 blocks of this size.}
11258 SmallBlockTypes[LInd].PreviousPartiallyFreePool := @SmallBlockTypes[LInd];
11259 SmallBlockTypes[LInd].NextPartiallyFreePool := @SmallBlockTypes[LInd];
11260 {Set the block size to block type index translation table}
11261 for LSizeInd := (LPreviousBlockSize div SmallBlockGranularity) to ((SmallBlockTypes[LInd].BlockSize - 1) div SmallBlockGranularity) do
11262 AllocSize2SmallBlockTypeIndX4[LSizeInd] := LInd * 4;
11263 {Cannot sequential feed yet: Ensure that the next address is greater than
11264 the maximum address}
11265 SmallBlockTypes[LInd].MaxSequentialFeedBlockAddress := Pointer(0);
11266 SmallBlockTypes[LInd].NextSequentialFeedBlockAddress := Pointer(1);
11267 {Get the mask to use for finding a medium block suitable for a block pool}
11268 LMinimumPoolSize :=
11269 ((SmallBlockTypes[LInd].BlockSize * MinimumSmallBlocksPerPool
11270 + SmallBlockPoolHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset)
11271 and -MediumBlockGranularity) + MediumBlockSizeOffset;
11272 if LMinimumPoolSize < MinimumMediumBlockSize then
11273 LMinimumPoolSize := MinimumMediumBlockSize;
11274 {Get the closest group number for the minimum pool size}
11275 LGroupNumber := (LMinimumPoolSize - MinimumMediumBlockSize + MediumBlockBinsPerGroup * MediumBlockGranularity div 2)
11276 div (MediumBlockBinsPerGroup * MediumBlockGranularity);
11277 {Too large?}
11278 if LGroupNumber > 7 then
11279 LGroupNumber := 7;
11280 {Set the bitmap}
11281 SmallBlockTypes[LInd].AllowedGroupsForBlockPoolBitmap := Byte(-(1 shl LGroupNumber));
11282 {Set the minimum pool size}
11283 SmallBlockTypes[LInd].MinimumBlockPoolSize := MinimumMediumBlockSize + LGroupNumber * (MediumBlockBinsPerGroup * MediumBlockGranularity);
11284 {Get the optimal block pool size}
11285 LOptimalPoolSize := ((SmallBlockTypes[LInd].BlockSize * TargetSmallBlocksPerPool
11286 + SmallBlockPoolHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset)
11287 and -MediumBlockGranularity) + MediumBlockSizeOffset;
11288 {Limit the optimal pool size to within range}
11289 if LOptimalPoolSize < OptimalSmallBlockPoolSizeLowerLimit then
11290 LOptimalPoolSize := OptimalSmallBlockPoolSizeLowerLimit;
11291 if LOptimalPoolSize > OptimalSmallBlockPoolSizeUpperLimit then
11292 LOptimalPoolSize := OptimalSmallBlockPoolSizeUpperLimit;
11293 {How many blocks will fit in the adjusted optimal size?}
11294 LBlocksPerPool := (LOptimalPoolSize - SmallBlockPoolHeaderSize) div SmallBlockTypes[LInd].BlockSize;
11295 {Recalculate the optimal pool size to minimize wastage due to a partial
11296 last block.}
11297 SmallBlockTypes[LInd].OptimalBlockPoolSize :=
11298 ((LBlocksPerPool * SmallBlockTypes[LInd].BlockSize + SmallBlockPoolHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset) and -MediumBlockGranularity) + MediumBlockSizeOffset;
11299 {$ifdef CheckHeapForCorruption}
11300 {Debug checks}
11301 if (SmallBlockTypes[LInd].OptimalBlockPoolSize < MinimumMediumBlockSize)
11302 or (SmallBlockTypes[LInd].BlockSize div SmallBlockGranularity * SmallBlockGranularity <> SmallBlockTypes[LInd].BlockSize) then
11303 begin
11304 {$ifdef BCB6OrDelphi7AndUp}
11305 System.Error(reInvalidPtr);
11306 {$else}
11307 System.RunError(reInvalidPtr);
11308 {$endif}
11309 end;
11310 {$endif}
11311 {Set the previous small block size}
11312 LPreviousBlockSize := SmallBlockTypes[LInd].BlockSize;
11313 end;
11314 {-------------------Set up the medium blocks-------------------}
11315 {$ifdef CheckHeapForCorruption}
11316 {Check that there are no gaps between where the small blocks end and the
11317 medium blocks start}
11318 if (((MaximumSmallBlockSize - 3) + (MediumBlockGranularity - 1 + BlockHeaderSize - MediumBlockSizeOffset))
11319 and -MediumBlockGranularity) + MediumBlockSizeOffset < MinimumMediumBlockSize then
11320 begin
11321 {$ifdef BCB6OrDelphi7AndUp}
11322 System.Error(reInvalidPtr);
11323 {$else}
11324 System.RunError(reInvalidPtr);
11325 {$endif}
11326 end;
11327 {$endif}
11328 {There are currently no medium block pools}
11329 MediumBlockPoolsCircularList.PreviousMediumBlockPoolHeader := @MediumBlockPoolsCircularList;
11330 MediumBlockPoolsCircularList.NextMediumBlockPoolHeader := @MediumBlockPoolsCircularList;
11331 {All medium bins are empty}
11332 for LInd := 0 to High(MediumBlockBins) do
11333 begin
11334 LPMediumFreeBlock := @MediumBlockBins[LInd];
11335 LPMediumFreeBlock.PreviousFreeBlock := LPMediumFreeBlock;
11336 LPMediumFreeBlock.NextFreeBlock := LPMediumFreeBlock;
11337 end;
11338 {------------------Set up the large blocks---------------------}
11339 LargeBlocksCircularList.PreviousLargeBlockHeader := @LargeBlocksCircularList;
11340 LargeBlocksCircularList.NextLargeBlockHeader := @LargeBlocksCircularList;
11341 {------------------Set up the debugging structures---------------------}
11342 {$ifdef FullDebugMode}
11343 {Set up the fake VMT}
11344 {Copy the basic info from the TFreedObject class}
11345 System.Move(Pointer(PByte(TFreedObject) + vmtSelfPtr + SizeOf(Pointer))^,
11346 FreedObjectVMT.VMTData[vmtSelfPtr + SizeOf(Pointer)], vmtParent - vmtSelfPtr);
11347 PNativeUInt(@FreedObjectVMT.VMTData[vmtSelfPtr])^ := NativeUInt(@FreedObjectVMT.VMTMethods[0]);
11348 {Set up the virtual method table}
11349 for LInd := 0 to MaxFakeVMTEntries - 1 do
11350 begin
11351 PNativeUInt(@FreedObjectVMT.VMTMethods[Low(FreedObjectVMT.VMTMethods) + Integer(LInd * SizeOf(Pointer))])^ :=
11352 NativeUInt(@TFreedObject.GetVirtualMethodIndex) + LInd * VMTIndexIncCodeSize;
11353 {$ifdef CatchUseOfFreedInterfaces}
11354 VMTBadInterface[LInd] := @TFreedObject.InterfaceError;
11355 {$endif}
11356 end;
11357 {Set up the default log file name}
11358 SetDefaultMMLogFileName;
11359 {$endif}
11360 end;
11361
11362 {Installs the memory manager (InitializeMemoryManager should be called first)}
11363 procedure InstallMemoryManager;
11364 {$ifdef MMSharingEnabled}
11365 var
11366 i, LCurrentProcessID: Cardinal;
11367 LPMapAddress: PPointer;
11368 LChar: AnsiChar;
11369 {$endif}
11370 begin
11371 if not FastMMIsInstalled then
11372 begin
11373 {$ifdef FullDebugMode}
11374 {$ifdef 32Bit}
11375 {Try to reserve the 64K block covering address $80808080}
11376 ReservedBlock := VirtualAlloc(Pointer(DebugReservedAddress), 65536, MEM_RESERVE, PAGE_NOACCESS);
11377 {$endif}
11378 {$endif}
11379 {$ifdef MMSharingEnabled}
11380 {Build a string identifying the current process}
11381 LCurrentProcessID := GetCurrentProcessId;
11382 for i := 0 to 7 do
11383 begin
11384 LChar := HexTable[((LCurrentProcessID shr (i * 4)) and $F)];
11385 MappingObjectName[(High(MappingObjectName) - 1) - i] := LChar;
11386 {$ifdef EnableBackwardCompatibleMMSharing}
11387 UniqueProcessIDString[8 - i] := LChar;
11388 UniqueProcessIDStringBE[8 - i] := LChar;
11389 {$endif}
11390 end;
11391 {$endif}
11392 {$ifdef AttemptToUseSharedMM}
11393 {Is the replacement memory manager already installed for this process?}
11394 {$ifdef EnableBackwardCompatibleMMSharing}
11395 MMWindow := FindWindowA('STATIC', PAnsiChar(@UniqueProcessIDString[1]));
11396 MMWindowBE := FindWindowA('STATIC', PAnsiChar(@UniqueProcessIDStringBE[1]));
11397 {$endif}
11398 MappingObjectHandle := OpenFileMappingA(FILE_MAP_READ, False, MappingObjectName);
11399 {Is no MM being shared?}
11400 {$ifdef EnableBackwardCompatibleMMSharing}
11401 if (MMWindow or MMWindowBE or MappingObjectHandle) = 0 then
11402 {$else}
11403 if MappingObjectHandle = 0 then
11404 {$endif}
11405 begin
11406 {$endif}
11407 {$ifdef ShareMM}
11408 {Share the MM with other DLLs? - if this DLL is unloaded, then
11409 dependent DLLs will cause a crash.}
11410 {$ifndef ShareMMIfLibrary}
11411 if not IsLibrary then
11412 {$endif}
11413 begin
11414 {$ifdef EnableBackwardCompatibleMMSharing}
11415 {No memory manager installed yet - create the invisible window}
11416 MMWindow := CreateWindowA('STATIC', PAnsiChar(@UniqueProcessIDString[1]),
11417 WS_POPUP, 0, 0, 0, 0, 0, 0, hInstance, nil);
11418 MMWindowBE := CreateWindowA('STATIC', PAnsiChar(@UniqueProcessIDStringBE[1]),
11419 WS_POPUP, 0, 0, 0, 0, 0, 0, hInstance, nil);
11420 {The window data is a pointer to this memory manager}
11421 if MMWindow <> 0 then
11422 SetWindowLongA(MMWindow, GWL_USERDATA, NativeInt(@NewMemoryManager));
11423 if MMWindowBE <> 0 then
11424 SetWindowLongA(MMWindowBE, GWL_USERDATA, NativeInt(@NewMemoryManager));
11425 {$endif}
11426 {Create the memory mapped file}
11427 MappingObjectHandle := CreateFileMappingA(INVALID_HANDLE_VALUE, nil,
11428 PAGE_READWRITE, 0, SizeOf(Pointer), MappingObjectName);
11429 {Map a view of the memory}
11430 LPMapAddress := MapViewOfFile(MappingObjectHandle, FILE_MAP_WRITE, 0, 0, 0);
11431 {Set a pointer to the new memory manager}
11432 LPMapAddress^ := @NewMemoryManager;
11433 {Unmap the file}
11434 UnmapViewOfFile(LPMapAddress);
11435 end;
11436 {$endif}
11437 {We will be using this memory manager}
11438 {$ifndef FullDebugMode}
11439 NewMemoryManager.GetMem := FastGetMem;
11440 NewMemoryManager.FreeMem := FastFreeMem;
11441 NewMemoryManager.ReallocMem := FastReallocMem;
11442 {$else}
11443 NewMemoryManager.GetMem := DebugGetMem;
11444 NewMemoryManager.FreeMem := DebugFreeMem;
11445 NewMemoryManager.ReallocMem := DebugReallocMem;
11446 {$endif}
11447 {$ifdef BDS2006AndUp}
11448 {$ifndef FullDebugMode}
11449 NewMemoryManager.AllocMem := FastAllocMem;
11450 {$else}
11451 NewMemoryManager.AllocMem := DebugAllocMem;
11452 {$endif}
11453 {$ifdef EnableMemoryLeakReporting}
11454 NewMemoryManager.RegisterExpectedMemoryLeak := RegisterExpectedMemoryLeak;
11455 NewMemoryManager.UnRegisterExpectedMemoryLeak := UnRegisterExpectedMemoryLeak;
11456 {$else}
11457 NewMemoryManager.RegisterExpectedMemoryLeak := NoOpRegisterExpectedMemoryLeak;
11458 NewMemoryManager.UnRegisterExpectedMemoryLeak := NoOpUnRegisterExpectedMemoryLeak;
11459 {$endif}
11460 {$endif}
11461 {Owns the memory manager}
11462 IsMemoryManagerOwner := True;
11463 {$ifdef AttemptToUseSharedMM}
11464 end
11465 else
11466 begin
11467 {Get the address of the shared memory manager}
11468 {$ifndef BDS2006AndUp}
11469 {$ifdef EnableBackwardCompatibleMMSharing}
11470 if MappingObjectHandle <> 0 then
11471 begin
11472 {$endif}
11473 {Map a view of the memory}
11474 LPMapAddress := MapViewOfFile(MappingObjectHandle, FILE_MAP_READ, 0, 0, 0);
11475 {Set the new memory manager}
11476 NewMemoryManager := PMemoryManager(LPMapAddress^)^;
11477 {Unmap the file}
11478 UnmapViewOfFile(LPMapAddress);
11479 {$ifdef EnableBackwardCompatibleMMSharing}
11480 end
11481 else
11482 begin
11483 if MMWindow <> 0 then
11484 begin
11485 NewMemoryManager := PMemoryManager(GetWindowLong(MMWindow, GWL_USERDATA))^;
11486 end
11487 else
11488 begin
11489 NewMemoryManager := PMemoryManager(GetWindowLong(MMWindowBE, GWL_USERDATA))^;
11490 end;
11491 end;
11492 {$endif}
11493 {$else}
11494 {$ifdef EnableBackwardCompatibleMMSharing}
11495 if MappingObjectHandle <> 0 then
11496 begin
11497 {$endif}
11498 {Map a view of the memory}
11499 LPMapAddress := MapViewOfFile(MappingObjectHandle, FILE_MAP_READ, 0, 0, 0);
11500 {Set the new memory manager}
11501 NewMemoryManager := PMemoryManagerEx(LPMapAddress^)^;
11502 {Unmap the file}
11503 UnmapViewOfFile(LPMapAddress);
11504 {$ifdef EnableBackwardCompatibleMMSharing}
11505 end
11506 else
11507 begin
11508 if MMWindow <> 0 then
11509 begin
11510 NewMemoryManager := PMemoryManagerEx(GetWindowLong(MMWindow, GWL_USERDATA))^;
11511 end
11512 else
11513 begin
11514 NewMemoryManager := PMemoryManagerEx(GetWindowLong(MMWindowBE, GWL_USERDATA))^;
11515 end;
11516 end;
11517 {$endif}
11518 {$endif}
11519 {Close the file mapping handle}
11520 CloseHandle(MappingObjectHandle);
11521 MappingObjectHandle := 0;
11522 {The memory manager is not owned by this module}
11523 IsMemoryManagerOwner := False;
11524 end;
11525 {$endif}
11526 {Save the old memory manager}
11527 GetMemoryManager(OldMemoryManager);
11528 {Replace the memory manager with either this one or the shared one.}
11529 SetMemoryManager(NewMemoryManager);
11530 {FastMM is now installed}
11531 FastMMIsInstalled := True;
11532 {$ifdef UseOutputDebugString}
11533 if IsMemoryManagerOwner then
11534 OutputDebugStringA(FastMMInstallMsg)
11535 else
11536 OutputDebugStringA(FastMMInstallSharedMsg);
11537 {$endif}
11538 end;
11539 end;
11540
11541 procedure UninstallMemoryManager;
11542 begin
11543 {Is this the owner of the shared MM window?}
11544 if IsMemoryManagerOwner then
11545 begin
11546 {$ifdef ShareMM}
11547 {$ifdef EnableBackwardCompatibleMMSharing}
11548 {Destroy the window}
11549 if MMWindow <> 0 then
11550 begin
11551 DestroyWindow(MMWindow);
11552 MMWindow := 0;
11553 end;
11554 if MMWindowBE <> 0 then
11555 begin
11556 DestroyWindow(MMWindowBE);
11557 MMWindowBE := 0;
11558 end;
11559 {$endif}
11560 {Destroy the memory mapped file handle}
11561 if MappingObjectHandle <> 0 then
11562 begin
11563 CloseHandle(MappingObjectHandle);
11564 MappingObjectHandle := 0;
11565 end;
11566 {$endif}
11567 {$ifdef FullDebugMode}
11568 {Release the reserved block}
11569 if ReservedBlock <> nil then
11570 begin
11571 VirtualFree(ReservedBlock, 0, MEM_RELEASE);
11572 ReservedBlock := nil;
11573 end;
11574 {$endif}
11575 end;
11576 {$ifndef DetectMMOperationsAfterUninstall}
11577 {Restore the old memory manager}
11578 SetMemoryManager(OldMemoryManager);
11579 {$else}
11580 {Set the invalid memory manager: no more MM operations allowed}
11581 SetMemoryManager(InvalidMemoryManager);
11582 {$endif}
11583 {Memory manager has been uninstalled}
11584 FastMMIsInstalled := False;
11585 {$ifdef UseOutputDebugString}
11586 if IsMemoryManagerOwner then
11587 OutputDebugStringA(FastMMUninstallMsg)
11588 else
11589 OutputDebugStringA(FastMMUninstallSharedMsg);
11590 {$endif}
11591 end;
11592
11593 procedure FinalizeMemoryManager;
11594 begin
11595 {Restore the old memory manager if FastMM has been installed}
11596 if FastMMIsInstalled then
11597 begin
11598 {$ifndef NeverUninstall}
11599 {Uninstall FastMM}
11600 UninstallMemoryManager;
11601 {$endif}
11602 {Do we own the memory manager, or are we just sharing it?}
11603 if IsMemoryManagerOwner then
11604 begin
11605 {$ifdef CheckUseOfFreedBlocksOnShutdown}
11606 CheckBlocksOnShutdown(
11607 {$ifdef EnableMemoryLeakReporting}
11608 True
11609 {$ifdef RequireIDEPresenceForLeakReporting}
11610 and DelphiIsRunning
11611 {$endif}
11612 {$ifdef RequireDebuggerPresenceForLeakReporting}
11613 and ((DebugHook <> 0)
11614 {$ifdef PatchBCBTerminate}
11615 or (Assigned(pCppDebugHook) and (pCppDebugHook^ <> 0))
11616 {$endif PatchBCBTerminate}
11617 )
11618 {$endif}
11619 {$ifdef ManualLeakReportingControl}
11620 and ReportMemoryLeaksOnShutdown
11621 {$endif}
11622 {$else}
11623 False
11624 {$endif}
11625 );
11626 {$else}
11627 {$ifdef EnableMemoryLeakReporting}
11628 if True
11629 {$ifdef RequireIDEPresenceForLeakReporting}
11630 and DelphiIsRunning
11631 {$endif}
11632 {$ifdef RequireDebuggerPresenceForLeakReporting}
11633 and ((DebugHook <> 0)
11634 {$ifdef PatchBCBTerminate}
11635 or (Assigned(pCppDebugHook) and (pCppDebugHook^ <> 0))
11636 {$endif PatchBCBTerminate}
11637 )
11638 {$endif}
11639 {$ifdef ManualLeakReportingControl}
11640 and ReportMemoryLeaksOnShutdown
11641 {$endif}
11642 then
11643 CheckBlocksOnShutdown(True);
11644 {$endif}
11645 {$endif}
11646 {$ifdef EnableMemoryLeakReporting}
11647 {Free the expected memory leaks list}
11648 if ExpectedMemoryLeaks <> nil then
11649 begin
11650 VirtualFree(ExpectedMemoryLeaks, 0, MEM_RELEASE);
11651 ExpectedMemoryLeaks := nil;
11652 end;
11653 {$endif}
11654 {$ifndef NeverUninstall}
11655 {Clean up: Free all memory. If this is a .DLL that owns its own MM, then
11656 it is necessary to prevent the main application from running out of
11657 address space.}
11658 FreeAllMemory;
11659 {$endif}
11660 end;
11661 end;
11662 end;
11663
11664 procedure RunInitializationCode;
11665 begin
11666 {Only run this code once during startup.}
11667 if InitializationCodeHasRun then
11668 Exit;
11669 InitializationCodeHasRun := True;
11670 {$ifndef BCB}
11671 {$ifdef InstallOnlyIfRunningInIDE}
11672 if (DebugHook <> 0) and DelphiIsRunning then
11673 {$endif}
11674 begin
11675 {Initialize all the lookup tables, etc. for the memory manager}
11676 InitializeMemoryManager;
11677 {Has another MM been set, or has the Embarcadero MM been used? If so, this
11678 file is not the first unit in the uses clause of the project's .dpr
11679 file.}
11680 if CheckCanInstallMemoryManager then
11681 begin
11682 {$ifdef ClearLogFileOnStartup}
11683 DeleteEventLog;
11684 {$endif}
11685 InstallMemoryManager;
11686 end;
11687 end;
11688 {$endif}
11689 end;
11690
11691 initialization
11692 RunInitializationCode;
11693
11694 finalization
11695 {$ifndef PatchBCBTerminate}
11696 FinalizeMemoryManager;
11697 {$endif}
11698
11699 end.