(*



Fast Memory Manager 4.991



Description:

 A fast replacement memory manager for Embarcadero Delphi Win32 applications

 that scales well under multi-threaded usage, is not prone to memory

 fragmentation, and supports shared memory without the use of external .DLL

 files.



Homepage:

 http://fastmm.sourceforge.net



Advantages:

 - Fast

 - Low overhead. FastMM is designed for an average of 5% and maximum of 10%

   overhead per block.

 - Supports up to 3GB of user mode address space under Windows 32-bit and 4GB

   under Windows 64-bit. Add the "$SetPEFlags $20" option (in curly braces)

   to your .dpr to enable this.

 - Highly aligned memory blocks. Can be configured for either 8-byte or 16-byte

   alignment.

 - Good scaling under multi-threaded applications

 - Intelligent reallocations. Avoids slow memory move operations through

   not performing unneccesary downsizes and by having a minimum percentage

   block size growth factor when an in-place block upsize is not possible.

 - Resistant to address space fragmentation

 - No external DLL required when sharing memory between the application and

   external libraries (provided both use this memory manager)

 - Optionally reports memory leaks on program shutdown. (This check can be set

   to be performed only if Delphi is currently running on the machine, so end

   users won't be bothered by the error message.)

 - Supports Delphi 4 (or later), C++ Builder 4 (or later), Kylix 3.



Usage:

 Delphi:

  Place this unit as the very first unit under the "uses" section in your

  project's .dpr file. When sharing memory between an application and a DLL

  (e.g. when passing a long string or dynamic array to a DLL function), both the

  main application and the DLL must be compiled using this memory manager (with

  the required conditional defines set). There are some conditional defines

  (inside FastMM4Options.inc) that may be used to tweak the memory manager. To

  enable support for a user mode address space greater than 2GB you will have to

  use the EditBin* tool to set the LARGE_ADDRESS_AWARE flag in the EXE header.

  This informs Windows x64 or Windows 32-bit (with the /3GB option set) that the

  application supports an address space larger than 2GB (up to 4GB). In Delphi 6

  and later you can also specify this flag through the compiler directive

  {$SetPEFlags $20}

  *The EditBin tool ships with the MS Visual C compiler.

 C++ Builder 6:

  Refer to the instructions inside FastMM4BCB.cpp.



License:

 This work is copyright Professional Software Development / Pierre le Riche. It

 is released under a dual license, and you may choose to use it under either the

 Mozilla Public License 1.1 (MPL 1.1, available from

 http://www.mozilla.org/MPL/MPL-1.1.html) or the GNU Lesser General Public

 License 2.1 (LGPL 2.1, available from

 http://www.opensource.org/licenses/lgpl-license.php). If you find FastMM useful

 or you would like to support further development, a donation would be much

 appreciated. My banking details are:

   Country: South Africa

   Bank: ABSA Bank Ltd

   Branch: Somerset West

   Branch Code: 334-712

   Account Name: PSD (Distribution)

   Account No.: 4041827693

   Swift Code: ABSAZAJJ

 My PayPal account is:

   bof@psd.co.za



Contact Details:

 My contact details are shown below if you would like to get in touch with me.

 If you use this memory manager I would like to hear from you: please e-mail me

 your comments - good and bad.

 Snailmail:

   PO Box 2514

   Somerset West

   7129

   South Africa

 E-mail:

   plr@psd.co.za



Support:

 If you have trouble using FastMM, you are welcome to drop me an e-mail at the

 address above, or you may post your questions in the BASM newsgroup on the

 Embarcadero news server (which is where I hang out quite frequently).



Disclaimer:

 FastMM has been tested extensively with both single and multithreaded

 applications on various hardware platforms, but unfortunately I am not in a

 position to make any guarantees. Use it at your own risk.



Acknowledgements (for version 4):

 - Eric Grange for his RecyclerMM on which the earlier versions of FastMM were

   based. RecyclerMM was what inspired me to try and write my own memory

   manager back in early 2004.

 - Primoz Gabrijelcic for helping to track down various bugs.

 - Dennis Christensen for his tireless efforts with the Fastcode project:

   helping to develop, optimize and debug the growing Fastcode library.

 - JiYuan Xie for implementing the leak reporting code for C++ Builder.

 - Sebastian Zierer for implementing the OS X support.

 - Pierre Y. for his suggestions regarding the extension of the memory leak

   checking options.

 - Hanspeter Widmer for his suggestion to have an option to display install and

   uninstall debug messages and moving options to a separate file, as well as

   the new usage tracker.

 - Anders Isaksson and Greg for finding and identifying the "DelphiIsRunning"

   bug under Delphi 5.

 - Francois Malan for various suggestions and bug reports.

 - Craig Peterson for helping me identify the cache associativity issues that

   could arise due to medium blocks always being an exact multiple of 256 bytes.

   Also for various other bug reports and enhancement suggestions.

 - Jarek Karciarz, Vladimir Ulchenko (Vavan) and Bob Gonder for their help in

   implementing the BCB support.

 - Ben Taylor for his suggestion to display the object class of all memory

   leaks.

 - Jean Marc Eber and Vincent Mahon (the Memcheck guys) for the call stack

   trace code and also the method used to catch virtual method calls on freed

   objects.

 - Nahan Hyn for the suggestion to be able to enable or disable memory leak

   reporting through a global variable (the "ManualLeakReportingControl"

   option.)

 - Leonel Togniolli for various suggestions with regard to enhancing the bug

   tracking features of FastMM and other helpful advice.

 - Joe Bain and Leonel Togniolli for the workaround to QC#10922 affecting

   compilation under Delphi 2005.

 - Robert Marquardt for the suggestion to make localisation of FastMM easier by

   having all string constants together.

 - Simon Kissel and Fikret Hasovic for their help in implementing Kylix support.

 - Matthias Thoma, Petr Vones, Robert Rossmair and the rest of the JCL team for

   their debug info library used in the debug info support DLL and also the

   code used to check for a valid call site in the "raw" stack trace code.

 - Andreas Hausladen for the suggestion to use an external DLL to enable the

   reporting of debug information.

 - Alexander Tabakov for various good suggestions regarding the debugging

   facilities of FastMM.

 - M. Skloff for some useful suggestions and bringing to my attention some

   compiler warnings.

 - Martin Aignesberger for the code to use madExcept instead of the JCL library

   inside the debug info support DLL.

 - Diederik and Dennis Passmore for the suggestion to be able to register

   expected leaks.

 - Dario Tiraboschi and Mark Gebauer for pointing out the problems that occur

   when range checking and complete boolean evaluation is turned on.

 - Arthur Hoornweg for notifying me of the image base being incorrect for

   borlndmm.dll.

 - Theo Carr-Brion and Hanspeter Widmer for finding the false alarm error

   message "Block Header Has Been Corrupted" bug in FullDebugMode.

 - Danny Heijl for reporting the compiler error in "release" mode.

 - Omar Zelaya for reporting the BCB support regression bug.

 - Dan Miser for various good suggestions, e.g. not logging expected leaks to

   file, enhancements the stack trace and messagebox functionality, etc.

 - Arjen de Ruijter for fixing the bug in GetMemoryLeakType that caused it

   to not properly detect expected leaks registered by class when in

   "FullDebugMode".

 - Aleksander Oven for reporting the installation problem when trying to use

   FastMM in an application together with libraries that all use runtime

   packages.

 - Kristofer Skaug for reporting the bug that sometimes causes the leak report

   to be shown, even when all the leaks have been registered as expected leaks.

   Also for some useful enhancement suggestions.

 - Günther Schoch for the "RequireDebuggerPresenceForLeakReporting" option.

 - Jan Schlüter for the "ForceMMX" option.

 - Hallvard Vassbotn for various good enhancement suggestions.

 - Mark Edington for some good suggestions and bug reports.

 - Paul Ishenin for reporting the compilation error when the NoMessageBoxes

   option is set and also the missing call stack entries issue when "raw" stack

   traces are enabled, as well as for the Russian translation.

 - Cristian Nicola for reporting the compilation bug when the

   CatchUseOfFreedInterfaces option was enabled (4.40).

 - Mathias Rauen (madshi) for improving the support for madExcept in the debug

   info support DLL.

 - Roddy Pratt for the BCB5 support code.

 - Rene Mihula for the Czech translation and the suggestion to have dynamic

   loading of the FullDebugMode DLL as an option.

 - Artur Redzko for the Polish translation.

 - Bart van der Werf for helping me solve the DLL unload order problem when

   using the debug mode borlndmm.dll library, as well as various other

   suggestions.

 - JRG ("The Delphi Guy") for the Spanish translation.

 - Justus Janssen for Delphi 4 support.

 - Vadim Lopushansky and Charles Vinal for reporting the Delphi 5 compiler

   error in version 4.50.

 - Johni Jeferson Capeletto for the Brazilian Portuguese translation.

 - Kurt Fitzner for reporting the BCB6 compiler error in 4.52.

 - Michal Niklas for reporting the Kylix compiler error in 4.54.

 - Thomas Speck and Uwe Queisser for German translations.

 - Zaenal Mutaqin for the Indonesian translation.

 - Carlos Macao for the Portuguese translation.

 - Michael Winter for catching the performance issue when reallocating certain

   block sizes.

 - dzmitry[li] for the Belarussian translation.

 - Marcelo Montenegro for the updated Spanish translation.

 - Jud Cole for finding and reporting the bug which may trigger a read access

   violation when upsizing certain small block sizes together with the

   "UseCustomVariableSizeMoveRoutines" option.

 - Zdenek Vasku for reporting and fixing the memory manager sharing bug

   affecting Windows 95/98/Me.

 - RB Winston for suggesting the improvement to GExperts "backup" support.

 - Thomas Schulz for reporting the bug affecting large address space support

   under FullDebugMode, as well as the recursive call bug when attempting to

   report memory leaks when EnableMemoryLeakReporting is disabled.

 - Luigi Sandon for the Italian translation.

 - Werner Bochtler for various suggestions and bug reports.

 - Markus Beth for suggesting the "NeverSleepOnThreadContention" option.

 - JiYuan Xie for the Simplified Chinese translation.

 - Andrey Shtukaturov for the updated Russian translation, as well as the

   Ukrainian translation.

 - Dimitry Timokhov for finding two elusive bugs in the memory leak class

   detection code.

 - Paulo Moreno for fixing the AllocMem bug in FullDebugMode that prevented

   large blocks from being cleared.

 - Vladimir Bochkarev for the suggestion to remove some unnecessary code if the

   MM sharing mechanism is disabled.

 - Loris Luise for the version constant suggestion.

 - J.W. de Bokx for the MessageBox bugfix.

 - Igor Lindunen for reporting the bug that caused the Align16Bytes option to

   not work in FullDebugMode.

 - Ionut Muntean for the Romanian translation.

 - Florent Ouchet for the French translation.

 - Marcus Mönnig for the ScanMemoryPoolForCorruptions suggestion and the

   suggestion to have the option to scan the memory pool before every

   operation when in FullDebugMode.

 - Francois Piette for bringing under my attention that

   ScanMemoryPoolForCorruption was not thread safe.

 - Michael Rabatscher for reporting some compiler warnings.

 - QianYuan Wang for the Simplified Chinese translation of FastMM4Options.inc.

 - Maurizio Lotauro and Christian-W. Budde for reporting some Delphi 5

   compiler errors.

 - Patrick van Logchem for the DisableLoggingOfMemoryDumps option.

 - Norbert Spiegel for the BCB4 support code.

 - Uwe Schuster for the improved string leak detection code.

 - Murray McGowan for improvements to the usage tracker.

 - Michael Hieke for the SuppressFreeMemErrorsInsideException option as well

   as a bugfix to GetMemoryMap.

 - Richard Bradbrook for fixing the Windows 95 FullDebugMode support that was

   broken in version 4.94.

 - Zach Saw for the suggestion to (optionally) use SwitchToThread when

   waiting for a lock on a shared resource to be released.

 - Everyone who have made donations. Thanks!

 - Any other Fastcoders or supporters that I have forgotten, and also everyone

   that helped with the older versions.



Change log:

 Version 1.00 (28 June 2004):

  - First version (called PSDMemoryManager). Based on RecyclerMM (free block

    stack approach) by Eric Grange.

 Version 2.00 (3 November 2004):

  - Complete redesign and rewrite from scratch. Name changed to FastMM to

    reflect this fact. Uses a linked-list approach. Is faster, has less memory

    overhead, and will now catch most bad pointers on FreeMem calls.

 Version 3.00 (1 March 2005):

  - Another rewrite. Reduced the memory overhead by: (a) not having a separate

    memory area for the linked list of free blocks (uses space inside free

    blocks themselves) (b) batch managers are allocated as part of chunks (c)

    block size lookup table size reduced. This should make FastMM more CPU

    cache friendly.

 Version 4.00 (7 June 2005):

  - Yet another rewrite. FastMM4 is in fact three memory managers in one: Small

    blocks (up to a few KB) are managed through the binning model in the same

    way as previous versions, medium blocks (from a few KB up to approximately

    256K) are allocated in a linked-list fashion, and large blocks are grabbed

    directly from the system through VirtualAlloc. This 3-layered design allows

    very fast operation with the most frequently used block sizes (small

    blocks), while also minimizing fragmentation and imparting significant

    overhead savings with blocks larger than a few KB.

 Version 4.01 (8 June 2005):

  - Added the options "RequireDebugInfoForLeakReporting" and

    "RequireIDEPresenceForLeakReporting" as suggested by Pierre Y.

  - Fixed the "DelphiIsRunning" function not working under Delphi 5, and

    consequently no leak checking. (Reported by Anders Isaksson and Greg.)

 Version 4.02 (8 June 2005):

  - Fixed the compilation error when both the "AssumeMultiThreaded" and

    "CheckHeapForCorruption options were set. (Reported by Francois Malan.)

 Version 4.03 (9 June 2005):

  - Added descriptive error messages when FastMM4 cannot be installed because

    another MM has already been installed or memory has already been allocated.

 Version 4.04 (13 June 2005):

  - Added a small fixed offset to the size of medium blocks (previously always

    exact multiples of 256 bytes). This makes performance problems due to CPU

    cache associativity limitations much less likely. (Reported by Craig

    Peterson.)

 Version 4.05 (17 June 2005):

  - Added the Align16Bytes option. Disable this option to drop the 16 byte

    alignment restriction and reduce alignment to 8 bytes for the smallest

    block sizes. Disabling Align16Bytes should lower memory consumption at the

    cost of complicating the use of aligned SSE move instructions. (Suggested

    by Craig Peterson.)

  - Added a support unit for C++ Builder 6 - Add FastMM4BCB.cpp and

    FastMM4.pas to your BCB project to use FastMM instead of the RTL MM. Memory

    leak checking is not supported because (unfortunately) once an MM is

    installed under BCB you cannot uninstall it... at least not without

    modifying the RTL code in exit.c or patching the RTL code runtime. (Thanks

    to Jarek Karciarz, Vladimir Ulchenko and Bob Gonder.)

 Version 4.06 (22 June 2005):

  - Displays the class of all leaked objects on the memory leak report and also

    tries to identify leaked long strings. Previously it only displayed the

    sizes of all leaked blocks. (Suggested by Ben Taylor.)

  - Added support for displaying the sizes of medium and large block memory

    leaks. Previously it only displayed details for small block leaks.

 Version 4.07 (22 June 2005):

  - Fixed the detection of the class of leaked objects not working under

    Windows 98/Me.

 Version 4.08 (27 June 2005):

  - Added a BorlndMM.dpr project to allow you to build a borlndmm.dll that uses

    FastMM4 instead of the default memory manager. You may replace the old

    DLL in the Delphi \Bin directory to make the IDE use this memory manager

    instead.

 Version 4.09 (30 June 2005):

  - Included a patch fix for the bug affecting replacement borlndmm.dll files

    with Delphi 2005 (QC#14007). Compile the patch, close Delphi, and run it

    once to patch your vclide90.bpl. You will now be able to use the

    replacement borlndmm.dll to speed up the Delphi 2005 IDE as well.

 Version 4.10 (7 July 2005):

  - Due to QC#14070 ("Delphi IDE attempts to free memory after the shutdown

    code of borlndmm.dll has been called"), FastMM cannot be uninstalled

    safely when used inside a replacement borlndmm.dll for the IDE. Added a

    conditional define "NeverUninstall" for this purpose.

  - Added the "FullDebugMode" option to pad all blocks with a header and footer

    to help you catch memory overwrite bugs in your applications. All blocks

    returned to freemem are also zeroed out to help catch bugs involving the

    use of previously freed blocks. Also catches attempts at calling virtual

    methods of freed objects provided the block in question has not been reused

    since the object was freed. Displays stack traces on error to aid debugging.

  - Added the "LogErrorsToFile" option to log all errors to a text file in the

    same folder as the application.

  - Added the "ManualLeakReportingControl" option (suggested by Nahan Hyn) to

    enable control over whether the memory leak report should be done or not

    via a global variable.

 Version 4.11 (7 July 2005):

  - Fixed a compilation error under Delphi 2005 due to QC#10922. (Thanks to Joe

    Bain and Leonel Togniolli.)

  - Fixed leaked object classes not displaying in the leak report in

    "FullDebugMode".

  Version 4.12 (8 July 2005):

  - Moved all the string constants to one place to make it easier to do

    translations into other languages. (Thanks to Robert Marquardt.)

  - Added support for Kylix. Some functionality is currently missing: No

    support for detecting the object class on leaks and also no MM sharing.

    (Thanks to Simon Kissel and Fikret Hasovic).

  Version 4.13 (11 July 2005):

  - Added the FastMM_DebugInfo.dll support library to display debug info for

    stack traces.

  - Stack traces for the memory leak report is now logged to the log file in

    "FullDebugMode".

  Version 4.14 (14 July 2005):

  - Fixed string leaks not being detected as such in "FullDebugMode". (Thanks

    to Leonel Togniolli.)

  - Fixed the compilation error in "FullDebugMode" when "LogErrorsToFile" is

    not set. (Thanks to Leonel Togniolli.)

  - Added a "Release" option to allow the grouping of various options and to

    make it easier to make debug and release builds. (Thanks to Alexander

    Tabakov.)

  - Added a "HideMemoryLeakHintMessage" option to not display the hint below

    the memory leak message. (Thanks to Alexander Tabakov.)

  - Changed the fill character for "FullDebugMode" from zero to $80 to be able

    to differentiate between invalid memory accesses using nil pointers to

    invalid memory accesses using fields of freed objects. FastMM tries to

    reserve the 64K block starting at $80800000 at startup to ensure that an

    A/V will occur when this block is accessed. (Thanks to Alexander Tabakov.)

  - Fixed some compiler warnings. (Thanks to M. Skloff)

  - Fixed some display bugs in the memory leak report. (Thanks to Leonel

    Togniolli.)

  - Added a "LogMemoryLeakDetailToFile" option. Some applications leak a lot of

    memory and can make the log file grow very large very quickly.

  - Added the option to use madExcept instead of the JCL Debug library in the

    debug info support DLL. (Thanks to Martin Aignesberger.)

  - Added procedures "GetMemoryManagerState" and "GetMemoryMap" to retrieve

    statistics about the current state of the memory manager and memory pool.

    (A usage tracker form together with a demo is also available.)

  Version 4.15 (14 July 2005):

  - Fixed a false 4GB(!) memory leak reported in some instances.

  Version 4.16 (15 July 2005):

  - Added the "CatchUseOfFreedInterfaces" option to catch the use of interfaces

    of freed objects. This option is not compatible with checking that a freed

    block has not been modified, so enable this option only when hunting an

    invalid interface reference. (Only relevant if "FullDebugMode" is set.)

  - During shutdown FastMM now checks that all free blocks have not been

    modified since being freed. (Only when "FullDebugMode" is set and

    "CatchUseOfFreedInterfaces" is disabled.)

  Version 4.17 (15 July 2005):

 - Added the AddExpectedMemoryLeaks and RemoveExpectedMemoryLeaks procedures to

   register/unregister expected leaks, thus preventing the leak report from

   displaying if only expected leaks occurred. (Thanks to Diederik and Dennis

   Passmore for the suggestion.) (Note: these functions were renamed in later

   versions.)

 - Fixed the "LogMemoryLeakDetailToFile" not logging memory leak detail to file

   as it is supposed to. (Thanks to Leonel Togniolli.)

 Version 4.18 (18 July 2005):

 - Fixed some issues when range checking or complete boolean evaluation is

   switched on. (Thanks to Dario Tiraboschi and Mark Gebauer.)

 - Added the "OutputInstallUninstallDebugString" option to display a message when

   FastMM is installed or uninstalled. (Thanks to Hanspeter Widmer.)

 - Moved the options to a separate include file. (Thanks to Hanspeter Widmer.)

 - Moved message strings to a separate file for easy translation.

 Version 4.19 (19 July 2005):

 - Fixed Kylix support that was broken in 4.14.

 Version 4.20 (20 July 2005):

 - Fixed a false memory overwrite report at shutdown in "FullDebugMode". If you

   consistently got a "Block Header Has Been Corrupted" error message during

   shutdown at address $xxxx0070 then it was probably a false alarm. (Thanks to

   Theo Carr-Brion and Hanspeter Widmer.}

 Version 4.21 (27 July 2005):

 - Minor change to the block header flags to make it possible to immediately

   tell whether a medium block is being used as a small block pool or not.

   (Simplifies the leak checking and status reporting code.)

 - Expanded the functionality around the management of expected memory leaks.

 - Added the "ClearLogFileOnStartup" option. Deletes the log file during

   initialization. (Thanks to M. Skloff.)

 - Changed "OutputInstallUninstallDebugString" to use OutputDebugString instead

   of MessageBox. (Thanks to Hanspeter Widmer.)

 Version 4.22 (1 August 2005):

 - Added a FastAllocMem function that avoids an unnecessary FillChar call with

   large blocks.

 - Changed large block resizing behavior to be a bit more conservative. Large

   blocks will be downsized if the new size is less than half of the old size

   (the threshold was a quarter previously).

 Version 4.23 (6 August 2005):

 - Fixed BCB6 support (Thanks to Omar Zelaya).

 - Renamed "OutputInstallUninstallDebugString" to "UseOutputDebugString", and

   added debug string output on memory leak or error detection.

 Version 4.24 (11 August 2005):

 - Added the "NoMessageBoxes" option to suppress the display of message boxes,

   which is useful for services that should not be interrupted. (Thanks to Dan

   Miser).

 - Changed the stack trace code to return the line number of the caller and not

   the line number of the return address. (Thanks to Dan Miser).

 Version 4.25 (15 August 2005):

 - Fixed GetMemoryLeakType not detecting expected leaks registered by class

   when in "FullDebugMode". (Thanks to Arjen de Ruijter).

 Version 4.26 (18 August 2005):

 - Added a "UseRuntimePackages" option that allows FastMM to be used in a main

   application together with DLLs that all use runtime packages. (Thanks to

   Aleksander Oven.)

 Version 4.27 (24 August 2005):

 - Fixed a bug that sometimes caused the leak report to be shown even though all

   leaks were registered as expected leaks. (Thanks to Kristofer Skaug.)

 Version 4.29 (30 September 2005):

 - Added the "RequireDebuggerPresenceForLeakReporting" option to only display

   the leak report if the application is run inside the IDE. (Thanks to Günther

   Schoch.)

 - Added the "ForceMMX" option, which when disabled will check the CPU for

   MMX compatibility before using MMX. (Thanks to Jan Schlüter.)

 - Added the module name to the title of error dialogs to more easily identify

   which application caused the error. (Thanks to Kristofer Skaug.)

 - Added an ASCII dump to the "FullDebugMode" memory dumps. (Thanks to Hallvard

   Vassbotn.)

 - Added the option "HideExpectedLeaksRegisteredByPointer" to suppress the

   display and logging of expected memory leaks that were registered by pointer.

   (Thanks to Dan Miser.) Leaks registered by size or class are often ambiguous,

   so these expected leaks are always logged to file (in FullDebugMode) and are

   never hidden from the leak display (only displayed if there is at least one

   unexpected leak).

 - Added a procedure "GetRegisteredMemoryLeaks" to return a list of all

   registered memory leaks. (Thanks to Dan Miser.)

 - Added the "RawStackTraces" option to perform "raw" stack traces, negating

   the need for stack frames. This will usually result in more complete stack

   traces in FullDebugMode error reports, but it is significantly slower.

   (Thanks to Hallvard Vassbotn, Dan Miser and the JCL team.)

 Version 4.31 (2 October 2005):

 - Fixed the crash bug when both "RawStackTraces" and "FullDebugMode" were

   enabled. (Thanks to Dan Miser and Mark Edington.)

 Version 4.33 (6 October 2005):

 - Added a header corruption check to all memory blocks that are identified as

   leaks in FullDebugMode. This allows better differentiation between memory

   pool corruption bugs and actual memory leaks.

 - Fixed the stack overflow bug when using "RawStackTraces".

 Version 4.35 (6 October 2005):

 - Fixed a compilation error when the "NoMessageBoxes" option is set. (Thanks

   to Paul Ishenin.)

 - Before performing a "raw" stack trace, FastMM now checks whether exception

   handling is in place. If exception handling is not in place FastMM falls

   back to stack frame tracing. (Exception handling is required to handle the

   possible A/Vs when reading invalid call addresses. Exception handling is

   usually always available except when SysUtils hasn't been initialized yet or

   after SysUtils has been finalized.)

 Version 4.37 (8 October 2005):

 - Fixed the missing call stack trace entry issue when dynamically loading DLLs.

   (Thanks to Paul Ishenin.)

 Version 4.39 (12 October 2005):

 - Restored the performance with "RawStackTraces" enabled back to the level it

   was in 4.35.

 - Fixed the stack overflow error when using "RawStackTraces" that I thought I

   had fixed in 4.31, but unfortunately didn't. (Thanks to Craig Peterson.)

 Version 4.40 (13 October 2005):

 - Improved "RawStackTraces" to have less incorrect extra entries. (Thanks to

   Craig Peterson.)

 - Added the Russian (by Paul Ishenin) and Afrikaans translations of

   FastMM4Messages.pas.

 Version 4.42 (13 October 2005):

 - Fixed the compilation error when "CatchUseOfFreedInterfaces" is enabled.

   (Thanks to Cristian Nicola.)

 Version 4.44 (25 October 2005):

 - Implemented a FastGetHeapStatus function in analogy with GetHeapStatus.

   (Suggested by Cristian Nicola.)

 - Shifted more of the stack trace code over to the support dll to allow third

   party vendors to make available their own stack tracing and stack trace

   logging facilities.

 - Mathias Rauen (madshi) improved the support for madExcept in the debug info

   support DLL. Thanks!

 - Added support for BCB5. (Thanks to Roddy Pratt.)

 - Added the Czech translation by Rene Mihula.

 - Added the "DetectMMOperationsAfterUninstall" option. This will catch

   attempts to use the MM after FastMM has been uninstalled, and is useful for

   debugging.

 Version 4.46 (26 October 2005):

 - Renamed FastMM_DebugInfo.dll to FastMM_FullDebugMode.dll and made the

   dependency on this library a static one. This solves a DLL unload order

   problem when using FullDebugMode together with the replacement

   borlndmm.dll. (Thanks to Bart van der Werf.)

 - Added the Polish translation by Artur Redzko.

 Version 4.48 (10 November 2005):

 - Fixed class detection for objects leaked in dynamically loaded DLLs that

   were relocated.

 - Fabio Dell'Aria implemented support for EurekaLog in the FullDebugMode

   support DLL. Thanks!

 - Added the Spanish translation by JRG ("The Delphi Guy").

 Version 4.49 (10 November 2005):

 - Implemented support for installing replacement AllocMem and leak

   registration mechanisms for Delphi/BCB versions that support it.

 - Added support for Delphi 4. (Thanks to Justus Janssen.)

 Version 4.50 (5 December 2005):

 - Renamed the ReportMemoryLeaks global variable to ReportMemoryLeaksOnShutdown

   to be more consistent with the Delphi 2006 memory manager.

 - Improved the handling of large blocks. Large blocks can now consist of

   several consecutive segments allocated through VirtualAlloc. This

   significantly improves speed when frequently resizing large blocks, since

   these blocks can now often be upsized in-place.

 Version 4.52 (7 December 2005):

 - Fixed the compilation error with Delphi 5. (Thanks to Vadim Lopushansky and

   Charles Vinal for reporting the error.)

 Version 4.54 (15 December 2005):

 - Added the Brazilian Portuguese translation by Johni Jeferson Capeletto.

 - Fixed the compilation error with BCB6. (Thanks to Kurt Fitzner.)

 Version 4.56 (20 December 2005):

 - Fixed the Kylix compilation problem. (Thanks to Michal Niklas.)

 Version 4.58 (1 February 2006):

 - Added the German translations by Thomas Speck and Uwe Queisser.

 - Added the Indonesian translation by Zaenal Mutaqin.

 - Added the Portuguese translation by Carlos Macao.

 Version 4.60 (21 February 2006):

 - Fixed a performance issue due to an unnecessary block move operation when

   allocating a block in the range 1261-1372 bytes and then reallocating it in

   the range 1373-1429 bytes twice. (Thanks to Michael Winter.)

 - Added the Belarussian translation by dzmitry[li].

 - Added the updated Spanish translation by Marcelo Montenegro.

 - Added a new option "EnableSharingWithDefaultMM". This option allows FastMM

   to be shared with the default MM of Delphi 2006. It is on by default, but

   MM sharing has to be enabled otherwise it has no effect (refer to the

   documentation for the "ShareMM" and "AttemptToUseSharedMM" options).

 Version 4.62 (22 February 2006):

 - Fixed a possible read access violation in the MoveX16LP routine when the

   UseCustomVariableSizeMoveRoutines option is enabled. (Thanks to Jud Cole for

   some great detective work in finding this bug.)

 - Improved the downsizing behaviour of medium blocks to better correlate with

   the reallocation behaviour of small blocks. This change reduces the number

   of transitions between small and medium block types when reallocating blocks

   in the 0.7K to 2.6K range. It cuts down on the number of memory move

   operations and improves performance.

 Version 4.64 (31 March 2006):

 - Added the following functions for use with FullDebugMode (and added the

   exports to the replacement BorlndMM.dll): SetMMLogFileName,

   GetCurrentAllocationGroup, PushAllocationGroup, PopAllocationGroup and

   LogAllocatedBlocksToFile. The purpose of these functions are to allow you to

   identify and log related memory leaks while your application is still

   running.

 - Fixed a bug in the memory manager sharing mechanism affecting Windows

   95/98/ME. (Thanks to Zdenek Vasku.)

 Version 4.66 (9 May 2006):

 - Added a hint comment in this file so that FastMM4Messages.pas will also be

   backed up by GExperts. (Thanks to RB Winston.)

 - Fixed a bug affecting large address space (> 2GB) support under

   FullDebugMode. (Thanks to Thomas Schulz.)

 Version 4.68 (3 July 2006):

 - Added the Italian translation by Luigi Sandon.

 - If FastMM is used inside a DLL it will now use the name of the DLL as base

   for the log file name. (Previously it always used the name of the main

   application executable file.)

 - Fixed a rare A/V when both the FullDebugMode and RawStackTraces options were

   enabled. (Thanks to Primoz Gabrijelcic.)

 - Added the "NeverSleepOnThreadContention" option. This option may improve

   performance if the ratio of the the number of active threads to the number

   of CPU cores is low (typically < 2). This option is only useful for 4+ CPU

   systems, it almost always hurts performance on single and dual CPU systems.

   (Thanks to Werner Bochtler and Markus Beth.)

 Version 4.70 (4 August 2006):

  - Added the Simplified Chinese translation by JiYuan Xie.

  - Added the updated Russian as well as the Ukrainian translation by Andrey

    Shtukaturov.

  - Fixed two bugs in the leak class detection code that would sometimes fail

    to detect the class of leaked objects and strings, and report them as

    'unknown'. (Thanks to Dimitry Timokhov)

  Version 4.72 (24 September 2006):

  - Fixed a bug that caused AllocMem to not clear blocks > 256K in

    FullDebugMode. (Thanks to Paulo Moreno.)

  Version 4.74 (9 November 2006):

  - Fixed a bug in the segmented large block functionality that could lead to

    an application freeze when upsizing blocks greater than 256K in a

    multithreaded application (one of those "what the heck was I thinking?"

    type bugs).

  Version 4.76 (12 January 2007):

  - Changed the RawStackTraces code in the FullDebugMode DLL

    to prevent it from modifying the Windows "GetLastError" error code.

    (Thanks to Primoz Gabrijelcic.)

  - Fixed a threading issue when the "CheckHeapForCorruption" option was

    enabled, but the "FullDebugMode" option was disabled. (Thanks to Primoz

    Gabrijelcic.)

  - Removed some unnecessary startup code when the MM sharing mechanism is

    disabled. (Thanks to Vladimir Bochkarev.)

  - In FullDebugMode leaked blocks would sometimes be reported as belonging to

    the class "TFreedObject" if they were allocated but never used. Such blocks

    will now be reported as "unknown". (Thanks to Francois Malan.)

  - In recent versions the replacement borlndmm.dll created a log file (when

    enabled) that used the "borlndmm" prefix instead of the application name.

    It is now fixed to use the application name, however if FastMM is used

    inside other DLLs the name of those DLLs will be used. (Thanks to Bart van

    der Werf.)

  - Added a "FastMMVersion" constant. (Suggested by Loris Luise.)

  - Fixed an issue with error message boxes not displaying under certain

    configurations. (Thanks to J.W. de Bokx.)

  - FastMM will now display only one error message at a time. If many errors

    occur in quick succession, only the first error will be shown (but all will

    be logged). This avoids a stack overflow with badly misbehaved programs.

    (Thanks to Bart van der Werf.)

  - Added a LoadDebugDLLDynamically option to be used in conjunction with

    FullDebugMode. In this mode FastMM_FullDebugMode.dll is loaded dynamically.

    If the DLL cannot be found, stack traces will not be available. (Thanks to

    Rene Mihula.)

  Version 4.78 (1 March 2007):

  - The MB_DEFAULT_DESKTOP_ONLY constant that is used when displaying messages

    boxes since 4.76 is not defined under Kylix, and the source would thus not

    compile. That constant is now defined. (Thanks to Werner Bochtler.)

  - Moved the medium block locking code that was duplicated in several places

    to a subroutine to reduce code size. (Thanks to Hallvard Vassbotn.)

  - Fixed a bug in the leak registration code that sometimes caused registered

    leaks to be reported erroneously. (Thanks to Primoz Gabrijelcic.)

  - Added the NoDebugInfo option (on by default) that suppresses the generation

    of debug info for the FastMM4.pas unit. This will prevent the integrated

    debugger from stepping into the memory manager. (Thanks to Primoz

    Gabrijelcic.)

  - Increased the default stack trace depth in FullDebugMode from 9 to 10 to

    ensure that the Align16Bytes setting works in FullDebugMode. (Thanks to

    Igor Lindunen.)

  - Updated the Czech translation. (Thanks to Rene Mihula.)

  Version 4.84 (7 July 2008):

  - Added the Romanian translation. (Thanks to Ionut Muntean.)

  - Optimized the GetMemoryMap procedure to improve speed.

  - Added the GetMemoryManagerUsageSummary function that returns a summary of

    the GetMemoryManagerState call. (Thanks to Hallvard Vassbotn.)

  - Added the French translation. (Thanks to Florent Ouchet.)

  - Added the "AlwaysAllocateTopDown" FullDebugMode option to help with

    catching bad pointer arithmetic code in an address space > 2GB. This option

    is enabled by default.

  - Added the "InstallOnlyIfRunningInIDE" option. Enable this option to

    only install FastMM as the memory manager when the application is run

    inside the Delphi IDE. This is useful when you want to deploy the same EXE

    that you use for testing, but only want the debugging features active on

    development machines. When this option is enabled and the application is

    not being run inside the IDE, then the default Delphi memory manager will

    be used (which, since Delphi 2006, is FastMM without FullDebugMode.) This

    option is off by default.

  - Added the "FullDebugModeInIDE" option. This is a convenient shorthand for

    enabling FullDebugMode, InstallOnlyIfRunningInIDE and

    LoadDebugDLLDynamically. This causes FastMM to be used in FullDebugMode

    when the application is being debugged on development machines, and the

    default memory manager when the same executable is deployed. This allows

    the debugging and deployment of an application without having to compile

    separate executables. This option is off by default.

  - Added a ScanMemoryPoolForCorruptions procedure that checks the entire

    memory pool for corruptions and raises an exception if one is found. It can

    be called at any time, but is only available in FullDebugMode. (Thanks to

    Marcus Mönnig.)

  - Added a global variable "FullDebugModeScanMemoryPoolBeforeEveryOperation".

    When this variable is set to true and FullDebugMode is enabled, then the

    entire memory pool is checked for consistency before every GetMem, FreeMem

    and ReallocMem operation. An "Out of Memory" error is raised if a

    corruption is found (and this variable is set to false to prevent recursive

    errors). This obviously incurs a massive performance hit, so enable it only

    when hunting for elusive memory corruption bugs. (Thanks to Marcus Mönnig.)

  - Fixed a bug in AllocMem that caused the FPU stack to be shifted by one

    position.

  - Changed the default for option "EnableMMX" to false, since using MMX may

    cause unexpected behaviour in code that passes parameters on the FPU stack

    (like some "compiler magic" routines, e.g. VarFromReal).

  - Removed the "EnableSharingWithDefaultMM" option. This is now the default

    behaviour and cannot be disabled. (FastMM will always try to share memory

    managers between itself and the default memory manager when memory manager

    sharing is enabled.)

  - Introduced a new memory manager sharing mechanism based on memory mapped

    files. This solves compatibility issues with console and service

    applications. This sharing mechanism currently runs in parallel with the

    old mechanism, but the old mechanism can be disabled by undefining

    "EnableBackwardCompatibleMMSharing" in FastMM4Options.inc.

  - Fixed the recursive call error when the EnableMemoryLeakReporting option

    is disabled and an attempt is made to register a memory leak under Delphi

    2006 or later. (Thanks to Thomas Schulz.)

  - Added a global variable "SuppressMessageBoxes" to enable or disable

    messageboxes at runtime. (Thanks to Craig Peterson.)

  - Added the leak reporting code for C++ Builder, as well as various other

    C++ Builder bits written by JiYuan Xie. (Thank you!)

  - Added the new Usage Tracker written by Hanspeter Widmer. (Thank you!)

  Version 4.86 (31 July 2008):

  - Tweaked the string detection algorithm somewhat to be less strict, and

    allow non-class leaks to be more often categorized as strings.

  - Fixed a compilation error under Delphi 5.

  - Made LogAllocatedBlocksToFile and ScanMemoryPoolForCorruptions thread

    safe. (Thanks to Francois Piette.)

  Version 4.88 (13 August 2008):

  - Fixed compiler warnings in NoOpRegisterExpectedMemoryLeak and

    NoOpUnRegisterExpectedMemoryLeak. (Thanks to Michael Rabatscher.)

  - Added the Simplified Chinese translation of FastMM4Options.inc by

    QianYuan Wang. (Thank you!)

  - Included the updated C++ Builder files with support for BCB6 without

    update 4 applied. (Submitted by JiYuan Xie. Thanks!)

  - Fixed a compilation error under Delphi 5.

  - Made LogAllocatedBlocksToFile and ScanMemoryPoolForCorruptions thread

    safe - for real this time. (Thanks to Francois Piette.)

  Version 4.90 (9 September 2008):

  - Added logging of the thread ID when capturing and displaying stack

    traces. (Suggested by Allen Bauer and Mark Edington.)

  - Fixed a Delphi 5 compiler error under FullDebugMode. (Thanks to Maurizio

    Lotauro and Christian-W. Budde.)

  - Changed a default setting in FastMM4Options.inc: RawStackTraces is now

    off by default due to the high number of support requests I receive with

    regards to the false postives it may cause. I recommend compiling debug

    builds of applications with the "Stack Frames" option enabled.

  - Fixed a compilation error under Kylix. (Thanks to Werner Bochtler.)

  - Official support for Delphi 2009.

  Version 4.92 (25 November 2008):

  - Added the DisableLoggingOfMemoryDumps option under FullDebugMode. When

    this option is set, memory dumps will not be logged for memory leaks or

    errors. (Thanks to Patrick van Logchem.)

  - Exposed the class and string type detection code in the interface section

    for use in application code (if required). (Requested by Patrick van

    Logchem.)

  - Fixed a bug in SetMMLogFileName that could cause the log file name to be

    set incorrectly.

  - Added BCB4 support. (Thanks to Norbert Spiegel.)

  - Included the updated Czech translation by Rene Mihula.

  - When FastMM raises an error due to a freed block being modified, it now

    logs detail about which bytes in the block were modified.

  Version 4.94 (28 August 2009):

  - Added the DoNotInstallIfDLLMissing option that prevents FastMM from

    installing itself if the FastMM_FullDebugMode.dll library is not

    available. (Only applicable when FullDebugMode and LoadDebugDLLDynamically

    are both enabled.) This is useful when the same executable will be used for

    both debugging and deployment - when the debug support DLL is available

    FastMM will be installed in FullDebugMode, and otherwise the default memory

    manager will be used.

  - Added the FullDebugModeWhenDLLAvailable option that combines the

    FullDebugMode, LoadDebugDLLDynamically and DoNotInstallIfDLLMissing options.

  - Re-enabled RawStackTraces by default. The frame based stack traces (even

    when compiling with stack frames enabled) are generally too incomplete.

  - Improved the speed of large block operations under FullDebugMode: Since

    large blocks are never reused, there is no point in clearing them before

    and after use (so it does not do that anymore).

  - If an error occurs in FullDebugMode and FastMM is unable to append to the

    log file, it will attempt to write to a log file of the same name in the

    "My Documents" folder. This feature is helpful when the executable resides

    in a read-only location and the default log file, which is derived from the

    executable name, would thus not be writeable.

  - Added support for controlling the error log file location through an

    environment variable. If the 'FastMMLogFilePath' environment variable is

    set then any generated error logs will be written to the specified folder

    instead of the default location (which is the same folder as the

    application).

  - Improved the call instruction detection code in the FastMM_FullDebugMode

    library. (Thanks to the JCL team.)

  - Improved the string leak detection and reporting code. (Thanks to Uwe

    Schuster.)

  - New FullDebugMode feature: Whenever FreeMem or ReallocMem is called, FastMM

    will check that the block was actually allocated through the same FastMM

    instance. This is useful for tracking down memory manager sharing issues.

  - Compatible with Delphi 2010.

  Version 4.96 (31 August 2010):

  - Reduced the minimum block size to 4 bytes from the previous value of 12

    bytes (only applicable to 8 byte alignment). This reduces memory usage if

    the application allocates many blocks <= 4 bytes in size.

  - Added colour-coded change indication to the FastMM usage tracker, making

    it easier to spot changes in the memory usage grid. (Thanks to Murray

    McGowan.)

  - Added the SuppressFreeMemErrorsInsideException FullDebugMode option: If

    FastMM encounters a problem with a memory block inside the FullDebugMode

    FreeMem handler then an "invalid pointer operation" exception will usually

    be raised. If the FreeMem occurs while another exception is being handled

    (perhaps in the try.. finally code) then the original exception will be

    lost. With this option set FastMM will ignore errors inside FreeMem when an

    exception is being handled, thus allowing the original exception to

    propagate. This option is on by default. (Thanks to Michael Hieke.)

  - Fixed Windows 95 FullDebugMode support that was broken in 4.94. (Thanks to

    Richard Bradbrook.)

  - Fixed a bug affecting GetMemoryMap performance and accuracy of measurements

    above 2GB if a large address space is not enabled for the project. (Thanks

    to Michael Hieke.)

  - Added the FullDebugModeRegisterAllAllocsAsExpectedMemoryLeak boolean flag.

    When set, all allocations are automatically registered as expected memory

    leaks. Only available in FullDebugMode. (Thanks to Brian Cook.)

  - Compatible with Delphi XE.

  Version 4.97 (30 September 2010):

  - Fixed a crash bug (that crept in in 4.96) that may manifest itself when

    resizing a block to 4 bytes or less.

  - Added the UseSwitchToThread option. Set this option to call SwitchToThread

    instead of sitting in a "busy waiting" loop when a thread contention

    occurs. This is used in conjunction with the NeverSleepOnThreadContention

    option, and has no effect unless NeverSleepOnThreadContention is also

    defined. This option may improve performance with many CPU cores and/or

    threads of different priorities. Note that the SwitchToThread API call is

    only available on Windows 2000 and later. (Thanks to Zach Saw.)

  Version 4.98 (23 September 2011):

  - Added the FullDebugModeCallBacks define which adds support for memory

    manager event callbacks. This allows the application to be notified of

    memory allocations, frees and reallocations as they occur. (Thanks to

    Jeroen Pluimers.)

  - Added security options ClearMemoryBeforeReturningToOS and

    AlwaysClearFreedMemory to force the clearing of memory blocks after being

    freed. This could possibly provide some protection against information

    theft, but at a significant performance penalty. (Thanks to Andrey

    Sozonov.)

  - Shifted the code in the initialization section to a procedure

    RunInitializationCode. This allows the startup code to be called before

    InitUnits, which is required by some software protection tools.

  - Added support for Delphi XE2 (Windows 32-bit and Windows 64-bit platforms

    only).

  Version 4.99 (6 November 2011):

  - Fixed crashes in the 64-bit BASM codepath when more than 4GB of memory is

    allocated.

  - Fixed bad record alignment under 64-bit that affected performance.

  - Fixed compilation errors with some older compilers.

  Version 4.991 (3 September 2012)

  - Added the LogMemoryManagerStateToFile call. This call logs a summary of

    the memory manager state to file: The total allocated memory, overhead,

    efficiency, and a breakdown of allocated memory by class and string type.

    This call may be useful to catch objects that do not necessarily leak, but

    do linger longer than they should.

  - OS X support added by Sebastian Zierer

  - Compatible with Delphi XE3



*)



unit FastMM4;



interface



{$Include FastMM4Options.inc}



{$RANGECHECKS OFF}

{$BOOLEVAL OFF}

{$OVERFLOWCHECKS OFF}

{$OPTIMIZATION ON}

{$TYPEDADDRESS OFF}

{$LONGSTRINGS ON}



{Compiler version defines}

{$ifndef BCB}

  {$ifdef ver120}

    {$define Delphi4or5}

  {$endif}

  {$ifdef ver130}

    {$define Delphi4or5}

  {$endif}

  {$ifdef ver140}

    {$define Delphi6}

  {$endif}

  {$ifdef ver150}

    {$define Delphi7}

  {$endif}

  {$ifdef ver170}

    {$define Delphi2005}

  {$endif}

{$else}

  {for BCB4, use the Delphi 5 codepath}

  {$ifdef ver120}

    {$define Delphi4or5}

    {$define BCB4}

  {$endif}

  {for BCB5, use the Delphi 5 codepath}

  {$ifdef ver130}

    {$define Delphi4or5}

  {$endif}

{$endif}

{$ifdef ver180}

  {$define BDS2006}

{$endif}

{$define 32Bit}

{$ifndef Delphi4or5}

  {$if SizeOf(Pointer) = 8}

    {$define 64Bit}

    {$undef 32Bit}

  {$ifend}

  {$if CompilerVersion >= 23}

    {$define XE2AndUp}

  {$ifend}

  {$define BCB6OrDelphi6AndUp}

  {$ifndef BCB}

    {$define Delphi6AndUp}

  {$endif}

  {$ifndef Delphi6}

    {$define BCB6OrDelphi7AndUp}

    {$ifndef BCB}

      {$define Delphi7AndUp}

    {$endif}

    {$ifndef BCB}

      {$ifndef Delphi7}

        {$ifndef Delphi2005}

          {$define BDS2006AndUp}

        {$endif}

      {$endif}

    {$endif}

  {$endif}

{$endif}



{$ifdef 64Bit}

  {Under 64 bit memory blocks must always be 16-byte aligned}

  {$define Align16Bytes}

  {No need for MMX under 64-bit, since SSE2 is available}

  {$undef EnableMMX}

  {There is little need for raw stack traces under 64-bit, since frame based

   stack traces are much more accurate than under 32-bit. (And frame based

   stack tracing is much faster.)}

  {$undef RawStackTraces}

{$endif}



{IDE debug mode always enables FullDebugMode and dynamic loading of the FullDebugMode DLL.}

{$ifdef FullDebugModeInIDE}

  {$define InstallOnlyIfRunningInIDE}

  {$define FullDebugMode}

  {$define LoadDebugDLLDynamically}

{$endif}



{Install in FullDebugMode only when the DLL is available?}

{$ifdef FullDebugModeWhenDLLAvailable}

  {$define FullDebugMode}

  {$define LoadDebugDLLDynamically}

  {$define DoNotInstallIfDLLMissing}

{$endif}



{$ifdef Linux}

  {$define POSIX}

{$endif}



{Some features not currently supported under Kylix / OS X}

{$ifdef POSIX}

  {$undef FullDebugMode}

  {$undef LogErrorsToFile}

  {$undef LogMemoryLeakDetailToFile}

  {$undef ShareMM}

  {$undef AttemptToUseSharedMM}

  {$undef RequireIDEPresenceForLeakReporting}

  {$undef UseOutputDebugString}

  {$ifdef PIC}

    {BASM version does not support position independent code}

    {$undef ASMVersion}

  {$endif}

{$endif}



{Do we require debug info for leak checking?}

{$ifdef RequireDebugInfoForLeakReporting}

  {$ifopt D-}

    {$undef EnableMemoryLeakReporting}

  {$endif}

{$endif}



{Enable heap checking and leak reporting in full debug mode}

{$ifdef FullDebugMode}

  {$STACKFRAMES ON}

  {$define CheckHeapForCorruption}

  {$ifndef CatchUseOfFreedInterfaces}

    {$define CheckUseOfFreedBlocksOnShutdown}

  {$endif}

{$else}

  {Error logging requires FullDebugMode}

  {$undef LogErrorsToFile}

  {$undef CatchUseOfFreedInterfaces}

  {$undef RawStackTraces}

  {$undef AlwaysAllocateTopDown}

{$endif}



{Set defines for security options}

{$ifdef FullDebugMode}

  {In FullDebugMode small and medium blocks are always cleared when calling

   FreeMem. Large blocks are always returned to the OS immediately.}

  {$ifdef ClearMemoryBeforeReturningToOS}

    {$define ClearLargeBlocksBeforeReturningToOS}

  {$endif}

  {$ifdef AlwaysClearFreedMemory}

    {$define ClearLargeBlocksBeforeReturningToOS}

  {$endif}

{$else}

  {If memory blocks are cleared in FreeMem then they do not need to be cleared

   before returning the memory to the OS.}

  {$ifdef AlwaysClearFreedMemory}

    {$define ClearSmallAndMediumBlocksInFreeMem}

    {$define ClearLargeBlocksBeforeReturningToOS}

  {$else}

    {$ifdef ClearMemoryBeforeReturningToOS}

      {$define ClearMediumBlockPoolsBeforeReturningToOS}

      {$define ClearLargeBlocksBeforeReturningToOS}

    {$endif}

  {$endif}

{$endif}



{Only the Pascal version supports extended heap corruption checking.}

{$ifdef CheckHeapForCorruption}

  {$undef ASMVersion}

{$endif}



{For BASM bits that are not implemented in 64-bit.}

{$ifdef 32Bit}

  {$ifdef ASMVersion}

    {$define Use32BitAsm}

  {$endif}

{$endif}



{$ifdef UseRuntimePackages}

  {$define AssumeMultiThreaded}

{$endif}



{$ifdef BCB6OrDelphi6AndUp}

  {$WARN SYMBOL_PLATFORM OFF}

  {$WARN SYMBOL_DEPRECATED OFF}

{$endif}



{Leak detail logging requires error logging}

{$ifndef LogErrorsToFile}

  {$undef LogMemoryLeakDetailToFile}

  {$undef ClearLogFileOnStartup}

{$endif}



{$ifndef EnableMemoryLeakReporting}

  {Manual leak reporting control requires leak reporting to be enabled}

  {$undef ManualLeakReportingControl}

{$endif}



{$ifndef EnableMMX}

  {$undef ForceMMX}

{$endif}



{Are any of the MM sharing options enabled?}

{$ifdef ShareMM}

  {$define MMSharingEnabled}

{$endif}

{$ifdef AttemptToUseSharedMM}

  {$define MMSharingEnabled}

{$endif}



{Instruct GExperts to back up the messages file as well.}

{#BACKUP FastMM4Messages.pas}



{Should debug info be disabled?}

{$ifdef NoDebugInfo}

  {$DEBUGINFO OFF}

{$endif}



{$ifdef BCB}

  {$ifdef borlndmmdll}

    {$OBJEXPORTALL OFF}

  {$endif}

  {$ifndef PatchBCBTerminate}

    {Cannot uninstall safely under BCB}

    {$define NeverUninstall}

    {Disable memory leak reporting}

    {$undef EnableMemoryLeakReporting}

  {$endif}

{$endif}



{-------------------------Public constants-----------------------------}

const

  {The current version of FastMM}

  FastMMVersion = '4.991';

  {The number of small block types}

{$ifdef Align16Bytes}

  NumSmallBlockTypes = 46;

{$else}

  NumSmallBlockTypes = 56;

{$endif}



{----------------------------Public types------------------------------}

type



  {Make sure all the required types are available}

{$ifdef BCB6OrDelphi6AndUp}

  {$if CompilerVersion < 20}

  PByte = PAnsiChar;

  {NativeInt didn't exist or was broken before Delphi 2009.}

  NativeInt = Integer;

  {$ifend}

  {$if CompilerVersion < 21}

  {NativeUInt didn't exist or was broken before Delphi 2010.}

  NativeUInt = Cardinal;

  {$ifend}

  {$if CompilerVersion < 22}

  {PNativeUInt didn't exist before Delphi XE.}

  PNativeUInt = ^Cardinal;

  {$ifend}

  {$if CompilerVersion < 23}

  {IntPtr and UIntPtr didn't exist before Delphi XE2.}

  IntPtr = Integer;

  UIntPtr = Cardinal;

  {$ifend}

{$else}

  PByte = PAnsiChar;

  NativeInt = Integer;

  NativeUInt = Cardinal;

  PNativeUInt = ^Cardinal;

  IntPtr = Integer;

  UIntPtr = Cardinal;

{$endif}



  TSmallBlockTypeState = record

    {The internal size of the block type}

    InternalBlockSize: Cardinal;

    {Useable block size: The number of non-reserved bytes inside the block.}

    UseableBlockSize: Cardinal;

    {The number of allocated blocks}

    AllocatedBlockCount: NativeUInt;

    {The total address space reserved for this block type (both allocated and

     free blocks)}

    ReservedAddressSpace: NativeUInt;

  end;

  TSmallBlockTypeStates = array[0..NumSmallBlockTypes - 1] of TSmallBlockTypeState;



  TMemoryManagerState = record

    {Small block type states}

    SmallBlockTypeStates: TSmallBlockTypeStates;

    {Medium block stats}

    AllocatedMediumBlockCount: Cardinal;

    TotalAllocatedMediumBlockSize: NativeUInt;

    ReservedMediumBlockAddressSpace: NativeUInt;

    {Large block stats}

    AllocatedLargeBlockCount: Cardinal;

    TotalAllocatedLargeBlockSize: NativeUInt;

    ReservedLargeBlockAddressSpace: NativeUInt;

  end;



  TMemoryManagerUsageSummary = record

    {The total number of bytes allocated by the application.}

    AllocatedBytes: NativeUInt;

    {The total number of address space bytes used by control structures, or

     lost due to fragmentation and other overhead.}

    OverheadBytes: NativeUInt;

    {The efficiency of the memory manager expressed as a percentage. This is

     100 * AllocatedBytes / (AllocatedBytes + OverheadBytes).}

    EfficiencyPercentage: Double;

  end;



  {Memory map}

  TChunkStatus = (csUnallocated, csAllocated, csReserved, csSysAllocated,

    csSysReserved);

  TMemoryMap = array[0..65535] of TChunkStatus;



{$ifdef EnableMemoryLeakReporting}

  {List of registered leaks}

  TRegisteredMemoryLeak = record

    LeakAddress: Pointer;

    LeakedClass: TClass;

    {$ifdef CheckCppObjectTypeEnabled}

    LeakedCppTypeIdPtr: Pointer;

    {$endif}

    LeakSize: NativeInt;

    LeakCount: Integer;

  end;

  TRegisteredMemoryLeaks = array of TRegisteredMemoryLeak;

{$endif}



  {Used by the DetectStringData routine to detect whether a leaked block

   contains string data.}

  TStringDataType = (stUnknown, stAnsiString, stUnicodeString);



  {The callback procedure for WalkAllocatedBlocks.}

  TWalkAllocatedBlocksCallback = procedure(APBlock: Pointer; ABlockSize: NativeInt; AUserData: Pointer);



{--------------------------Public variables----------------------------}

var

  {If this variable is set to true and FullDebugMode is enabled, then the

   entire memory pool is checked for consistency before every memory

   operation. Note that this incurs a massive performance hit on top of

   the already significant FullDebugMode overhead, so enable this option

   only when absolutely necessary.}

  FullDebugModeScanMemoryPoolBeforeEveryOperation: Boolean = False;

  FullDebugModeRegisterAllAllocsAsExpectedMemoryLeak: Boolean = False;

{$ifdef ManualLeakReportingControl}

  {Variable is declared in system.pas in newer Delphi versions.}

  {$ifndef BDS2006AndUp}

  ReportMemoryLeaksOnShutdown: Boolean;

  {$endif}

{$endif}

  {If set to True, disables the display of all messageboxes}

  SuppressMessageBoxes: Boolean;



{-------------------------Public procedures----------------------------}

{Executes the code normally run in the initialization section. Running it

 earlier may be required with e.g. some software protection tools.}

procedure RunInitializationCode;

{Installation procedures must be exposed for the BCB helper unit FastMM4BCB.cpp}

{$ifdef BCB}

procedure InitializeMemoryManager;

function CheckCanInstallMemoryManager: Boolean;

procedure InstallMemoryManager;



{$ifdef FullDebugMode}

(*$HPPEMIT '#define FullDebugMode' *)



{$ifdef ClearLogFileOnStartup}

(*$HPPEMIT '  #define ClearLogFileOnStartup' *)

procedure DeleteEventLog;

{$endif}



{$ifdef LoadDebugDLLDynamically}

(*$HPPEMIT '  #define LoadDebugDLLDynamically' *)

{$endif}



{$ifdef RawStackTraces}

(*$HPPEMIT '  #define RawStackTraces' *)

{$endif}



{$endif}



{$ifdef PatchBCBTerminate}

(*$HPPEMIT ''#13#10 *)

(*$HPPEMIT '#define PatchBCBTerminate' *)



{$ifdef EnableMemoryLeakReporting}

(*$HPPEMIT ''#13#10 *)

(*$HPPEMIT '#define EnableMemoryLeakReporting' *)

{$endif}



{$ifdef DetectMMOperationsAfterUninstall}

(*$HPPEMIT ''#13#10 *)

(*$HPPEMIT '#define DetectMMOperationsAfterUninstall' *)

{$endif}



{Called in FastMM4BCB.cpp, should contain codes of original "finalization" section}

procedure FinalizeMemoryManager;



{For completion of "RequireDebuggerPresenceForLeakReporting" checking in "FinalizeMemoryManager"}

var

  pCppDebugHook: ^Integer = nil; //PInteger not defined in BCB5



{$ifdef CheckCppObjectTypeEnabled}

(*$HPPEMIT ''#13#10 *)

(*$HPPEMIT '#define CheckCppObjectTypeEnabled' *)



type

  TGetCppVirtObjSizeByTypeIdPtrFunc = function(APointer: Pointer): Cardinal;

  TGetCppVirtObjTypeIdPtrFunc = function(APointer: Pointer; ASize: Cardinal): Pointer;

  TGetCppVirtObjTypeNameFunc = function(APointer: Pointer; ASize: Cardinal): PAnsiChar;

  TGetCppVirtObjTypeNameByTypeIdPtrFunc = function (APointer: Pointer): PAnsiChar;

  TGetCppVirtObjTypeNameByVTablePtrFunc = function(AVTablePtr: Pointer; AVTablePtrOffset: Cardinal): PAnsiChar;

var

  {Return virtual object's size from typeId pointer}

  GetCppVirtObjSizeByTypeIdPtrFunc: TGetCppVirtObjSizeByTypeIdPtrFunc = nil;

  {Retrieve virtual object's typeId pointer}

  GetCppVirtObjTypeIdPtrFunc: TGetCppVirtObjTypeIdPtrFunc = nil;

  {Retrieve virtual object's type name}

  GetCppVirtObjTypeNameFunc: TGetCppVirtObjTypeNameFunc = nil;

  {Return virtual object's type name from typeId pointer}

  GetCppVirtObjTypeNameByTypeIdPtrFunc: TGetCppVirtObjTypeNameByTypeIdPtrFunc = nil;

  {Retrieve virtual object's typeId pointer from it's virtual table pointer}

  GetCppVirtObjTypeNameByVTablePtrFunc: TGetCppVirtObjTypeNameByVTablePtrFunc = nil;

{$endif}

{$endif}

{$endif}



{$ifndef FullDebugMode}

{The standard memory manager functions}

function FastGetMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer;

function FastFreeMem(APointer: Pointer): Integer;

function FastReallocMem(APointer: Pointer; ANewSize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer;

function FastAllocMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Cardinal{$endif}): Pointer;

{$else}

{The FullDebugMode memory manager functions}

function DebugGetMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer;

function DebugFreeMem(APointer: Pointer): Integer;

function DebugReallocMem(APointer: Pointer; ANewSize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer;

function DebugAllocMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Cardinal{$endif}): Pointer;

{Scans the memory pool for any corruptions. If a corruption is encountered an "Out of Memory" exception is

 raised.}

procedure ScanMemoryPoolForCorruptions;

{Specify the full path and name for the filename to be used for logging memory

 errors, etc. If ALogFileName is nil or points to an empty string it will

 revert to the default log file name.}

procedure SetMMLogFileName(ALogFileName: PAnsiChar = nil);

{Returns the current "allocation group". Whenever a GetMem request is serviced

 in FullDebugMode, the current "allocation group" is stored in the block header.

 This may help with debugging. Note that if a block is subsequently reallocated

 that it keeps its original "allocation group" and "allocation number" (all

 allocations are also numbered sequentially).}

function GetCurrentAllocationGroup: Cardinal;

{Allocation groups work in a stack like fashion. Group numbers are pushed onto

 and popped off the stack. Note that the stack size is limited, so every push

 should have a matching pop.}

procedure PushAllocationGroup(ANewCurrentAllocationGroup: Cardinal);

procedure PopAllocationGroup;

{Logs detail about currently allocated memory blocks for the specified range of

 allocation groups. if ALastAllocationGroupToLog is less than

 AFirstAllocationGroupToLog or it is zero, then all allocation groups are

 logged. This routine also checks the memory pool for consistency at the same

 time, raising an "Out of Memory" error if the check fails.}

procedure LogAllocatedBlocksToFile(AFirstAllocationGroupToLog, ALastAllocationGroupToLog: Cardinal);

{$endif}



{Releases all allocated memory (use with extreme care)}

procedure FreeAllMemory;



{Returns summarised information about the state of the memory manager. (For

 backward compatibility.)}

function FastGetHeapStatus: THeapStatus;

{Returns statistics about the current state of the memory manager}

procedure GetMemoryManagerState(var AMemoryManagerState: TMemoryManagerState);

{Returns a summary of the information returned by GetMemoryManagerState}

procedure GetMemoryManagerUsageSummary(

  var AMemoryManagerUsageSummary: TMemoryManagerUsageSummary);

{$ifndef POSIX}

{Gets the state of every 64K block in the 4GB address space}

procedure GetMemoryMap(var AMemoryMap: TMemoryMap);

{$endif}



{$ifdef EnableMemoryLeakReporting}

{Registers expected memory leaks. Returns true on success. The list of leaked

 blocks is limited, so failure is possible if the list is full.}

function RegisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; overload;

function RegisterExpectedMemoryLeak(ALeakedObjectClass: TClass; ACount: Integer = 1): Boolean; overload;

function RegisterExpectedMemoryLeak(ALeakedBlockSize: NativeInt; ACount: Integer = 1): Boolean; overload;

{$ifdef CheckCppObjectTypeEnabled}

{Registers expected memory leaks by virtual object's typeId pointer.

 Usage: RegisterExpectedMemoryLeak(typeid(ACppObject).tpp, Count);}

function RegisterExpectedMemoryLeak(ALeakedCppVirtObjTypeIdPtr: Pointer; ACount: Integer): boolean; overload;

{$endif}

{Removes expected memory leaks. Returns true on success.}

function UnregisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; overload;

function UnregisterExpectedMemoryLeak(ALeakedObjectClass: TClass; ACount: Integer = 1): Boolean; overload;

function UnregisterExpectedMemoryLeak(ALeakedBlockSize: NativeInt; ACount: Integer = 1): Boolean; overload;

{$ifdef CheckCppObjectTypeEnabled}

{Usage: UnregisterExpectedMemoryLeak(typeid(ACppObject).tpp, Count);}

function UnregisterExpectedMemoryLeak(ALeakedCppVirtObjTypeIdPtr: Pointer; ACount: Integer): boolean; overload;

{$endif}

{Returns a list of all expected memory leaks}

function GetRegisteredMemoryLeaks: TRegisteredMemoryLeaks;

{$endif}



{Returns the class for a memory block. Returns nil if it is not a valid class.

 Used by the leak detection code.}

function DetectClassInstance(APointer: Pointer): TClass;

{Detects the probable string data type for a memory block. Used by the leak

 classification code when a block cannot be identified as a known class

 instance.}

function DetectStringData(APMemoryBlock: Pointer;

  AAvailableSpaceInBlock: NativeInt): TStringDataType;

{Walks all allocated blocks, calling ACallBack for each. Passes the user block size and AUserData to the callback.

 Important note: All block types will be locked during the callback, so the memory manager cannot be used inside it.}

procedure WalkAllocatedBlocks(ACallBack: TWalkAllocatedBlocksCallback; AUserData: Pointer);

{Writes a log file containing a summary of the memory mananger state and a summary of allocated blocks grouped by

 class. The file will be saved in UTF-8 encoding (in supported Delphi versions). Returns True on success. }

function LogMemoryManagerStateToFile(const AFileName: string; const AAdditionalDetails: string = ''): Boolean;



{$ifdef FullDebugMode}

{-------------FullDebugMode constants---------------}

const

  {The stack trace depth. (Must be an *uneven* number to ensure that the

   Align16Bytes option works in FullDebugMode.)}

  StackTraceDepth = 11;

  {The number of entries in the allocation group stack}

  AllocationGroupStackSize = 1000;

  {The number of fake VMT entries - used to track virtual method calls on

   freed objects. Do not change this value without also updating TFreedObject.GetVirtualMethodIndex}

  MaxFakeVMTEntries = 200;

  {The pattern used to fill unused memory}

  DebugFillByte = $80;

{$ifdef 32Bit}

  DebugFillPattern = $01010101 * Cardinal(DebugFillByte);

  {The address that is reserved so that accesses to the address of the fill

   pattern will result in an A/V. (Not used under 64-bit, since the upper half

   of the address space is always reserved by the OS.)}

  DebugReservedAddress = $01010000 * Cardinal(DebugFillByte);

{$else}

  DebugFillPattern = $8080808080808080;

{$endif}



{-------------------------FullDebugMode structures--------------------}

type

  PStackTrace = ^TStackTrace;

  TStackTrace = array[0..StackTraceDepth - 1] of NativeUInt;



  TBlockOperation = (boBlockCheck, boGetMem, boFreeMem, boReallocMem);



  {The header placed in front of blocks in FullDebugMode (just after the

   standard header). Must be a multiple of 16 bytes in size otherwise the

   Align16Bytes option will not work. Current size = 128 bytes under 32-bit,

   and 240 bytes under 64-bit.}

  PFullDebugBlockHeader = ^TFullDebugBlockHeader;

  TFullDebugBlockHeader = record

    {Space used by the medium block manager for previous/next block management.

     If a medium block is binned then these two fields will be modified.}

    Reserved1: Pointer;

    Reserved2: Pointer;

    {Is the block currently allocated? If it is allocated this will be the

     address of the getmem routine through which it was allocated, otherwise it

     will be nil.}

    AllocatedByRoutine: Pointer;

    {The allocation group: Can be used in the debugging process to group

     related memory leaks together}

    AllocationGroup: Cardinal;

    {The allocation number: All new allocations are numbered sequentially. This

     number may be useful in memory leak analysis. If it reaches 4G it wraps

     back to 0.}

    AllocationNumber: Cardinal;

    {The call stack when the block was allocated}

    AllocationStackTrace: TStackTrace;

    {The thread that allocated the block}

    AllocatedByThread: Cardinal;

    {The thread that freed the block}

    FreedByThread: Cardinal;

    {The call stack when the block was freed}

    FreeStackTrace: TStackTrace;

    {The user requested size for the block. 0 if this is the first time the

     block is used.}

    UserSize: NativeUInt;

    {The object class this block was used for the previous time it was

     allocated. When a block is freed, the pointer that would normally be in the

     space of the class pointer is copied here, so if it is detected that

     the block was used after being freed we have an idea what class it is.}

    PreviouslyUsedByClass: NativeUInt;

    {The sum of all the dwords(32-bit)/qwords(64-bit) in this structure

     excluding the initial two reserved fields and this field.}

    HeaderCheckSum: NativeUInt;

  end;

  {The NativeUInt following the user area of the block is the inverse of

   HeaderCheckSum. This is used to catch buffer overrun errors.}



  {The class used to catch attempts to execute a virtual method of a freed

   object}

  TFreedObject = class

  public

    procedure GetVirtualMethodIndex;

    procedure VirtualMethodError;

{$ifdef CatchUseOfFreedInterfaces}

    procedure InterfaceError;

{$endif}

  end;



{$ifdef FullDebugModeCallBacks}

  {FullDebugMode memory manager event callbacks. Note that APHeaderFreedBlock in the TOnDebugFreeMemFinish

   will not be valid for large (>260K) blocks.}

  TOnDebugGetMemFinish = procedure(APHeaderNewBlock: PFullDebugBlockHeader; ASize: NativeInt);

  TOnDebugFreeMemStart = procedure(APHeaderBlockToFree: PFullDebugBlockHeader);

  TOnDebugFreeMemFinish = procedure(APHeaderFreedBlock: PFullDebugBlockHeader; AResult: Integer);

  TOnDebugReallocMemStart = procedure(APHeaderBlockToReallocate: PFullDebugBlockHeader; ANewSize: NativeInt);

  TOnDebugReallocMemFinish = procedure(APHeaderReallocatedBlock: PFullDebugBlockHeader; ANewSize: NativeInt);



var

  {Note: FastMM will not catch exceptions inside these hooks, so make sure your hook code runs without

   exceptions.}

  OnDebugGetMemFinish: TOnDebugGetMemFinish = nil;

  OnDebugFreeMemStart: TOnDebugFreeMemStart = nil;

  OnDebugFreeMemFinish: TOnDebugFreeMemFinish = nil;

  OnDebugReallocMemStart: TOnDebugReallocMemStart = nil;

  OnDebugReallocMemFinish: TOnDebugReallocMemFinish = nil;

{$endif}

{$endif}



implementation



uses

{$ifndef POSIX}

  Windows,

  {$ifdef FullDebugMode}

    {$ifdef Delphi4or5}

  ShlObj,

    {$else}

  SHFolder,

    {$endif}

  {$endif}

{$else}

  {$ifdef MACOS}

  Posix.Stdlib, Posix.Unistd, Posix.Fcntl,

  {$ELSE}

  Libc,

  {$endif}

{$endif}

  FastMM4Messages;



{Fixed size move procedures. The 64-bit versions assume 16-byte alignment.}

procedure Move4(const ASource; var ADest; ACount: NativeInt); forward;

procedure Move12(const ASource; var ADest; ACount: NativeInt); forward;

procedure Move20(const ASource; var ADest; ACount: NativeInt); forward;

procedure Move28(const ASource; var ADest; ACount: NativeInt); forward;

procedure Move36(const ASource; var ADest; ACount: NativeInt); forward;

procedure Move44(const ASource; var ADest; ACount: NativeInt); forward;

procedure Move52(const ASource; var ADest; ACount: NativeInt); forward;

procedure Move60(const ASource; var ADest; ACount: NativeInt); forward;

procedure Move68(const ASource; var ADest; ACount: NativeInt); forward;

{$ifdef 64Bit}

{These are not needed and thus unimplemented under 32-bit}

procedure Move8(const ASource; var ADest; ACount: NativeInt); forward;

procedure Move24(const ASource; var ADest; ACount: NativeInt); forward;

procedure Move40(const ASource; var ADest; ACount: NativeInt); forward;

procedure Move56(const ASource; var ADest; ACount: NativeInt); forward;

{$endif}



{$ifdef DetectMMOperationsAfterUninstall}

{Invalid handlers to catch MM operations after uninstall}

function InvalidFreeMem(APointer: Pointer): Integer; forward;

function InvalidGetMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer; forward;

function InvalidReallocMem(APointer: Pointer; ANewSize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer; forward;

function InvalidAllocMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Cardinal{$endif}): Pointer; forward;

function InvalidRegisterAndUnRegisterMemoryLeak(APointer: Pointer): Boolean; forward;

{$endif}



{-------------------------Private constants----------------------------}

const

  {The size of a medium block pool. This is allocated through VirtualAlloc and

   is used to serve medium blocks. The size must be a multiple of 16 and at

   least 4 bytes less than a multiple of 4K (the page size) to prevent a

   possible read access violation when reading past the end of a memory block

   in the optimized move routine (MoveX16LP). In Full Debug mode we leave a

   trailing 256 bytes to be able to safely do a memory dump.}

  MediumBlockPoolSize = 20 * 64 * 1024{$ifndef FullDebugMode} - 16{$else} - 256{$endif};

  {The granularity of small blocks}

{$ifdef Align16Bytes}

  SmallBlockGranularity = 16;

{$else}

  SmallBlockGranularity = 8;

{$endif}

  {The granularity of medium blocks. Newly allocated medium blocks are

   a multiple of this size plus MediumBlockSizeOffset, to avoid cache line

   conflicts}

  MediumBlockGranularity = 256;

  MediumBlockSizeOffset = 48;

  {The granularity of large blocks}

  LargeBlockGranularity = 65536;

  {The maximum size of a small block. Blocks Larger than this are either

   medium or large blocks.}

  MaximumSmallBlockSize = 2608;

  {The smallest medium block size. (Medium blocks are rounded up to the nearest

   multiple of MediumBlockGranularity plus MediumBlockSizeOffset)}

  MinimumMediumBlockSize = 11 * 256 + MediumBlockSizeOffset;

  {The number of bins reserved for medium blocks}

  MediumBlockBinsPerGroup = 32;

  MediumBlockBinGroupCount = 32;

  MediumBlockBinCount = MediumBlockBinGroupCount * MediumBlockBinsPerGroup;

  {The maximum size allocatable through medium blocks. Blocks larger than this

   fall through to VirtualAlloc ( = large blocks).}

  MaximumMediumBlockSize = MinimumMediumBlockSize + (MediumBlockBinCount - 1) * MediumBlockGranularity;

  {The target number of small blocks per pool. The actual number of blocks per

   pool may be much greater for very small sizes and less for larger sizes. The

   cost of allocating the small block pool is amortized across all the small

   blocks in the pool, however the blocks may not all end up being used so they

   may be lying idle.}

  TargetSmallBlocksPerPool = 48;

  {The minimum number of small blocks per pool. Any available medium block must

   have space for roughly this many small blocks (or more) to be useable as a

   small block pool.}

  MinimumSmallBlocksPerPool = 12;

  {The lower and upper limits for the optimal small block pool size}

  OptimalSmallBlockPoolSizeLowerLimit = 29 * 1024 - MediumBlockGranularity + MediumBlockSizeOffset;

  OptimalSmallBlockPoolSizeUpperLimit = 64 * 1024 - MediumBlockGranularity + MediumBlockSizeOffset;

  {The maximum small block pool size. If a free block is this size or larger

   then it will be split.}

  MaximumSmallBlockPoolSize = OptimalSmallBlockPoolSizeUpperLimit + MinimumMediumBlockSize;

  {-------------Block type flags--------------}

  {The lower 3 bits in the dword header of small blocks (4 bits in medium and

   large blocks) are used as flags to indicate the state of the block}

  {Set if the block is not in use}

  IsFreeBlockFlag = 1;

  {Set if this is a medium block}

  IsMediumBlockFlag = 2;

  {Set if it is a medium block being used as a small block pool. Only valid if

   IsMediumBlockFlag is set.}

  IsSmallBlockPoolInUseFlag = 4;

  {Set if it is a large block. Only valid if IsMediumBlockFlag is not set.}

  IsLargeBlockFlag = 4;

  {Is the medium block preceding this block available? (Only used by medium

   blocks)}

  PreviousMediumBlockIsFreeFlag = 8;

  {Is this large block segmented? I.e. is it actually built up from more than

   one chunk allocated through VirtualAlloc? (Only used by large blocks.)}

  LargeBlockIsSegmented = 8;

  {The flags masks for small blocks}

  DropSmallFlagsMask = -8;

  ExtractSmallFlagsMask = 7;

  {The flags masks for medium and large blocks}

  DropMediumAndLargeFlagsMask = -16;

  ExtractMediumAndLargeFlagsMask = 15;

  {-------------Block resizing constants---------------}

  SmallBlockDownsizeCheckAdder = 64;

  SmallBlockUpsizeAdder = 32;

  {When a medium block is reallocated to a size smaller than this, then it must

   be reallocated to a small block and the data moved. If not, then it is

   shrunk in place down to MinimumMediumBlockSize. Currently the limit is set

   at a quarter of the minimum medium block size.}

  MediumInPlaceDownsizeLimit = MinimumMediumBlockSize div 4;

  {-------------Memory leak reporting constants---------------}

  ExpectedMemoryLeaksListSize = 64 * 1024;

  {-------------Other constants---------------}

{$ifndef NeverSleepOnThreadContention}

  {Sleep time when a resource (small/medium/large block manager) is in use}

  InitialSleepTime = 0;

  {Used when the resource is still in use after the first sleep}

  AdditionalSleepTime = 1;

{$endif}

  {Hexadecimal characters}

  HexTable: array[0..15] of AnsiChar = ('0', '1', '2', '3', '4', '5', '6', '7',

    '8', '9', 'A', 'B', 'C', 'D', 'E', 'F');

  {Copyright message - not used anywhere in the code}

  Copyright: AnsiString = 'FastMM4 (c) 2004 - 2011 Pierre le Riche / Professional Software Development';

{$ifdef FullDebugMode}

  {Virtual Method Called On Freed Object Errors}

  StandardVirtualMethodNames: array[1 + vmtParent div SizeOf(Pointer) .. vmtDestroy div SizeOf(Pointer)] of PAnsiChar = (

{$ifdef BCB6OrDelphi6AndUp}

  {$if RTLVersion >= 20}

    'Equals',

    'GetHashCode',

    'ToString',

  {$ifend}

{$endif}

    'SafeCallException',

    'AfterConstruction',

    'BeforeDestruction',

    'Dispatch',

    'DefaultHandler',

    'NewInstance',

    'FreeInstance',

    'Destroy');

  {The name of the FullDebugMode support DLL. The support DLL implements stack

   tracing and the conversion of addresses to unit and line number information.}

{$ifdef 32Bit}

  FullDebugModeLibraryName = FullDebugModeLibraryName32Bit;

{$else}

  FullDebugModeLibraryName = FullDebugModeLibraryName64Bit;

{$endif}

{$endif}



{-------------------------Private types----------------------------}

type



{$ifdef Delphi4or5}

  {Delphi 5 Compatibility}

  PCardinal = ^Cardinal;

  PPointer = ^Pointer;

{$endif}

{$ifdef BCB4}

  {Define some additional types for BCB4}

  PInteger  = ^Integer;

{$endif}



  {Move procedure type}

  TMoveProc = procedure(const ASource; var ADest; ACount: NativeInt);



  {Registers structure (for GetCPUID)}

  TRegisters = record

    RegEAX, RegEBX, RegECX, RegEDX: Integer;

  end;



  {The layout of a string allocation. Used to detect string leaks.}

  PStrRec = ^StrRec;

  StrRec = packed record

{$ifdef 64Bit}

    _Padding: Integer;

{$endif}

{$ifdef BCB6OrDelphi6AndUp}

  {$if RTLVersion >= 20}

    codePage: Word;

    elemSize: Word;

  {$ifend}

{$endif}

    refCnt: Integer;

    length: Integer;

  end;



{$ifdef EnableMemoryLeakReporting}

  {Different kinds of memory leaks}

  TMemoryLeakType = (mltUnexpectedLeak, mltExpectedLeakRegisteredByPointer,

    mltExpectedLeakRegisteredByClass, mltExpectedLeakRegisteredBySize);

{$endif}



  {---------------Small block structures-------------}



  {Pointer to the header of a small block pool}

  PSmallBlockPoolHeader = ^TSmallBlockPoolHeader;



  {Small block type (Size = 32 bytes for 32-bit, 64 bytes for 64-bit).}

  PSmallBlockType = ^TSmallBlockType;

  TSmallBlockType = record

    {True = Block type is locked}

    BlockTypeLocked: Boolean;

    {Bitmap indicating which of the first 8 medium block groups contain blocks

     of a suitable size for a block pool.}

    AllowedGroupsForBlockPoolBitmap: Byte;

    {The block size for this block type}

    BlockSize: Word;

    {The minimum and optimal size of a small block pool for this block type}

    MinimumBlockPoolSize: Word;

    OptimalBlockPoolSize: Word;

    {The first partially free pool for the given small block. This field must

     be at the same offset as TSmallBlockPoolHeader.NextPartiallyFreePool.}

    NextPartiallyFreePool: PSmallBlockPoolHeader;

    {The last partially free pool for the small block type. This field must

     be at the same offset as TSmallBlockPoolHeader.PreviousPartiallyFreePool.}

    PreviousPartiallyFreePool: PSmallBlockPoolHeader;

    {The offset of the last block that was served sequentially. The field must

     be at the same offset as TSmallBlockPoolHeader.FirstFreeBlock.}

    NextSequentialFeedBlockAddress: Pointer;

    {The last block that can be served sequentially.}

    MaxSequentialFeedBlockAddress: Pointer;

    {The pool that is current being used to serve blocks in sequential order}

    CurrentSequentialFeedPool: PSmallBlockPoolHeader;

{$ifdef UseCustomFixedSizeMoveRoutines}

    {The fixed size move procedure used to move data for this block size when

     it is upsized. When a block is downsized (which usually does not occur

     that often) the variable size move routine is used.}

    UpsizeMoveProcedure: TMoveProc;

{$else}

    Reserved1: Pointer;

{$endif}

{$ifdef 64Bit}

    {Pad to 64 bytes for 64-bit}

    Reserved2: Pointer;

{$endif}

  end;



  {Small block pool (Size = 32 bytes for 32-bit, 48 bytes for 64-bit).}

  TSmallBlockPoolHeader = record

    {BlockType}

    BlockType: PSmallBlockType;

{$ifdef 32Bit}

    {Align the next fields to the same fields in TSmallBlockType and pad this

     structure to 32 bytes for 32-bit}

    Reserved1: Cardinal;

{$endif}

    {The next and previous pool that has free blocks of this size. Do not

     change the position of these two fields: They must be at the same offsets

     as the fields in TSmallBlockType of the same name.}

    NextPartiallyFreePool: PSmallBlockPoolHeader;

    PreviousPartiallyFreePool: PSmallBlockPoolHeader;

    {Pointer to the first free block inside this pool. This field must be at

     the same offset as TSmallBlockType.NextSequentialFeedBlockAddress.}

    FirstFreeBlock: Pointer;

    {The number of blocks allocated in this pool.}

    BlocksInUse: Cardinal;

    {Padding}

    Reserved2: Cardinal;

    {The pool pointer and flags of the first block}

    FirstBlockPoolPointerAndFlags: NativeUInt;

  end;



  {Small block layout:

   At offset -SizeOf(Pointer) = Flags + address of the small block pool.

   At offset BlockSize - SizeOf(Pointer) = Flags + address of the small block

   pool for the next small block.

  }



  {------------------------Medium block structures------------------------}



  {The medium block pool from which medium blocks are drawn. Size = 16 bytes

   for 32-bit and 32 bytes for 64-bit.}

  PMediumBlockPoolHeader = ^TMediumBlockPoolHeader;

  TMediumBlockPoolHeader = record

    {Points to the previous and next medium block pools. This circular linked

     list is used to track memory leaks on program shutdown.}

    PreviousMediumBlockPoolHeader: PMediumBlockPoolHeader;

    NextMediumBlockPoolHeader: PMediumBlockPoolHeader;

    {Padding}

    Reserved1: NativeUInt;

    {The block size and flags of the first medium block in the block pool}

    FirstMediumBlockSizeAndFlags: NativeUInt;

  end;



  {Medium block layout:

   Offset: -2 * SizeOf(Pointer) = Previous Block Size (only if the previous block is free)

   Offset: -SizeOf(Pointer) = This block size and flags

   Offset: 0 = User data / Previous Free Block (if this block is free)

   Offset: SizeOf(Pointer) = Next Free Block (if this block is free)

   Offset: BlockSize - 2*SizeOf(Pointer) = Size of this block (if this block is free)

   Offset: BlockSize - SizeOf(Pointer) = Size of the next block and flags



  {A medium block that is unused}

  PMediumFreeBlock = ^TMediumFreeBlock;

  TMediumFreeBlock = record

    PreviousFreeBlock: PMediumFreeBlock;

    NextFreeBlock: PMediumFreeBlock;

  end;



  {-------------------------Large block structures------------------------}



  {Large block header record (Size = 16 for 32-bit, 32 for 64-bit)}

  PLargeBlockHeader = ^TLargeBlockHeader;

  TLargeBlockHeader = record

    {Points to the previous and next large blocks. This circular linked

     list is used to track memory leaks on program shutdown.}

    PreviousLargeBlockHeader: PLargeBlockHeader;

    NextLargeBlockHeader: PLargeBlockHeader;

    {The user allocated size of the Large block}

    UserAllocatedSize: NativeUInt;

    {The size of this block plus the flags}

    BlockSizeAndFlags: NativeUInt;

  end;



  {-------------------------Expected Memory Leak Structures--------------------}

{$ifdef EnableMemoryLeakReporting}



  {The layout of an expected leak. All fields may not be specified, in which

   case it may be harder to determine which leaks are expected and which are

   not.}

  PExpectedMemoryLeak = ^TExpectedMemoryLeak;

  PPExpectedMemoryLeak = ^PExpectedMemoryLeak;

  TExpectedMemoryLeak = record

    {Linked list pointers}

    PreviousLeak, NextLeak: PExpectedMemoryLeak;

    {Information about the expected leak}

    LeakAddress: Pointer;

    LeakedClass: TClass;

    {$ifdef CheckCppObjectTypeEnabled}

    LeakedCppTypeIdPtr: Pointer;

    {$endif}

    LeakSize: NativeInt;

    LeakCount: Integer;

  end;



  TExpectedMemoryLeaks = record

    {The number of entries used in the expected leaks buffer}

    EntriesUsed: Integer;

    {Freed entries}

    FirstFreeSlot: PExpectedMemoryLeak;

    {Entries with the address specified}

    FirstEntryByAddress: PExpectedMemoryLeak;

    {Entries with no address specified, but with the class specified}

    FirstEntryByClass: PExpectedMemoryLeak;

    {Entries with only size specified}

    FirstEntryBySizeOnly: PExpectedMemoryLeak;

    {The expected leaks buffer (Need to leave space for this header)}

    ExpectedLeaks: array[0..(ExpectedMemoryLeaksListSize - 64) div SizeOf(TExpectedMemoryLeak) - 1] of TExpectedMemoryLeak;

  end;

  PExpectedMemoryLeaks = ^TExpectedMemoryLeaks;



{$endif}



{-------------------------Private constants----------------------------}

const

{$ifndef BCB6OrDelphi7AndUp}

  reOutOfMemory = 1;

  reInvalidPtr = 2;

{$endif}

  {The size of the block header in front of small and medium blocks}

  BlockHeaderSize = SizeOf(Pointer);

  {The size of a small block pool header}

  SmallBlockPoolHeaderSize = SizeOf(TSmallBlockPoolHeader);

  {The size of a medium block pool header}

  MediumBlockPoolHeaderSize = SizeOf(TMediumBlockPoolHeader);

  {The size of the header in front of Large blocks}

  LargeBlockHeaderSize = SizeOf(TLargeBlockHeader);

{$ifdef FullDebugMode}

  {We need space for the header, the trailer checksum and the trailing block

   size (only used by freed medium blocks).}

  FullDebugBlockOverhead = SizeOf(TFullDebugBlockHeader) + SizeOf(NativeUInt) + SizeOf(Pointer);

{$endif}



{-------------------------Private variables----------------------------}

var

  {-----------------Small block management------------------}

  {The small block types. Sizes include the leading header. Sizes are

   picked to limit maximum wastage to about 10% or 256 bytes (whichever is

   less) where possible.}

  SmallBlockTypes: array[0..NumSmallBlockTypes - 1] of TSmallBlockType =(

    {8/16 byte jumps}

{$ifndef Align16Bytes}

    (BlockSize: 8 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: Move4{$endif}),

{$endif}

    (BlockSize: 16 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: {$ifdef 32Bit}Move12{$else}Move8{$endif}{$endif}),

{$ifndef Align16Bytes}

    (BlockSize: 24 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: Move20{$endif}),

{$endif}

    (BlockSize: 32 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: {$ifdef 32Bit}Move28{$else}Move24{$endif}{$endif}),

{$ifndef Align16Bytes}

    (BlockSize: 40 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: Move36{$endif}),

{$endif}

    (BlockSize: 48 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: {$ifdef 32Bit}Move44{$else}Move40{$endif}{$endif}),

{$ifndef Align16Bytes}

    (BlockSize: 56 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: Move52{$endif}),

{$endif}

    (BlockSize: 64 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: {$ifdef 32Bit}Move60{$else}Move56{$endif}{$endif}),

{$ifndef Align16Bytes}

    (BlockSize: 72 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: Move68{$endif}),

{$endif}

    (BlockSize: 80),

{$ifndef Align16Bytes}

    (BlockSize: 88),

{$endif}

    (BlockSize: 96),

{$ifndef Align16Bytes}

    (BlockSize: 104),

{$endif}

    (BlockSize: 112),

{$ifndef Align16Bytes}

    (BlockSize: 120),

{$endif}

    (BlockSize: 128),

{$ifndef Align16Bytes}

    (BlockSize: 136),

{$endif}

    (BlockSize: 144),

{$ifndef Align16Bytes}

    (BlockSize: 152),

{$endif}

    (BlockSize: 160),

    {16 byte jumps}

    (BlockSize: 176),

    (BlockSize: 192),

    (BlockSize: 208),

    (BlockSize: 224),

    (BlockSize: 240),

    (BlockSize: 256),

    (BlockSize: 272),

    (BlockSize: 288),

    (BlockSize: 304),

    (BlockSize: 320),

    {32 byte jumps}

    (BlockSize: 352),

    (BlockSize: 384),

    (BlockSize: 416),

    (BlockSize: 448),

    (BlockSize: 480),

    {48 byte jumps}

    (BlockSize: 528),

    (BlockSize: 576),

    (BlockSize: 624),

    (BlockSize: 672),

    {64 byte jumps}

    (BlockSize: 736),

    (BlockSize: 800),

    {80 byte jumps}

    (BlockSize: 880),

    (BlockSize: 960),

    {96 byte jumps}

    (BlockSize: 1056),

    (BlockSize: 1152),

    {112 byte jumps}

    (BlockSize: 1264),

    (BlockSize: 1376),

    {128 byte jumps}

    (BlockSize: 1504),

    {144 byte jumps}

    (BlockSize: 1648),

    {160 byte jumps}

    (BlockSize: 1808),

    {176 byte jumps}

    (BlockSize: 1984),

    {192 byte jumps}

    (BlockSize: 2176),

    {208 byte jumps}

    (BlockSize: 2384),

    {224 byte jumps}

    (BlockSize: MaximumSmallBlockSize),

    {The last block size occurs three times. If, during a GetMem call, the

     requested block size is already locked by another thread then up to two

     larger block sizes may be used instead. Having the last block size occur

     three times avoids the need to have a size overflow check.}

    (BlockSize: MaximumSmallBlockSize),

    (BlockSize: MaximumSmallBlockSize));

  {Size to small block type translation table}

  AllocSize2SmallBlockTypeIndX4: array[0..(MaximumSmallBlockSize - 1) div SmallBlockGranularity] of Byte;

  {-----------------Medium block management------------------}

  {A dummy medium block pool header: Maintains a circular list of all medium

   block pools to enable memory leak detection on program shutdown.}

  MediumBlockPoolsCircularList: TMediumBlockPoolHeader;

  {Are medium blocks locked?}

  MediumBlocksLocked: Boolean;

  {The sequential feed medium block pool.}

  LastSequentiallyFedMediumBlock: Pointer;

  MediumSequentialFeedBytesLeft: Cardinal;

  {The medium block bins are divided into groups of 32 bins. If a bit

   is set in this group bitmap, then at least one bin in the group has free

   blocks.}

  MediumBlockBinGroupBitmap: Cardinal;

  {The medium block bins: total of 32 * 32 = 1024 bins of a certain

   minimum size.}

  MediumBlockBinBitmaps: array[0..MediumBlockBinGroupCount - 1] of Cardinal;

  {The medium block bins. There are 1024 LIFO circular linked lists each

   holding blocks of a specified minimum size. The sizes vary in size from

   MinimumMediumBlockSize to MaximumMediumBlockSize. The bins are treated as

   type TMediumFreeBlock to avoid pointer checks.}

  MediumBlockBins: array[0..MediumBlockBinCount - 1] of TMediumFreeBlock;

  {-----------------Large block management------------------}

  {Are large blocks locked?}

  LargeBlocksLocked: Boolean;

  {A dummy large block header: Maintains a list of all allocated large blocks

   to enable memory leak detection on program shutdown.}

  LargeBlocksCircularList: TLargeBlockHeader;

  {-------------------------Expected Memory Leak Structures--------------------}

{$ifdef EnableMemoryLeakReporting}

  {The expected memory leaks}

  ExpectedMemoryLeaks: PExpectedMemoryLeaks;

  ExpectedMemoryLeaksListLocked: Boolean;

{$endif}

  {---------------------Full Debug Mode structures--------------------}

{$ifdef FullDebugMode}

  {The allocation group stack}

  AllocationGroupStack: array[0..AllocationGroupStackSize - 1] of Cardinal;

  {The allocation group stack top (it is an index into AllocationGroupStack)}

  AllocationGroupStackTop: Cardinal;

  {The last allocation number used}

  CurrentAllocationNumber: Cardinal;

  {This is a count of the number of threads currently inside any of the

   FullDebugMode GetMem, Freemem or ReallocMem handlers. If this value

   is negative then a block scan is in progress and no thread may

   allocate, free or reallocate any block or modify any FullDebugMode

   block header or footer.}

  ThreadsInFullDebugModeRoutine: Integer;

  {The current log file name}

  MMLogFileName: array[0..1023] of AnsiChar;

  {The 64K block of reserved memory used to trap invalid memory accesses using

   fields in a freed object.}

  ReservedBlock: Pointer;

  {The virtual method index count - used to get the virtual method index for a

   virtual method call on a freed object.}

  VMIndex: Integer;

  {The fake VMT used to catch virtual method calls on freed objects.}

  FreedObjectVMT: packed record

    VMTData: array[vmtSelfPtr .. vmtParent + SizeOf(Pointer) - 1] of byte;

    VMTMethods: array[SizeOf(Pointer) + vmtParent .. vmtParent + MaxFakeVMTEntries * SizeOf(Pointer) + SizeOf(Pointer) - 1] of Byte;

  end;

  {$ifdef CatchUseOfFreedInterfaces}

  VMTBadInterface: array[0..MaxFakeVMTEntries - 1] of Pointer;

  {$endif}

{$endif}

  {--------------Other info--------------}

  {The memory manager that was replaced}

  OldMemoryManager: {$ifndef BDS2006AndUp}TMemoryManager{$else}TMemoryManagerEx{$endif};

  {The replacement memory manager}

  NewMemoryManager: {$ifndef BDS2006AndUp}TMemoryManager{$else}TMemoryManagerEx{$endif};

{$ifdef DetectMMOperationsAfterUninstall}

  {Invalid handlers to catch MM operations after uninstall}

  InvalidMemoryManager: {$ifndef BDS2006AndUp}TMemoryManager{$else}TMemoryManagerEx{$endif} = (

    GetMem: InvalidGetMem;

    FreeMem: InvalidFreeMem;

    ReallocMem: InvalidReallocMem

  {$ifdef BDS2006AndUp};

    AllocMem: InvalidAllocMem;

    RegisterExpectedMemoryLeak: InvalidRegisterAndUnRegisterMemoryLeak;

    UnRegisterExpectedMemoryLeak: InvalidRegisterAndUnRegisterMemoryLeak;

  {$endif}

  );

{$endif}



{$ifdef MMSharingEnabled}

  {A string uniquely identifying the current process (for sharing the memory

   manager between DLLs and the main application)}

  MappingObjectName: array[0..25] of AnsiChar = ('L', 'o', 'c', 'a', 'l', '\',

    'F', 'a', 's', 't', 'M', 'M', '_', 'P', 'I', 'D', '_', '?', '?', '?', '?',

    '?', '?', '?', '?', #0);

{$ifdef EnableBackwardCompatibleMMSharing}

  UniqueProcessIDString: array[1..20] of AnsiChar = ('?', '?', '?', '?', '?',

    '?', '?', '?', '_', 'P', 'I', 'D', '_', 'F', 'a', 's', 't', 'M', 'M', #0);

  UniqueProcessIDStringBE: array[1..23] of AnsiChar = ('?', '?', '?', '?', '?',

    '?', '?', '?', '_', 'P', 'I', 'D', '_', 'F', 'a', 's', 't', 'M', 'M', '_',

    'B', 'E', #0);

  {The handle of the MM window}

  MMWindow: HWND;

  {The handle of the MM window (for default MM of Delphi 2006 compatibility)}

  MMWindowBE: HWND;

{$endif}

  {The handle of the memory mapped file}

  MappingObjectHandle: NativeUInt;

{$endif}

  {Has FastMM been installed?}

  FastMMIsInstalled: Boolean;

  {Is the MM in place a shared memory manager?}

  IsMemoryManagerOwner: Boolean;

  {Must MMX be used for move operations?}

{$ifdef EnableMMX}

  {$ifndef ForceMMX}

  UseMMX: Boolean;

  {$endif}

{$endif}

  {Is a MessageBox currently showing? If so, do not show another one.}

  ShowingMessageBox: Boolean;

  {True if RunInitializationCode has been called already.}

  InitializationCodeHasRun: Boolean = False;



{----------------Utility Functions------------------}



{A copy of StrLen in order to avoid the SysUtils unit, which would have

 introduced overhead like exception handling code.}

function StrLen(const AStr: PAnsiChar): NativeUInt;

{$ifndef Use32BitAsm}

begin

  Result := 0;

  while AStr[Result] <> #0 do

    Inc(Result);

end;

{$else}

asm

  {Check the first byte}

  cmp byte ptr [eax], 0

  je @ZeroLength

  {Get the negative of the string start in edx}

  mov edx, eax

  neg edx

  {Word align}

  add eax, 1

  and eax, -2

@ScanLoop:

  mov cx, [eax]

  add eax, 2

  test cl, ch

  jnz @ScanLoop

  test cl, cl

  jz @ReturnLess2

  test ch, ch

  jnz @ScanLoop

  lea eax, [eax + edx - 1]

  ret

@ReturnLess2:

  lea eax, [eax + edx - 2]

  ret

@ZeroLength:

  xor eax, eax

end;

{$endif}



{$ifdef EnableMMX}

{$ifndef ForceMMX}

{Returns true if the CPUID instruction is supported}

function CPUID_Supported: Boolean;

asm

  pushfd

  pop eax

  mov edx, eax

  xor eax, $200000

  push eax

  popfd

  pushfd

  pop eax

  xor eax, edx

  setnz al

end;



{Gets the CPUID}

function GetCPUID(AInfoRequired: Integer): TRegisters;

asm

  push ebx

  push esi

  mov esi, edx

  {cpuid instruction}

{$ifdef Delphi4or5}

  db $0f, $a2

{$else}

  cpuid

{$endif}

  {Save registers}

  mov TRegisters[esi].RegEAX, eax

  mov TRegisters[esi].RegEBX, ebx

  mov TRegisters[esi].RegECX, ecx

  mov TRegisters[esi].RegEDX, edx

  pop esi

  pop ebx

end;



{Returns true if the CPU supports MMX}

function MMX_Supported: Boolean;

var

  LReg: TRegisters;

begin

  if CPUID_Supported then

  begin

    {Get the CPUID}

    LReg := GetCPUID(1);

    {Bit 23 must be set for MMX support}

    Result := LReg.RegEDX and $800000 <> 0;

  end

  else

    Result := False;

end;

{$endif}

{$endif}



{Compare [AAddress], CompareVal:

 If Equal: [AAddress] := NewVal and result = CompareVal

 If Unequal: Result := [AAddress]}

function LockCmpxchg(CompareVal, NewVal: Byte; AAddress: PByte): Byte;

asm

{$ifdef 32Bit}

  {On entry:

    al = CompareVal,

    dl = NewVal,

    ecx = AAddress}

  {$ifndef LINUX}

  lock cmpxchg [ecx], dl

  {$else}

  {Workaround for Kylix compiler bug}

  db $F0, $0F, $B0, $11

  {$endif}

{$else}

  {On entry:

    cl = CompareVal

    dl = NewVal

    r8 = AAddress}

  .noframe

  mov rax, rcx

  lock cmpxchg [r8], dl

{$endif}

end;



{$ifndef ASMVersion}

{Gets the first set bit in the 32-bit number, returning the bit index}

function FindFirstSetBit(ACardinal: Cardinal): Cardinal;

asm

{$ifdef 64Bit}

  .noframe

  mov rax, rcx

{$endif}

  bsf eax, eax

end;

{$endif}



{$ifdef MACOS}



function StrLCopy(Dest: PAnsiChar; const Source: PAnsiChar; MaxLen: Cardinal): PAnsiChar;

var

  Len: Cardinal;

begin

  Result := Dest;

  Len := StrLen(Source);

  if Len > MaxLen then

    Len := MaxLen;

  Move(Source^, Dest^, Len * SizeOf(AnsiChar));

  Dest[Len] := #0;

end;



function GetModuleFileName(Module: HMODULE; Buffer: PAnsiChar; BufLen: Integer): Integer;

const

  CUnknown: AnsiString = 'unknown';

var

  tmp: array[0..512] of Char;

begin

  if FastMMIsInstalled then

  begin

    Result := System.GetModuleFileName(Module, tmp, BufLen);

    StrLCopy(Buffer, PAnsiChar(AnsiString(tmp)), BufLen);

  end

  else

  begin

    Result := Length(CUnknown);

    StrLCopy(Buffer, Pointer(CUnknown), Result + 1);

  end;

end;



const

  INVALID_HANDLE_VALUE = THandle(-1);



function FileCreate(const FileName: string): THandle;

begin

  Result := THandle(__open(PAnsiChar(UTF8String(FileName)), O_RDWR or O_CREAT or O_TRUNC or O_EXCL, FileAccessRights));

end;



{$endif}



{Writes the module filename to the specified buffer and returns the number of

 characters written.}

function AppendModuleFileName(ABuffer: PAnsiChar): Integer;

var

  LModuleHandle: HModule;

begin

  {Get the module handle}

{$ifndef borlndmmdll}

  if IsLibrary then

    LModuleHandle := HInstance

  else

{$endif}

    LModuleHandle := 0;

  {Get the module name}

{$ifndef POSIX}

  Result := GetModuleFileNameA(LModuleHandle, ABuffer, 512);

{$else}

  Result := GetModuleFileName(LModuleHandle, ABuffer, 512);

{$endif}

end;



{Copies the name of the module followed by the given string to the buffer,

 returning the pointer following the buffer.}

function AppendStringToModuleName(AString, ABuffer: PAnsiChar): PAnsiChar;

var

  LModuleNameLength: Cardinal;

  LCopyStart: PAnsiChar;

begin

  {Get the name of the application}

  LModuleNameLength := AppendModuleFileName(ABuffer);

  {Replace the last few characters}

  if LModuleNameLength > 0 then

  begin

    {Find the last backslash}

    LCopyStart := PAnsiChar(PByte(ABuffer) + LModuleNameLength - 1);

    LModuleNameLength := 0;

    while (UIntPtr(LCopyStart) >= UIntPtr(ABuffer))

      and (LCopyStart^ <> '\') do

    begin

      Inc(LModuleNameLength);

      Dec(LCopyStart);

    end;

    {Copy the name to the start of the buffer}

    Inc(LCopyStart);

    System.Move(LCopyStart^, ABuffer^, LModuleNameLength);

    Inc(ABuffer, LModuleNameLength);

    ABuffer^ := ':';

    Inc(ABuffer);

    ABuffer^ := ' ';

    Inc(ABuffer);

  end;

  {Append the string}

  while AString^ <> #0 do

  begin

    ABuffer^ := AString^;

    Inc(ABuffer);

    {Next char}

    Inc(AString);

  end;

  ABuffer^ := #0;

  Result := ABuffer;

end;



{----------------Faster Move Procedures-------------------}



{Fixed size move operations ignore the size parameter. All moves are assumed to

 be non-overlapping.}



procedure Move4(const ASource; var ADest; ACount: NativeInt);

asm

{$ifdef 32Bit}

  mov eax, [eax]

  mov [edx], eax

{$else}

.noframe

  mov eax, [rcx]

  mov [rdx], eax

{$endif}

end;



{$ifdef 64Bit}

procedure Move8(const ASource; var ADest; ACount: NativeInt);

asm

  mov rax, [rcx]

  mov [rdx], rax

end;

{$endif}



procedure Move12(const ASource; var ADest; ACount: NativeInt);

asm

{$ifdef 32Bit}

  mov ecx, [eax]

  mov [edx], ecx

  mov ecx, [eax + 4]

  mov eax, [eax + 8]

  mov [edx + 4], ecx

  mov [edx + 8], eax

{$else}

.noframe

  mov rax, [rcx]

  mov ecx, [rcx + 8]

  mov [rdx], rax

  mov [rdx + 8], ecx

{$endif}

end;



procedure Move20(const ASource; var ADest; ACount: NativeInt);

asm

{$ifdef 32Bit}

  mov ecx, [eax]

  mov [edx], ecx

  mov ecx, [eax + 4]

  mov [edx + 4], ecx

  mov ecx, [eax + 8]

  mov [edx + 8], ecx

  mov ecx, [eax + 12]

  mov eax, [eax + 16]

  mov [edx + 12], ecx

  mov [edx + 16], eax

{$else}

.noframe

  movdqa xmm0, [rcx]

  mov ecx, [rcx + 16]

  movdqa [rdx], xmm0

  mov [rdx + 16], ecx

{$endif}

end;



{$ifdef 64Bit}

procedure Move24(const ASource; var ADest; ACount: NativeInt);

asm

  movdqa xmm0, [rcx]

  mov r8, [rcx + 16]

  movdqa [rdx], xmm0

  mov [rdx + 16], r8

end;

{$endif}



procedure Move28(const ASource; var ADest; ACount: NativeInt);

asm

{$ifdef 32Bit}

  mov ecx, [eax]

  mov [edx], ecx

  mov ecx, [eax + 4]

  mov [edx + 4], ecx

  mov ecx, [eax + 8]

  mov [edx + 8], ecx

  mov ecx, [eax + 12]

  mov [edx + 12], ecx

  mov ecx, [eax + 16]

  mov [edx + 16], ecx

  mov ecx, [eax + 20]

  mov eax, [eax + 24]

  mov [edx + 20], ecx

  mov [edx + 24], eax

{$else}

.noframe

  movdqa xmm0, [rcx]

  mov r8, [rcx + 16]

  mov ecx, [rcx + 24]

  movdqa [rdx], xmm0

  mov [rdx + 16], r8

  mov [rdx + 24], ecx

{$endif}

end;



procedure Move36(const ASource; var ADest; ACount: NativeInt);

asm

{$ifdef 32Bit}

  fild qword ptr [eax]

  fild qword ptr [eax + 8]

  fild qword ptr [eax + 16]

  fild qword ptr [eax + 24]

  mov ecx, [eax + 32]

  mov [edx + 32], ecx

  fistp qword ptr [edx + 24]

  fistp qword ptr [edx + 16]

  fistp qword ptr [edx + 8]

  fistp qword ptr [edx]

{$else}

.noframe

  movdqa xmm0, [rcx]

  movdqa xmm1, [rcx + 16]

  mov ecx, [rcx + 32]

  movdqa [rdx], xmm0

  movdqa [rdx + 16], xmm1

  mov [rdx + 32], ecx

{$endif}

end;



{$ifdef 64Bit}

procedure Move40(const ASource; var ADest; ACount: NativeInt);

asm

  movdqa xmm0, [rcx]

  movdqa xmm1, [rcx + 16]

  mov r8, [rcx + 32]

  movdqa [rdx], xmm0

  movdqa [rdx + 16], xmm1

  mov [rdx + 32], r8

end;

{$endif}



procedure Move44(const ASource; var ADest; ACount: NativeInt);

asm

{$ifdef 32Bit}

  fild qword ptr [eax]

  fild qword ptr [eax + 8]

  fild qword ptr [eax + 16]

  fild qword ptr [eax + 24]

  fild qword ptr [eax + 32]

  mov ecx, [eax + 40]

  mov [edx + 40], ecx

  fistp qword ptr [edx + 32]

  fistp qword ptr [edx + 24]

  fistp qword ptr [edx + 16]

  fistp qword ptr [edx + 8]

  fistp qword ptr [edx]

{$else}

.noframe

  movdqa xmm0, [rcx]

  movdqa xmm1, [rcx + 16]

  mov r8, [rcx + 32]

  mov ecx, [rcx + 40]

  movdqa [rdx], xmm0

  movdqa [rdx + 16], xmm1

  mov [rdx + 32], r8

  mov [rdx + 40], ecx

{$endif}

end;



procedure Move52(const ASource; var ADest; ACount: NativeInt);

asm

{$ifdef 32Bit}

  fild qword ptr [eax]

  fild qword ptr [eax + 8]

  fild qword ptr [eax + 16]

  fild qword ptr [eax + 24]

  fild qword ptr [eax + 32]

  fild qword ptr [eax + 40]

  mov ecx, [eax + 48]

  mov [edx + 48], ecx

  fistp qword ptr [edx + 40]

  fistp qword ptr [edx + 32]

  fistp qword ptr [edx + 24]

  fistp qword ptr [edx + 16]

  fistp qword ptr [edx + 8]

  fistp qword ptr [edx]

{$else}

.noframe

  movdqa xmm0, [rcx]

  movdqa xmm1, [rcx + 16]

  movdqa xmm2, [rcx + 32]

  mov ecx, [rcx + 48]

  movdqa [rdx], xmm0

  movdqa [rdx + 16], xmm1

  movdqa [rdx + 32], xmm2

  mov [rdx + 48], ecx

{$endif}

end;



{$ifdef 64Bit}

procedure Move56(const ASource; var ADest; ACount: NativeInt);

asm

  movdqa xmm0, [rcx]

  movdqa xmm1, [rcx + 16]

  movdqa xmm2, [rcx + 32]

  mov r8, [rcx + 48]

  movdqa [rdx], xmm0

  movdqa [rdx + 16], xmm1

  movdqa [rdx + 32], xmm2

  mov [rdx + 48], r8

end;

{$endif}



procedure Move60(const ASource; var ADest; ACount: NativeInt);

asm

{$ifdef 32Bit}

  fild qword ptr [eax]

  fild qword ptr [eax + 8]

  fild qword ptr [eax + 16]

  fild qword ptr [eax + 24]

  fild qword ptr [eax + 32]

  fild qword ptr [eax + 40]

  fild qword ptr [eax + 48]

  mov ecx, [eax + 56]

  mov [edx + 56], ecx

  fistp qword ptr [edx + 48]

  fistp qword ptr [edx + 40]

  fistp qword ptr [edx + 32]

  fistp qword ptr [edx + 24]

  fistp qword ptr [edx + 16]

  fistp qword ptr [edx + 8]

  fistp qword ptr [edx]

{$else}

.noframe

  movdqa xmm0, [rcx]

  movdqa xmm1, [rcx + 16]

  movdqa xmm2, [rcx + 32]

  mov r8, [rcx + 48]

  mov ecx, [rcx + 56]

  movdqa [rdx], xmm0

  movdqa [rdx + 16], xmm1

  movdqa [rdx + 32], xmm2

  mov [rdx + 48], r8

  mov [rdx + 56], ecx

{$endif}

end;



procedure Move68(const ASource; var ADest; ACount: NativeInt);

asm

{$ifdef 32Bit}

  fild qword ptr [eax]

  fild qword ptr [eax + 8]

  fild qword ptr [eax + 16]

  fild qword ptr [eax + 24]

  fild qword ptr [eax + 32]

  fild qword ptr [eax + 40]

  fild qword ptr [eax + 48]

  fild qword ptr [eax + 56]

  mov ecx, [eax + 64]

  mov [edx + 64], ecx

  fistp qword ptr [edx + 56]

  fistp qword ptr [edx + 48]

  fistp qword ptr [edx + 40]

  fistp qword ptr [edx + 32]

  fistp qword ptr [edx + 24]

  fistp qword ptr [edx + 16]

  fistp qword ptr [edx + 8]

  fistp qword ptr [edx]

{$else}

.noframe

  movdqa xmm0, [rcx]

  movdqa xmm1, [rcx + 16]

  movdqa xmm2, [rcx + 32]

  movdqa xmm3, [rcx + 48]

  mov ecx, [rcx + 64]

  movdqa [rdx], xmm0

  movdqa [rdx + 16], xmm1

  movdqa [rdx + 32], xmm2

  movdqa [rdx + 48], xmm3

  mov [rdx + 64], ecx

{$endif}

end;



{Variable size move procedure: Rounds ACount up to the next multiple of 16 less

 SizeOf(Pointer). Important note: Always moves at least 16 - SizeOf(Pointer)

 bytes (the minimum small block size with 16 byte alignment), irrespective of

 ACount.}

procedure MoveX16LP(const ASource; var ADest; ACount: NativeInt);

asm

{$ifdef 32Bit}

  {Make the counter negative based: The last 12 bytes are moved separately}

  sub ecx, 12

  add eax, ecx

  add edx, ecx

{$ifdef EnableMMX}

  {$ifndef ForceMMX}

  cmp UseMMX, True

  jne @FPUMove

  {$endif}

  {Make the counter negative based: The last 12 bytes are moved separately}

  neg ecx

  jns @MMXMoveLast12

@MMXMoveLoop:

  {Move a 16 byte block}

  {$ifdef Delphi4or5}

  {Delphi 5 compatibility}

  db $0f, $6f, $04, $01

  db $0f, $6f, $4c, $01, $08

  db $0f, $7f, $04, $11

  db $0f, $7f, $4c, $11, $08

  {$else}

  movq mm0, [eax + ecx]

  movq mm1, [eax + ecx + 8]

  movq [edx + ecx], mm0

  movq [edx + ecx + 8], mm1

  {$endif}

  {Are there another 16 bytes to move?}

  add ecx, 16

  js @MMXMoveLoop

@MMXMoveLast12:

  {Do the last 12 bytes}

  {$ifdef Delphi4or5}

  {Delphi 5 compatibility}

  db $0f, $6f, $04, $01

  {$else}

  movq mm0, [eax + ecx]

  {$endif}

  mov eax, [eax + ecx + 8]

  {$ifdef Delphi4or5}

  {Delphi 5 compatibility}

  db $0f, $7f, $04, $11

  {$else}

  movq [edx + ecx], mm0

  {$endif}

  mov [edx + ecx + 8], eax

  {Exit MMX state}

  {$ifdef Delphi4or5}

  {Delphi 5 compatibility}

  db $0f, $77

  {$else}

  emms

  {$endif}

  {$ifndef ForceMMX}

  ret

  {$endif}

{$endif}

{FPU code is only used if MMX is not forced}

{$ifndef ForceMMX}

@FPUMove:

  neg ecx

  jns @FPUMoveLast12

@FPUMoveLoop:

  {Move a 16 byte block}

  fild qword ptr [eax + ecx]

  fild qword ptr [eax + ecx + 8]

  fistp qword ptr [edx + ecx + 8]

  fistp qword ptr [edx + ecx]

  {Are there another 16 bytes to move?}

  add ecx, 16

  js @FPUMoveLoop

@FPUMoveLast12:

  {Do the last 12 bytes}

  fild qword ptr [eax + ecx]

  fistp qword ptr [edx + ecx]

  mov eax, [eax + ecx + 8]

  mov [edx + ecx + 8], eax

{$endif}

{$else}

.noframe

  {Make the counter negative based: The last 8 bytes are moved separately}

  sub r8, 8

  add rcx, r8

  add rdx, r8

  neg r8

  jns @MoveLast12

@MoveLoop:

  {Move a 16 byte block}

  movdqa xmm0, [rcx + r8]

  movdqa [rdx + r8], xmm0

  {Are there another 16 bytes to move?}

  add r8, 16

  js @MoveLoop

@MoveLast12:

  {Do the last 8 bytes}

  mov r9, [rcx + r8]

  mov [rdx + r8], r9

{$endif}

end;



{Variable size move procedure: Rounds ACount up to the next multiple of 8 less

 SizeOf(Pointer). Important note: Always moves at least 8 - SizeOf(Pointer)

 bytes (the minimum small block size with 8 byte alignment), irrespective of

 ACount.}

procedure MoveX8LP(const ASource; var ADest; ACount: NativeInt);

asm

{$ifdef 32Bit}

  {Make the counter negative based: The last 4 bytes are moved separately}

  sub ecx, 4

  {4 bytes or less? -> Use the Move4 routine.}

  jle @FourBytesOrLess

  add eax, ecx

  add edx, ecx

  neg ecx

{$ifdef EnableMMX}

  {$ifndef ForceMMX}

  cmp UseMMX, True

  jne @FPUMoveLoop

  {$endif}

@MMXMoveLoop:

  {Move an 8 byte block}

{$ifdef Delphi4or5}

  {Delphi 5 compatibility}

  db $0f, $6f, $04, $01

  db $0f, $7f, $04, $11

{$else}

  movq mm0, [eax + ecx]

  movq [edx + ecx], mm0

{$endif}

  {Are there another 8 bytes to move?}

  add ecx, 8

  js @MMXMoveLoop

  {Exit MMX state}

{$ifdef Delphi4or5}

  {Delphi 5 compatibility}

  db $0f, $77

{$else}

  emms

{$endif}

  {Do the last 4 bytes}

  mov eax, [eax + ecx]

  mov [edx + ecx], eax

  ret

{$endif}

{FPU code is only used if MMX is not forced}

{$ifndef ForceMMX}

@FPUMoveLoop:

  {Move an 8 byte block}

  fild qword ptr [eax + ecx]

  fistp qword ptr [edx + ecx]

  {Are there another 8 bytes to move?}

  add ecx, 8

  js @FPUMoveLoop

  {Do the last 4 bytes}

  mov eax, [eax + ecx]

  mov [edx + ecx], eax

  ret

{$endif}

@FourBytesOrLess:

  {Four or less bytes to move}

  mov eax, [eax]

  mov [edx], eax

{$else}

.noframe

  {Make the counter negative based}

  add rcx, r8

  add rdx, r8

  neg r8

@MoveLoop:

  {Move an 8 byte block}

  mov r9, [rcx + r8]

  mov [rdx + r8], r9

  {Are there another 8 bytes to move?}

  add r8, 8

  js @MoveLoop

{$endif}

end;



{----------------Windows Emulation Functions for Kylix / OS X Support-----------------}



{$ifdef POSIX}



const

  {Messagebox constants}

  MB_OK = 0;

  MB_ICONERROR = $10;

  MB_TASKMODAL = $2000;

  MB_DEFAULT_DESKTOP_ONLY = $20000;

  {Virtual memory constants}

  MEM_COMMIT = $1000;

  MEM_RELEASE = $8000;

  MEM_TOP_DOWN = $100000;

  PAGE_READWRITE = 4;



procedure MessageBoxA(hWnd: Cardinal; AMessageText, AMessageTitle: PAnsiChar; uType: Cardinal); stdcall;

begin

  if FastMMIsInstalled then

    writeln(AMessageText)

  else

    __write(STDERR_FILENO, AMessageText, StrLen(AMessageText));

end;



function VirtualAlloc(lpvAddress: Pointer; dwSize, flAllocationType, flProtect: Cardinal): Pointer; stdcall;

begin

  Result := valloc(dwSize);

end;



function VirtualFree(lpAddress: Pointer; dwSize, dwFreeType: Cardinal): LongBool; stdcall;

begin

  free(lpAddress);

  Result := True;

end;



function WriteFile(hFile: THandle; const Buffer; nNumberOfBytesToWrite: Cardinal;

  var lpNumberOfBytesWritten: Cardinal; lpOverlapped: Pointer): Boolean; stdcall;

begin

  lpNumberOfBytesWritten := __write(hFile, @Buffer, nNumberOfBytesToWrite);

  if lpNumberOfBytesWritten = Cardinal(-1) then

  begin

    lpNumberOfBytesWritten := 0;

    Result := False;

  end

  else

    Result := True;

end;



{$ifndef NeverSleepOnThreadContention}

procedure Sleep(dwMilliseconds: Cardinal); stdcall;

begin

  {Convert to microseconds (more or less)}

  usleep(dwMilliseconds shl 10);

end;

{$endif}

{$endif}



{-----------------Debugging Support Functions and Procedures------------------}



{$ifdef FullDebugMode}



{Returns the current thread ID}

function GetThreadID: Cardinal;

{$ifdef 32Bit}

asm

  mov eax, FS:[$24]

end;

{$else}

begin

  Result := GetCurrentThreadId;

end;

{$endif}



{Fills a block of memory with the given dword (32-bit) or qword (64-bit).

 Always fills a multiple of SizeOf(Pointer) bytes}

procedure DebugFillMem(var AAddress; AByteCount: NativeInt; AFillValue: NativeUInt);

asm

{$ifdef 32Bit}

  {On Entry:

   eax = AAddress

   edx = AByteCount

   ecx = AFillValue}

  add eax, edx

  neg edx

  jns @Done

@FillLoop:

  mov [eax + edx], ecx

  add edx, 4

  js @FillLoop

@Done:

{$else}

  {On Entry:

   rcx = AAddress

   rdx = AByteCount

   r8 = AFillValue}

  add rcx, rdx

  neg rdx

  jns @Done

@FillLoop:

  mov [rcx + rdx], r8

  add rdx, 8

  js @FillLoop

@Done:

{$endif}

end;



  {$ifndef LoadDebugDLLDynamically}



{The stack trace procedure. The stack trace module is external since it may

 raise handled access violations that result in the creation of exception

 objects and the stack trace code is not re-entrant.}

procedure GetStackTrace(AReturnAddresses: PNativeUInt;

  AMaxDepth, ASkipFrames: Cardinal); external FullDebugModeLibraryName

  name {$ifdef RawStackTraces}'GetRawStackTrace'{$else}'GetFrameBasedStackTrace'{$endif};



{The exported procedure in the FastMM_FullDebugMode.dll library used to convert

 the return addresses of a stack trace to a text string.}

function LogStackTrace(AReturnAddresses: PNativeUInt;

  AMaxDepth: Cardinal; ABuffer: PAnsiChar): PAnsiChar; external FullDebugModeLibraryName

  name 'LogStackTrace';



  {$else}



  {Default no-op stack trace and logging handlers}

  procedure NoOpGetStackTrace(AReturnAddresses: PNativeUInt;

    AMaxDepth, ASkipFrames: Cardinal);

  begin

    DebugFillMem(AReturnAddresses^, AMaxDepth * SizeOf(Pointer), 0);

  end;



  function NoOpLogStackTrace(AReturnAddresses: PNativeUInt;

    AMaxDepth: Cardinal; ABuffer: PAnsiChar): PAnsiChar;

  begin

    Result := ABuffer;

  end;



var



  {Handle to the FullDebugMode DLL}

  FullDebugModeDLL: HMODULE;



  GetStackTrace: procedure (AReturnAddresses: PNativeUInt;

    AMaxDepth, ASkipFrames: Cardinal) = NoOpGetStackTrace;



  LogStackTrace: function (AReturnAddresses: PNativeUInt;

    AMaxDepth: Cardinal; ABuffer: PAnsiChar): PAnsiChar = NoOpLogStackTrace;



  {$endif}



{$endif}



{$ifndef POSIX}

function DelphiIsRunning: Boolean;

begin

  Result := FindWindowA('TAppBuilder', nil) <> 0;

end;

{$endif}



{Converts an unsigned integer to string at the buffer location, returning the

 new buffer position. Note: The 32-bit asm version only supports numbers up to

 2^31 - 1.}

function NativeUIntToStrBuf(ANum: NativeUInt; APBuffer: PAnsiChar): PAnsiChar;

{$ifndef Use32BitAsm}

const

  MaxDigits = 20;

var

  LDigitBuffer: array[0..MaxDigits - 1] of AnsiChar;

  LCount: Cardinal;

  LDigit: NativeUInt;

begin

  {Generate the digits in the local buffer}

  LCount := 0;

  repeat

    LDigit := ANum;

    ANum := ANum div 10;

    LDigit := LDigit - ANum * 10;

    Inc(LCount);

    LDigitBuffer[MaxDigits - LCount] := AnsiChar(Ord('0') + LDigit);

  until ANum = 0;

  {Copy the digits to the output buffer and advance it}

  System.Move(LDigitBuffer[MaxDigits - LCount], APBuffer^, LCount);

  Result := APBuffer + LCount;

end;

{$else}

asm

  {On entry: eax = ANum, edx = ABuffer}

  push edi

  mov edi, edx                //Pointer to the first character in edi

  {Calculate leading digit: divide the number by 1e9}

  add eax, 1                  //Increment the number

  mov edx, $89705F41          //1e9 reciprocal

  mul edx                     //Multplying with reciprocal

  shr eax, 30                 //Save fraction bits

  mov ecx, edx                //First digit in bits <31:29>

  and edx, $1FFFFFFF          //Filter fraction part edx<28:0>

  shr ecx, 29                 //Get leading digit into accumulator

  lea edx, [edx + 4 * edx]    //Calculate ...

  add edx, eax                //... 5*fraction

  mov eax, ecx                //Copy leading digit

  or eax, '0'                 //Convert digit to ASCII

  mov [edi], al               //Store digit out to memory

  {Calculate digit #2}

  mov eax, edx                //Point format such that 1.0 = 2^28

  cmp ecx, 1                  //Any non-zero digit yet ?

  sbb edi, -1                 //Yes->increment ptr, No->keep old ptr

  shr eax, 28                 //Next digit

  and edx, $0fffffff          //Fraction part edx<27:0>

  or ecx, eax                 //Accumulate next digit

  or eax, '0'                 //Convert digit to ASCII

  mov [edi], al               //Store digit out to memory

  {Calculate digit #3}

  lea eax, [edx * 4 + edx]    //5*fraction, new digit eax<31:27>

  lea edx, [edx * 4 + edx]    //5*fraction, new fraction edx<26:0>

  cmp ecx, 1                  //Any non-zero digit yet ?

  sbb edi, -1                 //Yes->increment ptr, No->keep old ptr

  shr eax, 27                 //Next digit

  and edx, $07ffffff          //Fraction part

  or ecx, eax                 //Accumulate next digit

  or eax, '0'                 //Convert digit to ASCII

  mov [edi], al               //Store digit out to memory

  {Calculate digit #4}

  lea eax, [edx * 4 + edx]    //5*fraction, new digit eax<31:26>

  lea edx, [edx * 4 + edx]    //5*fraction, new fraction edx<25:0>

  cmp ecx, 1                  //Any non-zero digit yet ?

  sbb edi, -1                 //Yes->increment ptr, No->keep old ptr

  shr eax, 26                 //Next digit

  and edx, $03ffffff          //Fraction part

  or ecx, eax                 //Accumulate next digit

  or eax, '0'                 //Convert digit to ASCII

  mov [edi], al               //Store digit out to memory

  {Calculate digit #5}

  lea eax, [edx * 4 + edx]    //5*fraction, new digit eax<31:25>

  lea edx, [edx * 4 + edx]    //5*fraction, new fraction edx<24:0>

  cmp ecx, 1                  //Any non-zero digit yet ?

  sbb edi, -1                 //Yes->increment ptr, No->keep old ptr

  shr eax, 25                 //Next digit

  and edx, $01ffffff          //Fraction part

  or ecx, eax                 //Accumulate next digit

  or eax, '0'                 //Convert digit to ASCII

  mov [edi], al               //Store digit out to memory

  {Calculate digit #6}

  lea eax, [edx * 4 + edx]    //5*fraction, new digit eax<31:24>

  lea edx, [edx * 4 + edx]    //5*fraction, new fraction edx<23:0>

  cmp ecx, 1                  //Any non-zero digit yet ?

  sbb edi, -1                 //Yes->increment ptr, No->keep old ptr

  shr eax, 24                 //Next digit

  and edx, $00ffffff          //Fraction part

  or ecx, eax                 //Accumulate next digit

  or eax, '0'                 //Convert digit to ASCII

  mov [edi], al               //Store digit out to memory

  {Calculate digit #7}

  lea eax, [edx * 4 + edx]    //5*fraction, new digit eax<31:23>

  lea edx, [edx * 4 + edx]    //5*fraction, new fraction edx<31:23>

  cmp ecx, 1                  //Any non-zero digit yet ?

  sbb edi, -1                 //Yes->increment ptr, No->keep old ptr

  shr eax, 23                 //Next digit

  and edx, $007fffff          //Fraction part

  or ecx, eax                 //Accumulate next digit

  or eax, '0'                 //Convert digit to ASCII

  mov [edi], al               //Store digit out to memory

  {Calculate digit #8}

  lea eax, [edx * 4 + edx]    //5*fraction, new digit eax<31:22>

  lea edx, [edx * 4 + edx]    //5*fraction, new fraction edx<22:0>

  cmp ecx, 1                  //Any non-zero digit yet ?

  sbb edi, -1                 //Yes->increment ptr, No->keep old ptr

  shr eax, 22                 //Next digit

  and edx, $003fffff          //Fraction part

  or ecx, eax                 //Accumulate next digit

  or eax, '0'                 //Convert digit to ASCII

  mov [edi], al               //Store digit out to memory

  {Calculate digit #9}

  lea eax, [edx * 4 + edx]    //5*fraction, new digit eax<31:21>

  lea edx, [edx * 4 + edx]    //5*fraction, new fraction edx<21:0>

  cmp ecx, 1                  //Any non-zero digit yet ?

  sbb edi, -1                 //Yes->increment ptr, No->keep old ptr

  shr eax, 21                 //Next digit

  and edx, $001fffff          //Fraction part

  or ecx, eax                 //Accumulate next digit

  or eax, '0'                 //Convert digit to ASCII

  mov [edi], al               //Store digit out to memory

  {Calculate digit #10}

  lea eax, [edx * 4 + edx]    //5*fraction, new digit eax<31:20>

  cmp ecx, 1                  //Any-non-zero digit yet ?

  sbb edi, -1                 //Yes->increment ptr, No->keep old ptr

  shr eax, 20                 //Next digit

  or eax, '0'                 //Convert digit to ASCII

  mov [edi], al               //Store last digit and end marker out to memory

  {Return a pointer to the next character}

  lea eax, [edi + 1]

  {Restore edi}

  pop edi

end;

{$endif}



{Converts an unsigned integer to a hexadecimal string at the buffer location,

 returning the new buffer position.}

function NativeUIntToHexBuf(ANum: NativeUInt; APBuffer: PAnsiChar): PAnsiChar;

{$ifndef Use32BitAsm}

const

  MaxDigits = 16;

var

  LDigitBuffer: array[0..MaxDigits - 1] of AnsiChar;

  LCount: Cardinal;

  LDigit: NativeUInt;

begin

  {Generate the digits in the local buffer}

  LCount := 0;

  repeat

    LDigit := ANum;

    ANum := ANum div 16;

    LDigit := LDigit - ANum * 16;

    Inc(LCount);

    LDigitBuffer[MaxDigits - LCount] := HexTable[LDigit];

  until ANum = 0;

  {Copy the digits to the output buffer and advance it}

  System.Move(LDigitBuffer[MaxDigits - LCount], APBuffer^, LCount);

  Result := APBuffer + LCount;

end;

{$else}

asm

  {On entry:

    eax = ANum

    edx = ABuffer}

  push ebx

  push edi

  {Save ANum in ebx}

  mov ebx, eax

  {Get a pointer to the first character in edi}

  mov edi, edx

  {Get the number in ecx as well}

  mov ecx, eax

  {Keep the low nibbles in ebx and the high nibbles in ecx}

  and ebx, $0f0f0f0f

  and ecx, $f0f0f0f0

  {Swap the bytes into the right order}

  ror ebx, 16

  ror ecx, 20

  {Get nibble 7}

  movzx eax, ch

  mov dl, ch

  mov al, byte ptr HexTable[eax]

  mov [edi], al

  cmp dl, 1

  sbb edi, -1

  {Get nibble 6}

  movzx eax, bh

  or dl, bh

  mov al, byte ptr HexTable[eax]

  mov [edi], al

  cmp dl, 1

  sbb edi, -1

  {Get nibble 5}

  movzx eax, cl

  or dl, cl

  mov al, byte ptr HexTable[eax]

  mov [edi], al

  cmp dl, 1

  sbb edi, -1

  {Get nibble 4}

  movzx eax, bl

  or dl, bl

  mov al, byte ptr HexTable[eax]

  mov [edi], al

  cmp dl, 1

  sbb edi, -1

  {Rotate ecx and ebx so we get access to the rest}

  shr ebx, 16

  shr ecx, 16

  {Get nibble 3}

  movzx eax, ch

  or dl, ch

  mov al, byte ptr HexTable[eax]

  mov [edi], al

  cmp dl, 1

  sbb edi, -1

  {Get nibble 2}

  movzx eax, bh

  or dl, bh

  mov al, byte ptr HexTable[eax]

  mov [edi], al

  cmp dl, 1

  sbb edi, -1

  {Get nibble 1}

  movzx eax, cl

  or dl, cl

  mov al, byte ptr HexTable[eax]

  mov [edi], al

  cmp dl, 1

  sbb edi, -1

  {Get nibble 0}

  movzx eax, bl

  mov al, byte ptr HexTable[eax]

  mov [edi], al

  {Return a pointer to the end of the string}

  lea eax, [edi + 1]

  {Restore registers}

  pop edi

  pop ebx

end;

{$endif}



{Appends the source text to the destination and returns the new destination

 position}

function AppendStringToBuffer(const ASource, ADestination: PAnsiChar; ACount: Cardinal): PAnsiChar;

begin

  System.Move(ASource^, ADestination^, ACount);

  Result := Pointer(PByte(ADestination) + ACount);

end;



{Appends the name of the class to the destination buffer and returns the new

 destination position}

function AppendClassNameToBuffer(AClass: TClass; ADestination: PAnsiChar): PAnsiChar;

var

  LPClassName: PShortString;

begin

  {Get a pointer to the class name}

  if AClass <> nil then

  begin

    LPClassName := PShortString(PPointer(PByte(AClass) + vmtClassName)^);

    {Append the class name}

    Result := AppendStringToBuffer(@LPClassName^[1], ADestination, Length(LPClassName^));

  end

  else

  begin

    Result := AppendStringToBuffer(UnknownClassNameMsg, ADestination, Length(UnknownClassNameMsg));

  end;

end;



{Shows a message box if the program is not showing one already.}

procedure ShowMessageBox(AText, ACaption: PAnsiChar);

begin

  if (not ShowingMessageBox) and (not SuppressMessageBoxes) then

  begin

    ShowingMessageBox := True;

    MessageBoxA(0, AText, ACaption,

      MB_OK or MB_ICONERROR or MB_TASKMODAL or MB_DEFAULT_DESKTOP_ONLY);

    ShowingMessageBox := False;

  end;

end;



{Returns the class for a memory block. Returns nil if it is not a valid class}

function DetectClassInstance(APointer: Pointer): TClass;

{$ifndef POSIX}

var

  LMemInfo: TMemoryBasicInformation;



  {Checks whether the given address is a valid address for a VMT entry.}

  function IsValidVMTAddress(APAddress: Pointer): Boolean;

  begin

    {Do some basic pointer checks: Must be dword aligned and beyond 64K}

    if (UIntPtr(APAddress) > 65535)

      and (UIntPtr(APAddress) and 3 = 0) then

    begin

      {Do we need to recheck the virtual memory?}

      if (UIntPtr(LMemInfo.BaseAddress) > UIntPtr(APAddress))

        or ((UIntPtr(LMemInfo.BaseAddress) + LMemInfo.RegionSize) < (UIntPtr(APAddress) + 4)) then

      begin

        {Get the VM status for the pointer}

        LMemInfo.RegionSize := 0;

        VirtualQuery(APAddress,  LMemInfo, SizeOf(LMemInfo));

      end;

      {Check the readability of the memory address}

      Result := (LMemInfo.RegionSize >= 4)

        and (LMemInfo.State = MEM_COMMIT)

        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)

        and (LMemInfo.Protect and PAGE_GUARD = 0);

    end

    else

      Result := False;

  end;



  {Returns true if AClassPointer points to a class VMT}

  function InternalIsValidClass(AClassPointer: Pointer; ADepth: Integer = 0): Boolean;

  var

    LParentClassSelfPointer: PPointer;

  begin

    {Check that the self pointer as well as parent class self pointer addresses

     are valid}

    if (ADepth < 1000)

      and IsValidVMTAddress(Pointer(PByte(AClassPointer) + vmtSelfPtr))

      and IsValidVMTAddress(Pointer(PByte(AClassPointer) + vmtParent)) then

    begin

      {Get a pointer to the parent class' self pointer}

      LParentClassSelfPointer := PPointer(PByte(AClassPointer) + vmtParent)^;

      {Check that the self pointer as well as the parent class is valid}

      Result := (PPointer(PByte(AClassPointer) + vmtSelfPtr)^ = AClassPointer)

        and ((LParentClassSelfPointer = nil)

          or (IsValidVMTAddress(LParentClassSelfPointer)

            and InternalIsValidClass(LParentClassSelfPointer^, ADepth + 1)));

    end

    else

      Result := False;

  end;



begin

  {Get the class pointer from the (suspected) object}

  Result := TClass(PPointer(APointer)^);

  {No VM info yet}

  LMemInfo.RegionSize := 0;

  {Check the block}

  if (not InternalIsValidClass(Pointer(Result), 0))

{$ifdef FullDebugMode}

    or (Result = @FreedObjectVMT.VMTMethods[0])

{$endif}

  then

    Result := nil;

end;

{$else}

begin

  {Not currently supported under Linux / OS X}

  Result := nil;

end;

{$endif}



{Gets the available size inside a block}

function GetAvailableSpaceInBlock(APointer: Pointer): NativeUInt;

var

  LBlockHeader: NativeUInt;

  LPSmallBlockPool: PSmallBlockPoolHeader;

begin

  LBlockHeader := PNativeUInt(PByte(APointer) - BlockHeaderSize)^;

  if LBlockHeader and (IsMediumBlockFlag or IsLargeBlockFlag) = 0 then

  begin

    LPSmallBlockPool := PSmallBlockPoolHeader(LBlockHeader and DropSmallFlagsMask);

    Result := LPSmallBlockPool.BlockType.BlockSize - BlockHeaderSize;

  end

  else

  begin

    Result := (LBlockHeader and DropMediumAndLargeFlagsMask) - BlockHeaderSize;

    if (LBlockHeader and IsMediumBlockFlag) = 0 then

      Dec(Result, LargeBlockHeaderSize);

  end;

end;



{-----------------Small Block Management------------------}



{Locks all small block types}

procedure LockAllSmallBlockTypes;

var

  LInd: Cardinal;

begin

  {Lock the medium blocks}

{$ifndef AssumeMultiThreaded}

  if IsMultiThread then

{$endif}

  begin

    for LInd := 0 to NumSmallBlockTypes - 1 do

    begin

      while LockCmpxchg(0, 1, @SmallBlockTypes[LInd].BlockTypeLocked) <> 0 do

      begin

{$ifdef NeverSleepOnThreadContention}

  {$ifdef UseSwitchToThread}

        SwitchToThread;

  {$endif}

{$else}

        Sleep(InitialSleepTime);

        if LockCmpxchg(0, 1, @SmallBlockTypes[LInd].BlockTypeLocked) = 0 then

          Break;

        Sleep(AdditionalSleepTime);

{$endif}

      end;

    end;

  end;

end;



{Gets the first and last block pointer for a small block pool}

procedure GetFirstAndLastSmallBlockInPool(APSmallBlockPool: PSmallBlockPoolHeader;

  var AFirstPtr, ALastPtr: Pointer);

var

  LBlockSize: NativeUInt;

begin

  {Get the pointer to the first block}

  AFirstPtr := Pointer(PByte(APSmallBlockPool) + SmallBlockPoolHeaderSize);

  {Get a pointer to the last block}

  if (APSmallBlockPool.BlockType.CurrentSequentialFeedPool <> APSmallBlockPool)

    or (UIntPtr(APSmallBlockPool.BlockType.NextSequentialFeedBlockAddress) > UIntPtr(APSmallBlockPool.BlockType.MaxSequentialFeedBlockAddress)) then

  begin

    {Not the sequential feed - point to the end of the block}

    LBlockSize := PNativeUInt(PByte(APSmallBlockPool) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask;

    ALastPtr := Pointer(PByte(APSmallBlockPool) + LBlockSize - APSmallBlockPool.BlockType.BlockSize);

  end

  else

  begin

    {The sequential feed pool - point to before the next sequential feed block}

    ALastPtr := Pointer(PByte(APSmallBlockPool.BlockType.NextSequentialFeedBlockAddress) - 1);

  end;

end;



{-----------------Medium Block Management------------------}



{Advances to the next medium block. Returns nil if the end of the medium block

 pool has been reached}

function NextMediumBlock(APMediumBlock: Pointer): Pointer;

var

  LBlockSize: NativeUInt;

begin

  {Get the size of this block}

  LBlockSize := PNativeUInt(PByte(APMediumBlock) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask;

  {Advance the pointer}

  Result := Pointer(PByte(APMediumBlock) + LBlockSize);

  {Is the next block the end of medium pool marker?}

  LBlockSize := PNativeUInt(PByte(Result) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask;

  if LBlockSize = 0 then

    Result := nil;

end;



{Gets the first medium block in the medium block pool}

function GetFirstMediumBlockInPool(APMediumBlockPoolHeader: PMediumBlockPoolHeader): Pointer;

begin

  if (MediumSequentialFeedBytesLeft = 0)

    or (UIntPtr(LastSequentiallyFedMediumBlock) < UIntPtr(APMediumBlockPoolHeader))

    or (UIntPtr(LastSequentiallyFedMediumBlock) > UIntPtr(APMediumBlockPoolHeader) + MediumBlockPoolSize) then

  begin

    Result := Pointer(PByte(APMediumBlockPoolHeader) + MediumBlockPoolHeaderSize);

  end

  else

  begin

    {Is the sequential feed pool empty?}

    if MediumSequentialFeedBytesLeft <> MediumBlockPoolSize - MediumBlockPoolHeaderSize then

      Result := LastSequentiallyFedMediumBlock

    else

      Result := nil;

  end;

end;



{Locks the medium blocks. Note that the 32-bit asm version is assumed to

 preserve all registers except eax.}

{$ifndef Use32BitAsm}

procedure LockMediumBlocks;

begin

  {Lock the medium blocks}

{$ifndef AssumeMultiThreaded}

  if IsMultiThread then

{$endif}

  begin

    while LockCmpxchg(0, 1, @MediumBlocksLocked) <> 0 do

    begin

{$ifdef NeverSleepOnThreadContention}

  {$ifdef UseSwitchToThread}

      SwitchToThread;

  {$endif}

{$else}

      Sleep(InitialSleepTime);

      if LockCmpxchg(0, 1, @MediumBlocksLocked) = 0 then

        Break;

      Sleep(AdditionalSleepTime);

{$endif}

    end;

  end;

end;

{$else}

procedure LockMediumBlocks;

asm

  {Note: This routine is assumed to preserve all registers except eax}

@MediumBlockLockLoop:

  mov eax, $100

  {Attempt to lock the medium blocks}

  lock cmpxchg MediumBlocksLocked, ah

  je @Done

{$ifdef NeverSleepOnThreadContention}

  {Pause instruction (improves performance on P4)}

  rep nop

  {$ifdef UseSwitchToThread}

  push ecx

  push edx

  call SwitchToThread

  pop edx

  pop ecx

  {$endif}

  {Try again}

  jmp @MediumBlockLockLoop

{$else}

  {Couldn't lock the medium blocks - sleep and try again}

  push ecx

  push edx

  push InitialSleepTime

  call Sleep

  pop edx

  pop ecx

  {Try again}

  mov eax, $100

  {Attempt to grab the block type}

  lock cmpxchg MediumBlocksLocked, ah

  je @Done

  {Couldn't lock the medium blocks - sleep and try again}

  push ecx

  push edx

  push AdditionalSleepTime

  call Sleep

  pop edx

  pop ecx

  {Try again}

  jmp @MediumBlockLockLoop

{$endif}

@Done:

end;

{$endif}



{Removes a medium block from the circular linked list of free blocks.

 Does not change any header flags. Medium blocks should be locked

 before calling this procedure.}

procedure RemoveMediumFreeBlock(APMediumFreeBlock: PMediumFreeBlock);

{$ifndef ASMVersion}

var

  LPreviousFreeBlock, LNextFreeBlock: PMediumFreeBlock;

  LBinNumber, LBinGroupNumber: Cardinal;

begin

  {Get the current previous and next blocks}

  LNextFreeBlock := APMediumFreeBlock.NextFreeBlock;

  LPreviousFreeBlock := APMediumFreeBlock.PreviousFreeBlock;

  {Remove this block from the linked list}

  LPreviousFreeBlock.NextFreeBlock := LNextFreeBlock;

  LNextFreeBlock.PreviousFreeBlock := LPreviousFreeBlock;

  {Is this bin now empty? If the previous and next free block pointers are

   equal, they must point to the bin.}

  if LPreviousFreeBlock = LNextFreeBlock then

  begin

    {Get the bin number for this block size}

    LBinNumber := (UIntPtr(LNextFreeBlock) - UIntPtr(@MediumBlockBins)) div SizeOf(TMediumFreeBlock);

    LBinGroupNumber := LBinNumber div 32;

    {Flag this bin as empty}

    MediumBlockBinBitmaps[LBinGroupNumber] := MediumBlockBinBitmaps[LBinGroupNumber]

      and (not (1 shl (LBinNumber and 31)));

    {Is the group now entirely empty?}

    if MediumBlockBinBitmaps[LBinGroupNumber] = 0 then

    begin

      {Flag this group as empty}

      MediumBlockBinGroupBitmap := MediumBlockBinGroupBitmap

        and (not (1 shl LBinGroupNumber));

    end;

  end;

end;

{$else}

{$ifdef 32Bit}

asm

  {On entry: eax = APMediumFreeBlock}

  {Get the current previous and next blocks}

  mov ecx, TMediumFreeBlock[eax].NextFreeBlock

  mov edx, TMediumFreeBlock[eax].PreviousFreeBlock

  {Is this bin now empty? If the previous and next free block pointers are

   equal, they must point to the bin.}

  cmp ecx, edx

  {Remove this block from the linked list}

  mov TMediumFreeBlock[ecx].PreviousFreeBlock, edx

  mov TMediumFreeBlock[edx].NextFreeBlock, ecx

  {Is this bin now empty? If the previous and next free block pointers are

   equal, they must point to the bin.}

  je @BinIsNowEmpty

@Done:

  ret

  {Align branch target}

  nop

@BinIsNowEmpty:

  {Get the bin number for this block size in ecx}

  sub ecx, offset MediumBlockBins

  mov edx, ecx

  shr ecx, 3

  {Get the group number in edx}

  movzx edx, dh

  {Flag this bin as empty}

  mov eax, -2

  rol eax, cl

  and dword ptr [MediumBlockBinBitmaps + edx * 4], eax

  jnz @Done

  {Flag this group as empty}

  mov eax, -2

  mov ecx, edx

  rol eax, cl

  and MediumBlockBinGroupBitmap, eax

end;

{$else}

asm

  {On entry: rcx = APMediumFreeBlock}

  mov rax, rcx

  {Get the current previous and next blocks}

  mov rcx, TMediumFreeBlock[rax].NextFreeBlock

  mov rdx, TMediumFreeBlock[rax].PreviousFreeBlock

  {Is this bin now empty? If the previous and next free block pointers are

   equal, they must point to the bin.}

  cmp rcx, rdx

  {Remove this block from the linked list}

  mov TMediumFreeBlock[rcx].PreviousFreeBlock, rdx

  mov TMediumFreeBlock[rdx].NextFreeBlock, rcx

  {Is this bin now empty? If the previous and next free block pointers are

   equal, they must point to the bin.}

  jne @Done

  {Get the bin number for this block size in rcx}

  lea r8, MediumBlockBins

  sub rcx, r8

  mov edx, ecx

  shr ecx, 4

  {Get the group number in edx}

  shr edx, 9

  {Flag this bin as empty}

  mov eax, -2

  rol eax, cl

  lea r8, MediumBlockBinBitmaps

  and dword ptr [r8 + rdx * 4], eax

  jnz @Done

  {Flag this group as empty}

  mov eax, -2

  mov ecx, edx

  rol eax, cl

  and MediumBlockBinGroupBitmap, eax

@Done:

end;

{$endif}

{$endif}



{Inserts a medium block into the appropriate medium block bin.}

procedure InsertMediumBlockIntoBin(APMediumFreeBlock: PMediumFreeBlock; AMediumBlockSize: Cardinal);

{$ifndef ASMVersion}

var

  LBinNumber, LBinGroupNumber: Cardinal;

  LPBin, LPFirstFreeBlock: PMediumFreeBlock;

begin

  {Get the bin number for this block size. Get the bin that holds blocks of at

   least this size.}

  LBinNumber := (AMediumBlockSize - MinimumMediumBlockSize) div MediumBlockGranularity;

  if LBinNumber >= MediumBlockBinCount then

    LBinNumber := MediumBlockBinCount - 1;

  {Get the bin}

  LPBin := @MediumBlockBins[LBinNumber];

  {Bins are LIFO, se we insert this block as the first free block in the bin}

  LPFirstFreeBlock := LPBin.NextFreeBlock;

  APMediumFreeBlock.PreviousFreeBlock := LPBin;

  APMediumFreeBlock.NextFreeBlock := LPFirstFreeBlock;

  LPFirstFreeBlock.PreviousFreeBlock := APMediumFreeBlock;

  LPBin.NextFreeBlock := APMediumFreeBlock;

  {Was this bin empty?}

  if LPFirstFreeBlock = LPBin then

  begin

    {Get the group number}

    LBinGroupNumber := LBinNumber div 32;

    {Flag this bin as used}

    MediumBlockBinBitmaps[LBinGroupNumber] := MediumBlockBinBitmaps[LBinGroupNumber]

      or (1 shl (LBinNumber and 31));

    {Flag the group as used}

    MediumBlockBinGroupBitmap := MediumBlockBinGroupBitmap

      or (1 shl LBinGroupNumber);

  end;

end;

{$else}

{$ifdef 32Bit}

asm

  {On entry: eax = APMediumFreeBlock, edx = AMediumBlockSize}

  {Get the bin number for this block size. Get the bin that holds blocks of at

   least this size.}

  sub edx, MinimumMediumBlockSize

  shr edx, 8

  {Validate the bin number}

  sub edx, MediumBlockBinCount - 1

  sbb ecx, ecx

  and edx, ecx

  add edx, MediumBlockBinCount - 1

  {Get the bin in ecx}

  lea ecx, [MediumBlockBins + edx * 8]

  {Bins are LIFO, se we insert this block as the first free block in the bin}

  mov edx, TMediumFreeBlock[ecx].NextFreeBlock

  {Was this bin empty?}

  cmp edx, ecx

  mov TMediumFreeBlock[eax].PreviousFreeBlock, ecx

  mov TMediumFreeBlock[eax].NextFreeBlock, edx

  mov TMediumFreeBlock[edx].PreviousFreeBlock, eax

  mov TMediumFreeBlock[ecx].NextFreeBlock, eax

  {Was this bin empty?}

  je @BinWasEmpty

  ret

  {Align branch target}

  nop

  nop

@BinWasEmpty:

  {Get the bin number in ecx}

  sub ecx, offset MediumBlockBins

  mov edx, ecx

  shr ecx, 3

  {Get the group number in edx}

  movzx edx, dh

  {Flag this bin as not empty}

  mov eax, 1

  shl eax, cl

  or dword ptr [MediumBlockBinBitmaps + edx * 4], eax

  {Flag the group as not empty}

  mov eax, 1

  mov ecx, edx

  shl eax, cl

  or MediumBlockBinGroupBitmap, eax

end;

{$else}

asm

  {On entry: rax = APMediumFreeBlock, edx = AMediumBlockSize}

  mov rax, rcx

  {Get the bin number for this block size. Get the bin that holds blocks of at

   least this size.}

  sub edx, MinimumMediumBlockSize

  shr edx, 8

  {Validate the bin number}

  sub edx, MediumBlockBinCount - 1

  sbb ecx, ecx

  and edx, ecx

  add edx, MediumBlockBinCount - 1

  mov r9, rdx

  {Get the bin address in rcx}

  lea rcx, MediumBlockBins

  shl edx, 4

  add rcx, rdx

  {Bins are LIFO, se we insert this block as the first free block in the bin}

  mov rdx, TMediumFreeBlock[rcx].NextFreeBlock

  {Was this bin empty?}

  cmp rdx, rcx

  mov TMediumFreeBlock[rax].PreviousFreeBlock, rcx

  mov TMediumFreeBlock[rax].NextFreeBlock, rdx

  mov TMediumFreeBlock[rdx].PreviousFreeBlock, rax

  mov TMediumFreeBlock[rcx].NextFreeBlock, rax

  {Was this bin empty?}

  jne @Done

  {Get the bin number in ecx}

  mov rcx, r9

  {Get the group number in edx}

  mov rdx, r9

  shr edx, 5

  {Flag this bin as not empty}

  mov eax, 1

  shl eax, cl

  lea r8, MediumBlockBinBitmaps

  or dword ptr [r8 + rdx * 4], eax

  {Flag the group as not empty}

  mov eax, 1

  mov ecx, edx

  shl eax, cl

  or MediumBlockBinGroupBitmap, eax

@Done:

end;

{$endif}

{$endif}



{Bins what remains in the current sequential feed medium block pool. Medium

 blocks must be locked.}

procedure BinMediumSequentialFeedRemainder;

{$ifndef ASMVersion}

var

  LSequentialFeedFreeSize, LNextBlockSizeAndFlags: NativeUInt;

  LPRemainderBlock, LNextMediumBlock: Pointer;

begin

  LSequentialFeedFreeSize := MediumSequentialFeedBytesLeft;

  if LSequentialFeedFreeSize > 0 then

  begin

    {Get the block after the open space}

    LNextMediumBlock := LastSequentiallyFedMediumBlock;

    LNextBlockSizeAndFlags := PNativeUInt(PByte(LNextMediumBlock) - BlockHeaderSize)^;

    {Point to the remainder}

    LPRemainderBlock := Pointer(PByte(LNextMediumBlock) - LSequentialFeedFreeSize);

{$ifndef FullDebugMode}

    {Can the next block be combined with the remainder?}

    if (LNextBlockSizeAndFlags and IsFreeBlockFlag) <> 0 then

    begin

      {Increase the size of this block}

      Inc(LSequentialFeedFreeSize, LNextBlockSizeAndFlags and DropMediumAndLargeFlagsMask);

      {Remove the next block as well}

      if (LNextBlockSizeAndFlags and DropMediumAndLargeFlagsMask) >= MinimumMediumBlockSize then

        RemoveMediumFreeBlock(LNextMediumBlock);

    end

    else

    begin

{$endif}

      {Set the "previous block is free" flag of the next block}

      PNativeUInt(PByte(LNextMediumBlock) - BlockHeaderSize)^ := LNextBlockSizeAndFlags or PreviousMediumBlockIsFreeFlag;

{$ifndef FullDebugMode}

    end;

{$endif}

    {Store the size of the block as well as the flags}

    PNativeUInt(PByte(LPRemainderBlock) - BlockHeaderSize)^ := LSequentialFeedFreeSize or IsMediumBlockFlag or IsFreeBlockFlag;

    {Store the trailing size marker}

    PNativeUInt(PByte(LPRemainderBlock) + LSequentialFeedFreeSize - BlockHeaderSize * 2)^ := LSequentialFeedFreeSize;

{$ifdef FullDebugMode}

    {In full debug mode the sequential feed remainder will never be too small to

     fit a full debug header.}

    {Clear the user area of the block}

    DebugFillMem(Pointer(PByte(LPRemainderBlock) + SizeOf(TFullDebugBlockHeader) + SizeOf(NativeUInt))^,

      LSequentialFeedFreeSize - FullDebugBlockOverhead - SizeOf(NativeUInt),

      {$ifndef CatchUseOfFreedInterfaces}DebugFillPattern{$else}NativeUInt(@VMTBadInterface){$endif});

    {We need to set a valid debug header and footer in the remainder}

    PFullDebugBlockHeader(LPRemainderBlock).HeaderCheckSum := NativeUInt(LPRemainderBlock);

    PNativeUInt(PByte(LPRemainderBlock) + SizeOf(TFullDebugBlockHeader))^ := not NativeUInt(LPRemainderBlock);

{$endif}

    {Bin this medium block}

    if LSequentialFeedFreeSize >= MinimumMediumBlockSize then

      InsertMediumBlockIntoBin(LPRemainderBlock, LSequentialFeedFreeSize);

  end;

end;

{$else}

{$ifdef 32Bit}

asm

  cmp MediumSequentialFeedBytesLeft, 0

  jne @MustBinMedium

  {Nothing to bin}

  ret

  {Align branch target}

  nop

  nop

@MustBinMedium:

  {Get a pointer to the last sequentially allocated medium block}

  mov eax, LastSequentiallyFedMediumBlock

  {Is the block that was last fed sequentially free?}

  test byte ptr [eax - 4], IsFreeBlockFlag

  jnz @LastBlockFedIsFree

  {Set the "previous block is free" flag in the last block fed}

  or dword ptr [eax - 4], PreviousMediumBlockIsFreeFlag

  {Get the remainder in edx}

  mov edx, MediumSequentialFeedBytesLeft

  {Point eax to the start of the remainder}

  sub eax, edx

@BinTheRemainder:

  {Status: eax = start of remainder, edx = size of remainder}

  {Store the size of the block as well as the flags}

  lea ecx, [edx + IsMediumBlockFlag + IsFreeBlockFlag]

  mov [eax - 4], ecx

  {Store the trailing size marker}

  mov [eax + edx - 8], edx

  {Bin this medium block}

  cmp edx, MinimumMediumBlockSize

  jnb InsertMediumBlockIntoBin

  ret

  {Align branch target}

  nop

  nop

@LastBlockFedIsFree:

  {Drop the flags}

  mov edx, DropMediumAndLargeFlagsMask

  and edx, [eax - 4]

  {Free the last block fed}

  cmp edx, MinimumMediumBlockSize

  jb @DontRemoveLastFed

  {Last fed block is free - remove it from its size bin}

  call RemoveMediumFreeBlock

  {Re-read eax and edx}

  mov eax, LastSequentiallyFedMediumBlock

  mov edx, DropMediumAndLargeFlagsMask

  and edx, [eax - 4]

@DontRemoveLastFed:

  {Get the number of bytes left in ecx}

  mov ecx, MediumSequentialFeedBytesLeft

  {Point eax to the start of the remainder}

  sub eax, ecx

  {edx = total size of the remainder}

  add edx, ecx

  jmp @BinTheRemainder

@Done:

end;

{$else}

asm

  .params 2

  xor eax, eax

  cmp MediumSequentialFeedBytesLeft, eax

  je @Done

  {Get a pointer to the last sequentially allocated medium block}

  mov rax, LastSequentiallyFedMediumBlock

  {Is the block that was last fed sequentially free?}

  test byte ptr [rax - BlockHeaderSize], IsFreeBlockFlag

  jnz @LastBlockFedIsFree

  {Set the "previous block is free" flag in the last block fed}

  or qword ptr [rax - BlockHeaderSize], PreviousMediumBlockIsFreeFlag

  {Get the remainder in edx}

  mov edx, MediumSequentialFeedBytesLeft

  {Point eax to the start of the remainder}

  sub rax, rdx

@BinTheRemainder:

  {Status: rax = start of remainder, edx = size of remainder}

  {Store the size of the block as well as the flags}

  lea rcx, [rdx + IsMediumBlockFlag + IsFreeBlockFlag]

  mov [rax - BlockHeaderSize], rcx

  {Store the trailing size marker}

  mov [rax + rdx - 2 * BlockHeaderSize], rdx

  {Bin this medium block}

  cmp edx, MinimumMediumBlockSize

  jb @Done

  mov rcx, rax

  call InsertMediumBlockIntoBin

  jmp @Done

@LastBlockFedIsFree:

  {Drop the flags}

  mov rdx, DropMediumAndLargeFlagsMask

  and rdx, [rax - BlockHeaderSize]

  {Free the last block fed}

  cmp edx, MinimumMediumBlockSize

  jb @DontRemoveLastFed

  {Last fed block is free - remove it from its size bin}

  mov rcx, rax

  call RemoveMediumFreeBlock

  {Re-read rax and rdx}

  mov rax, LastSequentiallyFedMediumBlock

  mov rdx, DropMediumAndLargeFlagsMask

  and rdx, [rax - BlockHeaderSize]

@DontRemoveLastFed:

  {Get the number of bytes left in ecx}

  mov ecx, MediumSequentialFeedBytesLeft

  {Point rax to the start of the remainder}

  sub rax, rcx

  {edx = total size of the remainder}

  add edx, ecx

  jmp @BinTheRemainder

@Done:

end;

{$endif}

{$endif}



{Allocates a new sequential feed medium block pool and immediately splits off a

 block of the requested size. The block size must be a multiple of 16 and

 medium blocks must be locked.}

function AllocNewSequentialFeedMediumPool(AFirstBlockSize: Cardinal): Pointer;

var

  LOldFirstMediumBlockPool: PMediumBlockPoolHeader;

  LNewPool: Pointer;

begin

  {Bin the current sequential feed remainder}

  BinMediumSequentialFeedRemainder;

  {Allocate a new sequential feed block pool}

  LNewPool := VirtualAlloc(nil, MediumBlockPoolSize,

    MEM_COMMIT{$ifdef AlwaysAllocateTopDown} or MEM_TOP_DOWN{$endif}, PAGE_READWRITE);

  if LNewPool <> nil then

  begin

    {Insert this block pool into the list of block pools}

    LOldFirstMediumBlockPool := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader;

    PMediumBlockPoolHeader(LNewPool).PreviousMediumBlockPoolHeader := @MediumBlockPoolsCircularList;

    MediumBlockPoolsCircularList.NextMediumBlockPoolHeader := LNewPool;

    PMediumBlockPoolHeader(LNewPool).NextMediumBlockPoolHeader := LOldFirstMediumBlockPool;

    LOldFirstMediumBlockPool.PreviousMediumBlockPoolHeader := LNewPool;

    {Store the sequential feed pool trailer}

    PNativeUInt(PByte(LNewPool) + MediumBlockPoolSize - BlockHeaderSize)^ := IsMediumBlockFlag;

    {Get the number of bytes still available}

    MediumSequentialFeedBytesLeft := (MediumBlockPoolSize - MediumBlockPoolHeaderSize) - AFirstBlockSize;

    {Get the result}

    Result := Pointer(PByte(LNewPool) + MediumBlockPoolSize - AFirstBlockSize);

    LastSequentiallyFedMediumBlock := Result;

    {Store the block header}

    PNativeUInt(PByte(Result) - BlockHeaderSize)^ := AFirstBlockSize or IsMediumBlockFlag;

  end

  else

  begin

    {Out of memory}

    MediumSequentialFeedBytesLeft := 0;

    Result := nil;

  end;

end;



{-----------------Large Block Management------------------}



{Locks the large blocks}

procedure LockLargeBlocks;

begin

  {Lock the large blocks}

{$ifndef AssumeMultiThreaded}

  if IsMultiThread then

{$endif}

  begin

    while LockCmpxchg(0, 1, @LargeBlocksLocked) <> 0 do

    begin

{$ifdef NeverSleepOnThreadContention}

  {$ifdef UseSwitchToThread}

      SwitchToThread;

  {$endif}

{$else}

      Sleep(InitialSleepTime);

      if LockCmpxchg(0, 1, @LargeBlocksLocked) = 0 then

        Break;

      Sleep(AdditionalSleepTime);

{$endif}

    end;

  end;

end;



{Allocates a Large block of at least ASize (actual size may be larger to

 allow for alignment etc.). ASize must be the actual user requested size. This

 procedure will pad it to the appropriate page boundary and also add the space

 required by the header.}

function AllocateLargeBlock(ASize: NativeUInt): Pointer;

var

  LLargeUsedBlockSize: NativeUInt;

  LOldFirstLargeBlock: PLargeBlockHeader;

begin

  {Pad the block size to include the header and granularity. We also add a

   SizeOf(Pointer) overhead so a huge block size is a multiple of 16 bytes less

   SizeOf(Pointer) (so we can use a single move function for reallocating all

   block types)}

  LLargeUsedBlockSize := (ASize + LargeBlockHeaderSize + LargeBlockGranularity - 1 + BlockHeaderSize)

    and -LargeBlockGranularity;

  {Get the Large block}

  Result := VirtualAlloc(nil, LLargeUsedBlockSize, MEM_COMMIT or MEM_TOP_DOWN,

    PAGE_READWRITE);

  {Set the Large block fields}

  if Result <> nil then

  begin

    {Set the large block size and flags}

    PLargeBlockHeader(Result).UserAllocatedSize := ASize;

    PLargeBlockHeader(Result).BlockSizeAndFlags := LLargeUsedBlockSize or IsLargeBlockFlag;

    {Insert the large block into the linked list of large blocks}

    LockLargeBlocks;

    LOldFirstLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader;

    PLargeBlockHeader(Result).PreviousLargeBlockHeader := @LargeBlocksCircularList;

    LargeBlocksCircularList.NextLargeBlockHeader := Result;

    PLargeBlockHeader(Result).NextLargeBlockHeader := LOldFirstLargeBlock;

    LOldFirstLargeBlock.PreviousLargeBlockHeader := Result;

    LargeBlocksLocked := False;

    {Add the size of the header}

    Inc(PByte(Result), LargeBlockHeaderSize);

{$ifdef FullDebugMode}

    {Since large blocks are never reused, the user area is not initialized to

     the debug fill pattern, but the debug header and footer must be set.}

    PFullDebugBlockHeader(Result).HeaderCheckSum := NativeUInt(Result);

    PNativeUInt(PByte(Result) + SizeOf(TFullDebugBlockHeader))^ := not NativeUInt(Result);

{$endif}

  end;

end;



{Frees a large block, returning 0 on success, -1 otherwise}

function FreeLargeBlock(APointer: Pointer): Integer;

var

  LPreviousLargeBlockHeader, LNextLargeBlockHeader: PLargeBlockHeader;

{$ifndef POSIX}

  LRemainingSize: NativeUInt;

  LCurrentSegment: Pointer;

  LMemInfo: TMemoryBasicInformation;

{$endif}

begin

{$ifdef ClearLargeBlocksBeforeReturningToOS}

  FillChar(APointer^,

    (PLargeBlockHeader(PByte(APointer) - LargeBlockHeaderSize).BlockSizeAndFlags

      and DropMediumAndLargeFlagsMask) - LargeBlockHeaderSize, 0);

{$endif}

  {Point to the start of the large block}

  APointer := Pointer(PByte(APointer) - LargeBlockHeaderSize);

  {Get the previous and next large blocks}

  LockLargeBlocks;

  LPreviousLargeBlockHeader := PLargeBlockHeader(APointer).PreviousLargeBlockHeader;

  LNextLargeBlockHeader := PLargeBlockHeader(APointer).NextLargeBlockHeader;

{$ifndef POSIX}

  {Is the large block segmented?}

  if PLargeBlockHeader(APointer).BlockSizeAndFlags and LargeBlockIsSegmented = 0 then

  begin

{$endif}

    {Single segment large block: Try to free it}

    if VirtualFree(APointer, 0, MEM_RELEASE) then

      Result := 0

    else

      Result := -1;

{$ifndef POSIX}

  end

  else

  begin

    {The large block is segmented - free all segments}

    LCurrentSegment := APointer;

    LRemainingSize := PLargeBlockHeader(APointer).BlockSizeAndFlags and DropMediumAndLargeFlagsMask;

    Result := 0;

    while True do

    begin

      {Get the size of the current segment}

      VirtualQuery(LCurrentSegment, LMemInfo, SizeOf(LMemInfo));

      {Free the segment}

      if not VirtualFree(LCurrentSegment, 0, MEM_RELEASE) then

      begin

        Result := -1;

        Break;

      end;

      {Done?}

      if NativeUInt(LMemInfo.RegionSize) >= LRemainingSize then

        Break;

      {Decrement the remaining size}

      Dec(LRemainingSize, NativeUInt(LMemInfo.RegionSize));

      Inc(PByte(LCurrentSegment), NativeUInt(LMemInfo.RegionSize));

    end;

  end;

{$endif}

  {Success?}

  if Result = 0 then

  begin

    {Remove the large block from the linked list}

    LNextLargeBlockHeader.PreviousLargeBlockHeader := LPreviousLargeBlockHeader;

    LPreviousLargeBlockHeader.NextLargeBlockHeader := LNextLargeBlockHeader;

  end;

  {Unlock the large blocks}

  LargeBlocksLocked := False;

end;



{$ifndef FullDebugMode}

{Reallocates a large block to at least the requested size. Returns the new

 pointer, or nil on error}

function ReallocateLargeBlock(APointer: Pointer; ANewSize: NativeUInt): Pointer;

var

  LOldAvailableSize, LBlockHeader, LOldUserSize, LMinimumUpsize,

    LNewAllocSize: NativeUInt;

{$ifndef POSIX}

  LNewSegmentSize: NativeUInt;

  LNextSegmentPointer: Pointer;

  LMemInfo: TMemoryBasicInformation;

{$endif}

begin

  {Get the block header}

  LBlockHeader := PNativeUInt(PByte(APointer) - BlockHeaderSize)^;

  {Large block - size is (16 + 4) less than the allocated size}

  LOldAvailableSize := (LBlockHeader and DropMediumAndLargeFlagsMask) - (LargeBlockHeaderSize + BlockHeaderSize);

  {Is it an upsize or a downsize?}

  if ANewSize > LOldAvailableSize then

  begin

    {This pointer is being reallocated to a larger block and therefore it is

     logical to assume that it may be enlarged again. Since reallocations are

     expensive, there is a minimum upsize percentage to avoid unnecessary

     future move operations.}

    {Add 25% for large block upsizes}

    LMinimumUpsize := LOldAvailableSize + (LOldAvailableSize shr 2);

    if ANewSize < LMinimumUpsize then

      LNewAllocSize := LMinimumUpsize

    else

      LNewAllocSize := ANewSize;

{$ifndef POSIX}

    {Can another large block segment be allocated directly after this segment,

     thus negating the need to move the data?}

    LNextSegmentPointer := Pointer(PByte(APointer) - LargeBlockHeaderSize + (LBlockHeader and DropMediumAndLargeFlagsMask));

    VirtualQuery(LNextSegmentPointer, LMemInfo, SizeOf(LMemInfo));

    if LMemInfo.State = MEM_FREE then

    begin

      {Round the region size to the previous 64K}

      LMemInfo.RegionSize := LMemInfo.RegionSize and -LargeBlockGranularity;

      {Enough space to grow in place?}

      if NativeUInt(LMemInfo.RegionSize) > (ANewSize - LOldAvailableSize) then

      begin

        {There is enough space after the block to extend it - determine by how

         much}

        LNewSegmentSize := (LNewAllocSize - LOldAvailableSize + LargeBlockGranularity - 1) and -LargeBlockGranularity;

        if LNewSegmentSize > LMemInfo.RegionSize then

          LNewSegmentSize := LMemInfo.RegionSize;

        {Attempy to reserve the address range (which will fail if another

         thread has just reserved it) and commit it immediately afterwards.}

        if (VirtualAlloc(LNextSegmentPointer, LNewSegmentSize, MEM_RESERVE, PAGE_READWRITE) <> nil)

          and (VirtualAlloc(LNextSegmentPointer, LNewSegmentSize, MEM_COMMIT, PAGE_READWRITE) <> nil) then

        begin

          {Update the requested size}

          PLargeBlockHeader(PByte(APointer) - LargeBlockHeaderSize).UserAllocatedSize := ANewSize;

          PLargeBlockHeader(PByte(APointer) - LargeBlockHeaderSize).BlockSizeAndFlags :=

            (PLargeBlockHeader(PByte(APointer) - LargeBlockHeaderSize).BlockSizeAndFlags + LNewSegmentSize)

            or LargeBlockIsSegmented;

          {Success}

          Result := APointer;

          Exit;

        end;

      end;

    end;

{$endif}

    {Could not resize in place: Allocate the new block}

    Result := FastGetMem(LNewAllocSize);

    if Result <> nil then

    begin

      {If it's a large block - store the actual user requested size (it may

       not be if the block that is being reallocated from was previously

       downsized)}

      if LNewAllocSize > (MaximumMediumBlockSize - BlockHeaderSize) then

        PLargeBlockHeader(PByte(Result) - LargeBlockHeaderSize).UserAllocatedSize := ANewSize;

      {The user allocated size is stored for large blocks}

      LOldUserSize := PLargeBlockHeader(PByte(APointer) - LargeBlockHeaderSize).UserAllocatedSize;

      {The number of bytes to move is the old user size.}

{$ifdef UseCustomVariableSizeMoveRoutines}

      MoveX16LP(APointer^, Result^, LOldUserSize);

{$else}

      System.Move(APointer^, Result^, LOldUserSize);

{$endif}

      {Free the old block}

      FastFreeMem(APointer);

    end;

  end

  else

  begin

    {It's a downsize: do we need to reallocate? Only if the new size is less

     than half the old size}

    if ANewSize >= (LOldAvailableSize shr 1) then

    begin

      {No need to reallocate}

      Result := APointer;

      {Update the requested size}

      PLargeBlockHeader(PByte(APointer) - LargeBlockHeaderSize).UserAllocatedSize := ANewSize;

    end

    else

    begin

      {The block is less than half the old size, and the current size is

       greater than the minimum block size allowing a downsize: reallocate}

      Result := FastGetMem(ANewSize);

      if Result <> nil then

      begin

        {Still a large block? -> Set the user size}

        if ANewSize > (MaximumMediumBlockSize - BlockHeaderSize) then

          PLargeBlockHeader(PByte(APointer) - LargeBlockHeaderSize).UserAllocatedSize := ANewSize;

        {Move the data across}

{$ifdef UseCustomVariableSizeMoveRoutines}

{$ifdef Align16Bytes}

        MoveX16LP(APointer^, Result^, ANewSize);

{$else}

        MoveX8LP(APointer^, Result^, ANewSize);

{$endif}

{$else}

        System.Move(APointer^, Result^, ANewSize);

{$endif}

        {Free the old block}

        FastFreeMem(APointer);

      end;

    end;

  end;

end;

{$endif}



{---------------------Replacement Memory Manager Interface---------------------}



{Replacement for SysGetMem}



function FastGetMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer;

{$ifndef ASMVersion}

var

  LMediumBlock{$ifndef FullDebugMode}, LNextFreeBlock, LSecondSplit{$endif}: PMediumFreeBlock;

  LNextMediumBlockHeader: PNativeUInt;

  LBlockSize, LAvailableBlockSize{$ifndef FullDebugMode}, LSecondSplitSize{$endif},

    LSequentialFeedFreeSize: NativeUInt;

  LPSmallBlockType: PSmallBlockType;

  LPSmallBlockPool, LPNewFirstPool: PSmallBlockPoolHeader;

  LNewFirstFreeBlock: Pointer;

  LPMediumBin: PMediumFreeBlock;

  LBinNumber, {$ifndef FullDebugMode}LBinGroupsMasked, {$endif}LBinGroupMasked,

    LBinGroupNumber: Cardinal;

begin

  {Is it a small block? -> Take the header size into account when

   determining the required block size}

  if NativeUInt(ASize) <= (MaximumSmallBlockSize - BlockHeaderSize) then

  begin

    {-------------------------Allocate a small block---------------------------}

    {Get the block type from the size}

    LPSmallBlockType := PSmallBlockType(AllocSize2SmallBlockTypeIndX4[

      (NativeUInt(ASize) + (BlockHeaderSize - 1)) div SmallBlockGranularity]

      * (SizeOf(TSmallBlockType) div 4)

      + UIntPtr(@SmallBlockTypes));

    {Lock the block type}

{$ifndef AssumeMultiThreaded}

    if IsMultiThread then

{$endif}

    begin

      while True do

      begin

        {Try to lock the small block type}

        if LockCmpxchg(0, 1, @LPSmallBlockType.BlockTypeLocked) = 0 then

          Break;

        {Try the next block type}

        Inc(PByte(LPSmallBlockType), SizeOf(TSmallBlockType));

        if LockCmpxchg(0, 1, @LPSmallBlockType.BlockTypeLocked) = 0 then

          Break;

        {Try up to two sizes past the requested size}

        Inc(PByte(LPSmallBlockType), SizeOf(TSmallBlockType));

        if LockCmpxchg(0, 1, @LPSmallBlockType.BlockTypeLocked) = 0 then

          Break;

        {All three sizes locked - given up and sleep}

        Dec(PByte(LPSmallBlockType), 2 * SizeOf(TSmallBlockType));

{$ifdef NeverSleepOnThreadContention}

  {$ifdef UseSwitchToThread}

        SwitchToThread;

  {$endif}

{$else}

        {Both this block type and the next is in use: sleep}

        Sleep(InitialSleepTime);

        {Try the lock again}

        if LockCmpxchg(0, 1, @LPSmallBlockType.BlockTypeLocked) = 0 then

          Break;

        {Sleep longer}

        Sleep(AdditionalSleepTime);

{$endif}

      end;

    end;

    {Get the first pool with free blocks}

    LPSmallBlockPool := LPSmallBlockType.NextPartiallyFreePool;

    {Is the pool valid?}

    if UIntPtr(LPSmallBlockPool) <> UIntPtr(LPSmallBlockType) then

    begin

      {Get the first free offset}

      Result := LPSmallBlockPool.FirstFreeBlock;

      {Get the new first free block}

      LNewFirstFreeBlock := PPointer(PByte(Result) - BlockHeaderSize)^;

{$ifdef CheckHeapForCorruption}

      {The block should be free}

      if (NativeUInt(LNewFirstFreeBlock) and ExtractSmallFlagsMask) <> IsFreeBlockFlag then

  {$ifdef BCB6OrDelphi7AndUp}

        System.Error(reInvalidPtr);

  {$else}

        System.RunError(reInvalidPtr);

  {$endif}

{$endif}

      LNewFirstFreeBlock := Pointer(UIntPtr(LNewFirstFreeBlock) and DropSmallFlagsMask);

      {Increment the number of used blocks}

      Inc(LPSmallBlockPool.BlocksInUse);

      {Set the new first free block}

      LPSmallBlockPool.FirstFreeBlock := LNewFirstFreeBlock;

      {Is the pool now full?}

      if LNewFirstFreeBlock = nil then

      begin

        {Pool is full - remove it from the partially free list}

        LPNewFirstPool := LPSmallBlockPool.NextPartiallyFreePool;

        LPSmallBlockType.NextPartiallyFreePool := LPNewFirstPool;

        LPNewFirstPool.PreviousPartiallyFreePool := PSmallBlockPoolHeader(LPSmallBlockType);

      end;

    end

    else

    begin

      {Try to feed a small block sequentially}

      Result := LPSmallBlockType.NextSequentialFeedBlockAddress;

      {Can another block fit?}

      if UIntPtr(Result) <= UIntPtr(LPSmallBlockType.MaxSequentialFeedBlockAddress) then

      begin

        {Get the sequential feed block pool}

        LPSmallBlockPool := LPSmallBlockType.CurrentSequentialFeedPool;

        {Increment the number of used blocks in the sequential feed pool}

        Inc(LPSmallBlockPool.BlocksInUse);

        {Store the next sequential feed block address}

        LPSmallBlockType.NextSequentialFeedBlockAddress := Pointer(PByte(Result) + LPSmallBlockType.BlockSize);

      end

      else

      begin

        {Need to allocate a pool: Lock the medium blocks}

        LockMediumBlocks;

{$ifndef FullDebugMode}

        {Are there any available blocks of a suitable size?}

        LBinGroupsMasked := MediumBlockBinGroupBitmap and ($ffffff00 or LPSmallBlockType.AllowedGroupsForBlockPoolBitmap);

        if LBinGroupsMasked <> 0 then

        begin

          {Get the bin group with free blocks}

          LBinGroupNumber := FindFirstSetBit(LBinGroupsMasked);

          {Get the bin in the group with free blocks}

          LBinNumber := FindFirstSetBit(MediumBlockBinBitmaps[LBinGroupNumber])

            + LBinGroupNumber * 32;

          LPMediumBin := @MediumBlockBins[LBinNumber];

          {Get the first block in the bin}

          LMediumBlock := LPMediumBin.NextFreeBlock;

          {Remove the first block from the linked list (LIFO)}

          LNextFreeBlock := LMediumBlock.NextFreeBlock;

          LPMediumBin.NextFreeBlock := LNextFreeBlock;

          LNextFreeBlock.PreviousFreeBlock := LPMediumBin;

          {Is this bin now empty?}

          if LNextFreeBlock = LPMediumBin then

          begin

            {Flag this bin as empty}

            MediumBlockBinBitmaps[LBinGroupNumber] := MediumBlockBinBitmaps[LBinGroupNumber]

              and (not (1 shl (LBinNumber and 31)));

            {Is the group now entirely empty?}

            if MediumBlockBinBitmaps[LBinGroupNumber] = 0 then

            begin

              {Flag this group as empty}

              MediumBlockBinGroupBitmap := MediumBlockBinGroupBitmap

                and (not (1 shl LBinGroupNumber));

            end;

          end;

          {Get the size of the available medium block}

          LBlockSize := PNativeUInt(PByte(LMediumBlock) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask;

  {$ifdef CheckHeapForCorruption}

          {Check that this block is actually free and the next and previous blocks

           are both in use.}

          if ((PNativeUInt(PByte(LMediumBlock) - BlockHeaderSize)^ and ExtractMediumAndLargeFlagsMask) <> (IsMediumBlockFlag or IsFreeBlockFlag))

            or ((PNativeUInt(PByte(LMediumBlock) + (PNativeUInt(PByte(LMediumBlock) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask) - BlockHeaderSize)^ and IsFreeBlockFlag) <> 0)

          then

          begin

    {$ifdef BCB6OrDelphi7AndUp}

            System.Error(reInvalidPtr);

    {$else}

            System.RunError(reInvalidPtr);

    {$endif}

          end;

  {$endif}

          {Should the block be split?}

          if LBlockSize >= MaximumSmallBlockPoolSize then

          begin

            {Get the size of the second split}

            LSecondSplitSize := LBlockSize - LPSmallBlockType.OptimalBlockPoolSize;

            {Adjust the block size}

            LBlockSize := LPSmallBlockType.OptimalBlockPoolSize;

            {Split the block in two}

            LSecondSplit := PMediumFreeBlock(PByte(LMediumBlock) + LBlockSize);

            PNativeUInt(PByte(LSecondSplit) - BlockHeaderSize)^ := LSecondSplitSize or (IsMediumBlockFlag or IsFreeBlockFlag);

            {Store the size of the second split as the second last dword/qword}

            PNativeUInt(PByte(LSecondSplit) + LSecondSplitSize - 2 * BlockHeaderSize)^ := LSecondSplitSize;

            {Put the remainder in a bin (it will be big enough)}

            InsertMediumBlockIntoBin(LSecondSplit, LSecondSplitSize);

          end

          else

          begin

            {Mark this block as used in the block following it}

            LNextMediumBlockHeader := PNativeUInt(PByte(LMediumBlock) + LBlockSize - BlockHeaderSize);

            LNextMediumBlockHeader^ := LNextMediumBlockHeader^ and (not PreviousMediumBlockIsFreeFlag);

          end;

        end

        else

        begin

{$endif}

          {Check the sequential feed medium block pool for space}

          LSequentialFeedFreeSize := MediumSequentialFeedBytesLeft;

          if LSequentialFeedFreeSize >= LPSmallBlockType.MinimumBlockPoolSize then

          begin

            {Enough sequential feed space: Will the remainder be usable?}

            if LSequentialFeedFreeSize >= (LPSmallBlockType.OptimalBlockPoolSize + MinimumMediumBlockSize) then

            begin

              LBlockSize := LPSmallBlockType.OptimalBlockPoolSize;

            end

            else

              LBlockSize := LSequentialFeedFreeSize;

            {Get the block}

            LMediumBlock := Pointer(PByte(LastSequentiallyFedMediumBlock) - LBlockSize);

            {Update the sequential feed parameters}

            LastSequentiallyFedMediumBlock := LMediumBlock;

            MediumSequentialFeedBytesLeft := LSequentialFeedFreeSize - LBlockSize;

          end

          else

          begin

            {Need to allocate a new sequential feed medium block pool: use the

             optimal size for this small block pool}

            LBlockSize := LPSmallBlockType.OptimalBlockPoolSize;

            {Allocate the medium block pool}

            LMediumBlock := AllocNewSequentialFeedMediumPool(LBlockSize);

            if LMediumBlock = nil then

            begin

              {Out of memory}

              {Unlock the medium blocks}

              MediumBlocksLocked := False;

              {Unlock the block type}

              LPSmallBlockType.BlockTypeLocked := False;

              {Failed}

              Result := nil;

              {done}

              Exit;

            end;

          end;

{$ifndef FullDebugMode}

        end;

{$endif}

        {Mark this block as in use}

        {Set the size and flags for this block}

        PNativeUInt(PByte(LMediumBlock) - BlockHeaderSize)^ := LBlockSize or IsMediumBlockFlag or IsSmallBlockPoolInUseFlag;

        {Unlock medium blocks}

        MediumBlocksLocked := False;

        {Set up the block pool}

        LPSmallBlockPool := PSmallBlockPoolHeader(LMediumBlock);

        LPSmallBlockPool.BlockType := LPSmallBlockType;

        LPSmallBlockPool.FirstFreeBlock := nil;

        LPSmallBlockPool.BlocksInUse := 1;

        {Set it up for sequential block serving}

        LPSmallBlockType.CurrentSequentialFeedPool := LPSmallBlockPool;

        Result := Pointer(PByte(LPSmallBlockPool) + SmallBlockPoolHeaderSize);

        LPSmallBlockType.NextSequentialFeedBlockAddress := Pointer(PByte(Result) + LPSmallBlockType.BlockSize);

        LPSmallBlockType.MaxSequentialFeedBlockAddress := Pointer(PByte(LPSmallBlockPool) + LBlockSize - LPSmallBlockType.BlockSize);

      end;

{$ifdef FullDebugMode}

      {Clear the user area of the block}

      DebugFillMem(Pointer(PByte(Result) + (SizeOf(TFullDebugBlockHeader) + SizeOf(NativeUInt)))^,

        LPSmallBlockType.BlockSize - FullDebugBlockOverhead - SizeOf(NativeUInt),

        {$ifndef CatchUseOfFreedInterfaces}DebugFillPattern{$else}NativeUInt(@VMTBadInterface){$endif});

      {Block was fed sequentially - we need to set a valid debug header. Use

       the block address.}

      PFullDebugBlockHeader(Result).HeaderCheckSum := NativeUInt(Result);

      PNativeUInt(PByte(Result) + SizeOf(TFullDebugBlockHeader))^ := not NativeUInt(Result);

{$endif}

    end;

    {Unlock the block type}

    LPSmallBlockType.BlockTypeLocked := False;

    {Set the block header}

    PNativeUInt(PByte(Result) - BlockHeaderSize)^ := UIntPtr(LPSmallBlockPool);

  end

  else

  begin

    {Medium block or Large block?}

    if NativeUInt(ASize) <= (MaximumMediumBlockSize - BlockHeaderSize) then

    begin

      {------------------------Allocate a medium block--------------------------}

      {Get the block size and bin number for this block size. Block sizes are

       rounded up to the next bin size.}

      LBlockSize := ((NativeUInt(ASize) + (MediumBlockGranularity - 1 + BlockHeaderSize - MediumBlockSizeOffset))

        and -MediumBlockGranularity) + MediumBlockSizeOffset;

      {Get the bin number}

      LBinNumber := (LBlockSize - MinimumMediumBlockSize) div MediumBlockGranularity;

      {Lock the medium blocks}

      LockMediumBlocks;

      {Calculate the bin group}

      LBinGroupNumber := LBinNumber div 32;

      {Is there a suitable block inside this group?}

      LBinGroupMasked := MediumBlockBinBitmaps[LBinGroupNumber] and -(1 shl (LBinNumber and 31));

      if LBinGroupMasked <> 0 then

      begin

        {Get the actual bin number}

        LBinNumber := FindFirstSetBit(LBinGroupMasked) + LBinGroupNumber * 32;

      end

      else

      begin

{$ifndef FullDebugMode}

        {Try all groups greater than this group}

        LBinGroupsMasked := MediumBlockBinGroupBitmap and -(2 shl LBinGroupNumber);

        if LBinGroupsMasked <> 0 then

        begin

          {There is a suitable group with space: get the bin number}

          LBinGroupNumber := FindFirstSetBit(LBinGroupsMasked);

          {Get the bin in the group with free blocks}

          LBinNumber := FindFirstSetBit(MediumBlockBinBitmaps[LBinGroupNumber])

            + LBinGroupNumber * 32;

        end

        else

        begin

{$endif}

          {There are no bins with a suitable block: Sequentially feed the required block}

          LSequentialFeedFreeSize := MediumSequentialFeedBytesLeft;

          if LSequentialFeedFreeSize >= LBlockSize then

          begin

{$ifdef FullDebugMode}

            {In full debug mode a medium block must have enough bytes to fit

             all the debug info, so we must make sure there are no tiny medium

             blocks at the start of the pool.}

            if LSequentialFeedFreeSize - LBlockSize < (FullDebugBlockOverhead + BlockHeaderSize) then

              LBlockSize := LSequentialFeedFreeSize;

{$endif}

            {Block can be fed sequentially}

            Result := Pointer(PByte(LastSequentiallyFedMediumBlock) - LBlockSize);

            {Store the last sequentially fed block}

            LastSequentiallyFedMediumBlock := Result;

            {Store the remaining bytes}

            MediumSequentialFeedBytesLeft := LSequentialFeedFreeSize - LBlockSize;

            {Set the flags for the block}

            PNativeUInt(PByte(Result) - BlockHeaderSize)^ := LBlockSize or IsMediumBlockFlag;

          end

          else

          begin

            {Need to allocate a new sequential feed block}

            Result := AllocNewSequentialFeedMediumPool(LBlockSize);

          end;

{$ifdef FullDebugMode}

          {Block was fed sequentially - we need to set a valid debug header}

          if Result <> nil then

          begin

            PFullDebugBlockHeader(Result).HeaderCheckSum := NativeUInt(Result);

            PNativeUInt(PByte(Result) + SizeOf(TFullDebugBlockHeader))^ := not NativeUInt(Result);

            {Clear the user area of the block}

            DebugFillMem(Pointer(PByte(Result) + SizeOf(TFullDebugBlockHeader) + SizeOf(NativeUInt))^,

              LBlockSize - FullDebugBlockOverhead - SizeOf(NativeUInt),

              {$ifndef CatchUseOfFreedInterfaces}DebugFillPattern{$else}NativeUInt(@VMTBadInterface){$endif});

          end;

{$endif}

          {Done}

          MediumBlocksLocked := False;

          Exit;

{$ifndef FullDebugMode}

        end;

{$endif}

      end;

      {If we get here we have a valid LBinGroupNumber and LBinNumber:

       Use the first block in the bin, splitting it if necessary}

      {Get a pointer to the bin}

      LPMediumBin := @MediumBlockBins[LBinNumber];

      {Get the result}

      Result := LPMediumBin.NextFreeBlock;

{$ifdef CheckHeapForCorruption}

      {Check that this block is actually free and the next and previous blocks

       are both in use (except in full debug mode).}

      if ((PNativeUInt(PByte(Result) - BlockHeaderSize)^ and {$ifndef FullDebugMode}ExtractMediumAndLargeFlagsMask{$else}(IsMediumBlockFlag or IsFreeBlockFlag){$endif}) <> (IsFreeBlockFlag or IsMediumBlockFlag))

  {$ifndef FullDebugMode}

        or ((PNativeUInt(PByte(Result) + (PNativeUInt(PByte(Result) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask) - BlockHeaderSize)^ and (ExtractMediumAndLargeFlagsMask - IsSmallBlockPoolInUseFlag)) <> (IsMediumBlockFlag or PreviousMediumBlockIsFreeFlag))

  {$endif}

      then

      begin

  {$ifdef BCB6OrDelphi7AndUp}

        System.Error(reInvalidPtr);

  {$else}

        System.RunError(reInvalidPtr);

  {$endif}

      end;

{$endif}

      {Remove the block from the bin containing it}

      RemoveMediumFreeBlock(Result);

      {Get the block size}

      LAvailableBlockSize := PNativeUInt(PByte(Result) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask;

{$ifndef FullDebugMode}

      {Is it an exact fit or not?}

      LSecondSplitSize := LAvailableBlockSize - LBlockSize;

      if LSecondSplitSize <> 0 then

      begin

        {Split the block in two}

        LSecondSplit := PMediumFreeBlock(PByte(Result) + LBlockSize);

        {Set the size of the second split}

        PNativeUInt(PByte(LSecondSplit) - BlockHeaderSize)^ := LSecondSplitSize or (IsMediumBlockFlag or IsFreeBlockFlag);

        {Store the size of the second split}

        PNativeUInt(PByte(LSecondSplit) + LSecondSplitSize - 2 * BlockHeaderSize)^ := LSecondSplitSize;

        {Put the remainder in a bin if it is big enough}

        if LSecondSplitSize >= MinimumMediumBlockSize then

          InsertMediumBlockIntoBin(LSecondSplit, LSecondSplitSize);

      end

      else

      begin

{$else}

        {In full debug mode blocks are never split or coalesced}

        LBlockSize := LAvailableBlockSize;

{$endif}

        {Mark this block as used in the block following it}

        LNextMediumBlockHeader := Pointer(PByte(Result) + LBlockSize - BlockHeaderSize);

{$ifndef FullDebugMode}

  {$ifdef CheckHeapForCorruption}

        {The next block must be in use}

        if (LNextMediumBlockHeader^ and (ExtractMediumAndLargeFlagsMask - IsSmallBlockPoolInUseFlag)) <> (IsMediumBlockFlag or PreviousMediumBlockIsFreeFlag) then

    {$ifdef BCB6OrDelphi7AndUp}

        System.Error(reInvalidPtr);

    {$else}

        System.RunError(reInvalidPtr);

    {$endif}

  {$endif}

{$endif}

        LNextMediumBlockHeader^ :=

          LNextMediumBlockHeader^ and (not PreviousMediumBlockIsFreeFlag);

{$ifndef FullDebugMode}

      end;

      {Set the size and flags for this block}

      PNativeUInt(PByte(Result) - BlockHeaderSize)^ := LBlockSize or IsMediumBlockFlag;

{$else}

      {In full debug mode blocks are never split or coalesced}

      Dec(PNativeUInt(PByte(Result) - BlockHeaderSize)^, IsFreeBlockFlag);

{$endif}

      {Unlock the medium blocks}

      MediumBlocksLocked := False;

    end

    else

    begin

      {Allocate a Large block}

      if ASize > 0 then

        Result := AllocateLargeBlock(ASize)

      else

        Result := nil;

    end;

  end;

end;

{$else}

{$ifdef 32Bit}

asm

  {On entry:

    eax = ASize}

  {Since most allocations are for small blocks, determine the small block type

   index so long}

  lea edx, [eax + BlockHeaderSize - 1]

{$ifdef Align16Bytes}

  shr edx, 4

{$else}

  shr edx, 3

{$endif}

  {Is it a small block?}

  cmp eax, (MaximumSmallBlockSize - BlockHeaderSize)

  {Save ebx}

  push ebx

  {Get the IsMultiThread variable so long}

{$ifndef AssumeMultiThreaded}

  mov cl, IsMultiThread

{$endif}

  {Is it a small block?}

  ja @NotASmallBlock

  {Do we need to lock the block type?}

{$ifndef AssumeMultiThreaded}

  test cl, cl

{$endif}

  {Get the small block type in ebx}

  movzx eax, byte ptr [AllocSize2SmallBlockTypeIndX4 + edx]

  lea ebx, [SmallBlockTypes + eax * 8]

  {Do we need to lock the block type?}

{$ifndef AssumeMultiThreaded}

  jnz @LockBlockTypeLoop

{$else}

  jmp @LockBlockTypeLoop

  {Align branch target}

  nop

  nop

{$endif}

@GotLockOnSmallBlockType:

  {Find the next free block: Get the first pool with free blocks in edx}

  mov edx, TSmallBlockType[ebx].NextPartiallyFreePool

  {Get the first free block (or the next sequential feed address if edx = ebx)}

  mov eax, TSmallBlockPoolHeader[edx].FirstFreeBlock

  {Get the drop flags mask in ecx so long}

  mov ecx, DropSmallFlagsMask

  {Is there a pool with free blocks?}

  cmp edx, ebx

  je @TrySmallSequentialFeed

  {Increment the number of used blocks}

  add TSmallBlockPoolHeader[edx].BlocksInUse, 1

  {Get the new first free block}

  and ecx, [eax - 4]

  {Set the new first free block}

  mov TSmallBlockPoolHeader[edx].FirstFreeBlock, ecx

  {Set the block header}

  mov [eax - 4], edx

  {Is the chunk now full?}

  jz @RemoveSmallPool

  {Unlock the block type}

  mov TSmallBlockType[ebx].BlockTypeLocked, False

  {Restore ebx}

  pop ebx

  {All done}

  ret

  {Align branch target}

{$ifndef AssumeMultiThreaded}

  nop

  nop

{$endif}

  nop

@TrySmallSequentialFeed:

  {Try to feed a small block sequentially: Get the sequential feed block pool}

  mov edx, TSmallBlockType[ebx].CurrentSequentialFeedPool

  {Get the next sequential feed address so long}

  movzx ecx, TSmallBlockType[ebx].BlockSize

  add ecx, eax

  {Can another block fit?}

  cmp eax, TSmallBlockType[ebx].MaxSequentialFeedBlockAddress

  ja @AllocateSmallBlockPool

  {Increment the number of used blocks in the sequential feed pool}

  add TSmallBlockPoolHeader[edx].BlocksInUse, 1

  {Store the next sequential feed block address}

  mov TSmallBlockType[ebx].NextSequentialFeedBlockAddress, ecx

  {Unlock the block type}

  mov TSmallBlockType[ebx].BlockTypeLocked, False

  {Set the block header}

  mov [eax - 4], edx

  {Restore ebx}

  pop ebx

  {All done}

  ret

  {Align branch target}

  nop

  nop

  nop

@RemoveSmallPool:

  {Pool is full - remove it from the partially free list}

  mov ecx, TSmallBlockPoolHeader[edx].NextPartiallyFreePool

  mov TSmallBlockPoolHeader[ecx].PreviousPartiallyFreePool, ebx

  mov TSmallBlockType[ebx].NextPartiallyFreePool, ecx

  {Unlock the block type}

  mov TSmallBlockType[ebx].BlockTypeLocked, False

  {Restore ebx}

  pop ebx

  {All done}

  ret

  {Align branch target}

  nop

  nop

@LockBlockTypeLoop:

  mov eax, $100

  {Attempt to grab the block type}

  lock cmpxchg TSmallBlockType([ebx]).BlockTypeLocked, ah

  je @GotLockOnSmallBlockType

  {Try the next size}

  add ebx, Type(TSmallBlockType)

  mov eax, $100

  lock cmpxchg TSmallBlockType([ebx]).BlockTypeLocked, ah

  je @GotLockOnSmallBlockType

  {Try the next size (up to two sizes larger)}

  add ebx, Type(TSmallBlockType)

  mov eax, $100

  lock cmpxchg TSmallBlockType([ebx]).BlockTypeLocked, ah

  je @GotLockOnSmallBlockType

  {Block type and two sizes larger are all locked - give up and sleep}

  sub ebx, 2 * Type(TSmallBlockType)

{$ifdef NeverSleepOnThreadContention}

  {Pause instruction (improves performance on P4)}

  rep nop

  {$ifdef UseSwitchToThread}

  call SwitchToThread

  {$endif}

  {Try again}

  jmp @LockBlockTypeLoop

  {Align branch target}

  nop

  {$ifndef UseSwitchToThread}

  nop

  {$endif}

{$else}

  {Couldn't grab the block type - sleep and try again}

  push InitialSleepTime

  call Sleep

  {Try again}

  mov eax, $100

  {Attempt to grab the block type}

  lock cmpxchg TSmallBlockType([ebx]).BlockTypeLocked, ah

  je @GotLockOnSmallBlockType

  {Couldn't grab the block type - sleep and try again}

  push AdditionalSleepTime

  call Sleep

  {Try again}

  jmp @LockBlockTypeLoop

  {Align branch target}

  nop

  nop

  nop

{$endif}

@AllocateSmallBlockPool:

  {save additional registers}

  push esi

  push edi

  {Do we need to lock the medium blocks?}

{$ifndef AssumeMultiThreaded}

  cmp IsMultiThread, False

  je @MediumBlocksLockedForPool

{$endif}

  call LockMediumBlocks

@MediumBlocksLockedForPool:

  {Are there any available blocks of a suitable size?}

  movsx esi, TSmallBlockType[ebx].AllowedGroupsForBlockPoolBitmap

  and esi, MediumBlockBinGroupBitmap

  jz @NoSuitableMediumBlocks

  {Get the bin group number with free blocks in eax}

  bsf eax, esi

  {Get the bin number in ecx}

  lea esi, [eax * 8]

  mov ecx, dword ptr [MediumBlockBinBitmaps + eax * 4]

  bsf ecx, ecx

  lea ecx, [ecx + esi * 4]

  {Get a pointer to the bin in edi}

  lea edi, [MediumBlockBins + ecx * 8]

  {Get the free block in esi}

  mov esi, TMediumFreeBlock[edi].NextFreeBlock

  {Remove the first block from the linked list (LIFO)}

  mov edx, TMediumFreeBlock[esi].NextFreeBlock

  mov TMediumFreeBlock[edi].NextFreeBlock, edx

  mov TMediumFreeBlock[edx].PreviousFreeBlock, edi

  {Is this bin now empty?}

  cmp edi, edx

  jne @MediumBinNotEmpty

  {eax = bin group number, ecx = bin number, edi = @bin, esi = free block, ebx = block type}

  {Flag this bin as empty}

  mov edx, -2

  rol edx, cl

  and dword ptr [MediumBlockBinBitmaps + eax * 4], edx

  jnz @MediumBinNotEmpty

  {Flag the group as empty}

  btr MediumBlockBinGroupBitmap, eax

@MediumBinNotEmpty:

  {esi = free block, ebx = block type}

  {Get the size of the available medium block in edi}

  mov edi, DropMediumAndLargeFlagsMask

  and edi, [esi - 4]

  cmp edi, MaximumSmallBlockPoolSize

  jb @UseWholeBlock

  {Split the block: get the size of the second part, new block size is the

   optimal size}

  mov edx, edi

  movzx edi, TSmallBlockType[ebx].OptimalBlockPoolSize

  sub edx, edi

  {Split the block in two}

  lea eax, [esi + edi]

  lea ecx, [edx + IsMediumBlockFlag + IsFreeBlockFlag]

  mov [eax - 4], ecx

  {Store the size of the second split as the second last dword}

  mov [eax + edx - 8], edx

  {Put the remainder in a bin (it will be big enough)}

  call InsertMediumBlockIntoBin

  jmp @GotMediumBlock

  {Align branch target}

{$ifdef AssumeMultiThreaded}

  nop

{$endif}

@NoSuitableMediumBlocks:

  {Check the sequential feed medium block pool for space}

  movzx ecx, TSmallBlockType[ebx].MinimumBlockPoolSize

  mov edi, MediumSequentialFeedBytesLeft

  cmp edi, ecx

  jb @AllocateNewSequentialFeed

  {Get the address of the last block that was fed}

  mov esi, LastSequentiallyFedMediumBlock

  {Enough sequential feed space: Will the remainder be usable?}

  movzx ecx, TSmallBlockType[ebx].OptimalBlockPoolSize

  lea edx, [ecx + MinimumMediumBlockSize]

  cmp edi, edx

  jb @NotMuchSpace

  mov edi, ecx

@NotMuchSpace:

  sub esi, edi

  {Update the sequential feed parameters}

  sub MediumSequentialFeedBytesLeft, edi

  mov LastSequentiallyFedMediumBlock, esi

  {Get the block pointer}

  jmp @GotMediumBlock

  {Align branch target}

@AllocateNewSequentialFeed:

  {Need to allocate a new sequential feed medium block pool: use the

   optimal size for this small block pool}

  movzx eax, TSmallBlockType[ebx].OptimalBlockPoolSize

  mov edi, eax

  {Allocate the medium block pool}

  call AllocNewSequentialFeedMediumPool

  mov esi, eax

  test eax, eax

  jnz @GotMediumBlock

  mov MediumBlocksLocked, al

  mov TSmallBlockType[ebx].BlockTypeLocked, al

  pop edi

  pop esi

  pop ebx

  ret

  {Align branch target}

@UseWholeBlock:

  {esi = free block, ebx = block type, edi = block size}

  {Mark this block as used in the block following it}

  and byte ptr [esi + edi - 4], not PreviousMediumBlockIsFreeFlag

@GotMediumBlock:

  {esi = free block, ebx = block type, edi = block size}

  {Set the size and flags for this block}

  lea ecx, [edi + IsMediumBlockFlag + IsSmallBlockPoolInUseFlag]

  mov [esi - 4], ecx

  {Unlock medium blocks}

  xor eax, eax

  mov MediumBlocksLocked, al

  {Set up the block pool}

  mov TSmallBlockPoolHeader[esi].BlockType, ebx

  mov TSmallBlockPoolHeader[esi].FirstFreeBlock, eax

  mov TSmallBlockPoolHeader[esi].BlocksInUse, 1

  {Set it up for sequential block serving}

  mov TSmallBlockType[ebx].CurrentSequentialFeedPool, esi

  {Return the pointer to the first block}

  lea eax, [esi + SmallBlockPoolHeaderSize]

  movzx ecx, TSmallBlockType[ebx].BlockSize

  lea edx, [eax + ecx]

  mov TSmallBlockType[ebx].NextSequentialFeedBlockAddress, edx

  add edi, esi

  sub edi, ecx

  mov TSmallBlockType[ebx].MaxSequentialFeedBlockAddress, edi

  {Unlock the small block type}

  mov TSmallBlockType[ebx].BlockTypeLocked, False

  {Set the small block header}

  mov [eax - 4], esi

  {Restore registers}

  pop edi

  pop esi

  pop ebx

  {Done}

  ret

{-------------------Medium block allocation-------------------}

  {Align branch target}

  nop

@NotASmallBlock:

  cmp eax, (MaximumMediumBlockSize - BlockHeaderSize)

  ja @IsALargeBlockRequest

  {Get the bin size for this block size. Block sizes are

   rounded up to the next bin size.}

  lea ebx, [eax + MediumBlockGranularity - 1 + BlockHeaderSize - MediumBlockSizeOffset]

  and ebx, -MediumBlockGranularity

  add ebx, MediumBlockSizeOffset

  {Do we need to lock the medium blocks?}

{$ifndef AssumeMultiThreaded}

  test cl, cl

  jz @MediumBlocksLocked

{$endif}

  call LockMediumBlocks

@MediumBlocksLocked:

  {Get the bin number in ecx and the group number in edx}

  lea edx, [ebx - MinimumMediumBlockSize]

  mov ecx, edx

  shr edx, 8 + 5

  shr ecx, 8

  {Is there a suitable block inside this group?}

  mov eax, -1

  shl eax, cl

  and eax, dword ptr [MediumBlockBinBitmaps + edx * 4]

  jz @GroupIsEmpty

  {Get the actual bin number}

  and ecx, -32

  bsf eax, eax

  or ecx, eax

  jmp @GotBinAndGroup

  {Align branch target}

  nop

@GroupIsEmpty:

  {Try all groups greater than this group}

  mov eax, -2

  mov ecx, edx

  shl eax, cl

  and eax, MediumBlockBinGroupBitmap

  jz @TrySequentialFeedMedium

  {There is a suitable group with space: get the bin number}

  bsf edx, eax

  {Get the bin in the group with free blocks}

  mov eax, dword ptr [MediumBlockBinBitmaps + edx * 4]

  bsf ecx, eax

  mov eax, edx

  shl eax, 5

  or ecx, eax

  jmp @GotBinAndGroup

  {Align branch target}

  nop

@TrySequentialFeedMedium:

  mov ecx, MediumSequentialFeedBytesLeft

  {Block can be fed sequentially?}

  sub ecx, ebx

  jc @AllocateNewSequentialFeedForMedium

  {Get the block address}

  mov eax, LastSequentiallyFedMediumBlock

  sub eax, ebx

  mov LastSequentiallyFedMediumBlock, eax

  {Store the remaining bytes}

  mov MediumSequentialFeedBytesLeft, ecx

  {Set the flags for the block}

  or ebx, IsMediumBlockFlag

  mov [eax - 4], ebx

  jmp @MediumBlockGetDone

  {Align branch target}

@AllocateNewSequentialFeedForMedium:

  mov eax, ebx

  call AllocNewSequentialFeedMediumPool

@MediumBlockGetDone:

  mov MediumBlocksLocked, False

  pop ebx

  ret

  {Align branch target}

@GotBinAndGroup:

  {ebx = block size, ecx = bin number, edx = group number}

  push esi

  push edi

  {Get a pointer to the bin in edi}

  lea edi, [MediumBlockBins + ecx * 8]

  {Get the free block in esi}

  mov esi, TMediumFreeBlock[edi].NextFreeBlock

  {Remove the first block from the linked list (LIFO)}

  mov eax, TMediumFreeBlock[esi].NextFreeBlock

  mov TMediumFreeBlock[edi].NextFreeBlock, eax

  mov TMediumFreeBlock[eax].PreviousFreeBlock, edi

  {Is this bin now empty?}

  cmp edi, eax

  jne @MediumBinNotEmptyForMedium

  {eax = bin group number, ecx = bin number, edi = @bin, esi = free block, ebx = block size}

  {Flag this bin as empty}

  mov eax, -2

  rol eax, cl

  and dword ptr [MediumBlockBinBitmaps + edx * 4], eax

  jnz @MediumBinNotEmptyForMedium

  {Flag the group as empty}

  btr MediumBlockBinGroupBitmap, edx

@MediumBinNotEmptyForMedium:

  {esi = free block, ebx = block size}

  {Get the size of the available medium block in edi}

  mov edi, DropMediumAndLargeFlagsMask

  and edi, [esi - 4]

  {Get the size of the second split in edx}

  mov edx, edi

  sub edx, ebx

  jz @UseWholeBlockForMedium

  {Split the block in two}

  lea eax, [esi + ebx]

  lea ecx, [edx + IsMediumBlockFlag + IsFreeBlockFlag]

  mov [eax - 4], ecx

  {Store the size of the second split as the second last dword}

  mov [eax + edx - 8], edx

  {Put the remainder in a bin}

  cmp edx, MinimumMediumBlockSize

  jb @GotMediumBlockForMedium

  call InsertMediumBlockIntoBin

  jmp @GotMediumBlockForMedium

  {Align branch target}

  nop

  nop

  nop

@UseWholeBlockForMedium:

  {Mark this block as used in the block following it}

  and byte ptr [esi + edi - 4], not PreviousMediumBlockIsFreeFlag

@GotMediumBlockForMedium:

  {Set the size and flags for this block}

  lea ecx, [ebx + IsMediumBlockFlag]

  mov [esi - 4], ecx

  {Unlock medium blocks}

  mov MediumBlocksLocked, False

  mov eax, esi

  pop edi

  pop esi

  pop ebx

  ret

{-------------------Large block allocation-------------------}

  {Align branch target}

@IsALargeBlockRequest:

  pop ebx

  test eax, eax

  jns AllocateLargeBlock

  xor eax, eax

end;

{$else}

{64-bit BASM implementation}

asm

  {On entry:

    rcx = ASize}

  .params 2

  .pushnv rbx

  .pushnv rsi

  .pushnv rdi

  {Since most allocations are for small blocks, determine the small block type

   index so long}

  lea edx, [ecx + BlockHeaderSize - 1]

{$ifdef Align16Bytes}

  shr edx, 4

{$else}

  shr edx, 3

{$endif}

  {Preload the addresses of some small block structures}

  lea r8, AllocSize2SmallBlockTypeIndX4

  lea rbx, SmallBlockTypes

{$ifndef AssumeMultiThreaded}

  {Get the IsMultiThread variable so long}

  movzx esi, IsMultiThread

{$endif}

  {Is it a small block?}

  cmp rcx, (MaximumSmallBlockSize - BlockHeaderSize)

  ja @NotASmallBlock

  {Get the small block type pointer in rbx}

  movzx ecx, byte ptr [r8 + rdx]

  shl ecx, 4 //SizeOf(TSmallBlockType) = 64

  add rbx, rcx

  {Do we need to lock the block type?}

{$ifndef AssumeMultiThreaded}

  test esi, esi

  jnz @LockBlockTypeLoop

{$else}

  jmp @LockBlockTypeLoop

{$endif}

@GotLockOnSmallBlockType:

  {Find the next free block: Get the first pool with free blocks in rdx}

  mov rdx, TSmallBlockType[rbx].NextPartiallyFreePool

  {Get the first free block (or the next sequential feed address if rdx = rbx)}

  mov rax, TSmallBlockPoolHeader[rdx].FirstFreeBlock

  {Get the drop flags mask in rcx so long}

  mov rcx, DropSmallFlagsMask

  {Is there a pool with free blocks?}

  cmp rdx, rbx

  je @TrySmallSequentialFeed

  {Increment the number of used blocks}

  add TSmallBlockPoolHeader[rdx].BlocksInUse, 1

  {Get the new first free block}

  and rcx, [rax - BlockHeaderSize]

  {Set the new first free block}

  mov TSmallBlockPoolHeader[rdx].FirstFreeBlock, rcx

  {Set the block header}

  mov [rax - BlockHeaderSize], rdx

  {Is the chunk now full?}

  jz @RemoveSmallPool

  {Unlock the block type}

  mov TSmallBlockType[rbx].BlockTypeLocked, False

  jmp @Done

@TrySmallSequentialFeed:

  {Try to feed a small block sequentially: Get the sequential feed block pool}

  mov rdx, TSmallBlockType[rbx].CurrentSequentialFeedPool

  {Get the next sequential feed address so long}

  movzx ecx, TSmallBlockType[rbx].BlockSize

  add rcx, rax

  {Can another block fit?}

  cmp rax, TSmallBlockType[rbx].MaxSequentialFeedBlockAddress

  ja @AllocateSmallBlockPool

  {Increment the number of used blocks in the sequential feed pool}

  add TSmallBlockPoolHeader[rdx].BlocksInUse, 1

  {Store the next sequential feed block address}

  mov TSmallBlockType[rbx].NextSequentialFeedBlockAddress, rcx

  {Unlock the block type}

  mov TSmallBlockType[rbx].BlockTypeLocked, False

  {Set the block header}

  mov [rax - BlockHeaderSize], rdx

  jmp @Done

@RemoveSmallPool:

  {Pool is full - remove it from the partially free list}

  mov rcx, TSmallBlockPoolHeader[rdx].NextPartiallyFreePool

  mov TSmallBlockPoolHeader[rcx].PreviousPartiallyFreePool, rbx

  mov TSmallBlockType[rbx].NextPartiallyFreePool, rcx

  {Unlock the block type}

  mov TSmallBlockType[rbx].BlockTypeLocked, False

  jmp @Done

@LockBlockTypeLoop:

  mov eax, $100

  {Attempt to grab the block type}

  lock cmpxchg TSmallBlockType([rbx]).BlockTypeLocked, ah

  je @GotLockOnSmallBlockType

  {Try the next size}

  add rbx, Type(TSmallBlockType)

  mov eax, $100

  lock cmpxchg TSmallBlockType([rbx]).BlockTypeLocked, ah

  je @GotLockOnSmallBlockType

  {Try the next size (up to two sizes larger)}

  add rbx, Type(TSmallBlockType)

  mov eax, $100

  lock cmpxchg TSmallBlockType([rbx]).BlockTypeLocked, ah

  je @GotLockOnSmallBlockType

  {Block type and two sizes larger are all locked - give up and sleep}

  sub rbx, 2 * Type(TSmallBlockType)

{$ifdef NeverSleepOnThreadContention}

  {Pause instruction (improves performance on P4)}

  pause

  {$ifdef UseSwitchToThread}

  call SwitchToThread

  {$endif}

  {Try again}

  jmp @LockBlockTypeLoop

{$else}

  {Couldn't grab the block type - sleep and try again}

  mov ecx, InitialSleepTime

  call Sleep

  {Try again}

  mov eax, $100

  {Attempt to grab the block type}

  lock cmpxchg TSmallBlockType([rbx]).BlockTypeLocked, ah

  je @GotLockOnSmallBlockType

  {Couldn't grab the block type - sleep and try again}

  mov ecx, AdditionalSleepTime

  call Sleep

  {Try again}

  jmp @LockBlockTypeLoop

{$endif}

@AllocateSmallBlockPool:

  {Do we need to lock the medium blocks?}

{$ifndef AssumeMultiThreaded}

  test esi, esi

  jz @MediumBlocksLockedForPool

{$endif}

  call LockMediumBlocks

@MediumBlocksLockedForPool:

  {Are there any available blocks of a suitable size?}

  movsx esi, TSmallBlockType[rbx].AllowedGroupsForBlockPoolBitmap

  and esi, MediumBlockBinGroupBitmap

  jz @NoSuitableMediumBlocks

  {Get the bin group number with free blocks in eax}

  bsf eax, esi

  {Get the bin number in ecx}

  lea r8, MediumBlockBinBitmaps

  lea r9, [rax * 4]

  mov ecx, [r8 + r9]

  bsf ecx, ecx

  lea ecx, [ecx + r9d * 8]

  {Get a pointer to the bin in edi}

  lea rdi, MediumBlockBins

  lea esi, [ecx * 8]

  lea rdi, [rdi + rsi * 2] //SizeOf(TMediumBlockBin) = 16

  {Get the free block in rsi}

  mov rsi, TMediumFreeBlock[rdi].NextFreeBlock

  {Remove the first block from the linked list (LIFO)}

  mov rdx, TMediumFreeBlock[rsi].NextFreeBlock

  mov TMediumFreeBlock[rdi].NextFreeBlock, rdx

  mov TMediumFreeBlock[rdx].PreviousFreeBlock, rdi

  {Is this bin now empty?}

  cmp rdi, rdx

  jne @MediumBinNotEmpty

  {r8 = @MediumBlockBinBitmaps, eax = bin group number,

   r9 = bin group number * 4, ecx = bin number, edi = @bin, esi = free block,

   ebx = block type}

  {Flag this bin as empty}

  mov edx, -2

  rol edx, cl

  and [r8 + r9], edx

  jnz @MediumBinNotEmpty

  {Flag the group as empty}

  btr MediumBlockBinGroupBitmap, eax

@MediumBinNotEmpty:

  {esi = free block, ebx = block type}

  {Get the size of the available medium block in edi}

  mov rdi, DropMediumAndLargeFlagsMask

  and rdi, [rsi - BlockHeaderSize]

  cmp edi, MaximumSmallBlockPoolSize

  jb @UseWholeBlock

  {Split the block: get the size of the second part, new block size is the

   optimal size}

  mov edx, edi

  movzx edi, TSmallBlockType[rbx].OptimalBlockPoolSize

  sub edx, edi

  {Split the block in two}

  lea rcx, [rsi + rdi]

  lea rax, [rdx + IsMediumBlockFlag + IsFreeBlockFlag]

  mov [rcx - BlockHeaderSize], rax

  {Store the size of the second split as the second last qword}

  mov [rcx + rdx - BlockHeaderSize * 2], rdx

  {Put the remainder in a bin (it will be big enough)}

  call InsertMediumBlockIntoBin

  jmp @GotMediumBlock

@NoSuitableMediumBlocks:

  {Check the sequential feed medium block pool for space}

  movzx ecx, TSmallBlockType[rbx].MinimumBlockPoolSize

  mov edi, MediumSequentialFeedBytesLeft

  cmp edi, ecx

  jb @AllocateNewSequentialFeed

  {Get the address of the last block that was fed}

  mov rsi, LastSequentiallyFedMediumBlock

  {Enough sequential feed space: Will the remainder be usable?}

  movzx ecx, TSmallBlockType[rbx].OptimalBlockPoolSize

  lea edx, [ecx + MinimumMediumBlockSize]

  cmp edi, edx

  jb @NotMuchSpace

  mov edi, ecx

@NotMuchSpace:

  sub rsi, rdi

  {Update the sequential feed parameters}

  sub MediumSequentialFeedBytesLeft, edi

  mov LastSequentiallyFedMediumBlock, rsi

  {Get the block pointer}

  jmp @GotMediumBlock

  {Align branch target}

@AllocateNewSequentialFeed:

  {Need to allocate a new sequential feed medium block pool: use the

   optimal size for this small block pool}

  movzx ecx, TSmallBlockType[rbx].OptimalBlockPoolSize

  mov edi, ecx

  {Allocate the medium block pool}

  call AllocNewSequentialFeedMediumPool

  mov rsi, rax

  test rax, rax

  jnz @GotMediumBlock

  mov MediumBlocksLocked, al

  mov TSmallBlockType[rbx].BlockTypeLocked, al

  jmp @Done

@UseWholeBlock:

  {rsi = free block, rbx = block type, edi = block size}

  {Mark this block as used in the block following it}

  and byte ptr [rsi + rdi - BlockHeaderSize], not PreviousMediumBlockIsFreeFlag

@GotMediumBlock:

  {rsi = free block, rbx = block type, edi = block size}

  {Set the size and flags for this block}

  lea ecx, [edi + IsMediumBlockFlag + IsSmallBlockPoolInUseFlag]

  mov [rsi - BlockHeaderSize], rcx

  {Unlock medium blocks}

  xor eax, eax

  mov MediumBlocksLocked, al

  {Set up the block pool}

  mov TSmallBlockPoolHeader[rsi].BlockType, rbx

  mov TSmallBlockPoolHeader[rsi].FirstFreeBlock, rax

  mov TSmallBlockPoolHeader[rsi].BlocksInUse, 1

  {Set it up for sequential block serving}

  mov TSmallBlockType[rbx].CurrentSequentialFeedPool, rsi

  {Return the pointer to the first block}

  lea rax, [rsi + SmallBlockPoolHeaderSize]

  movzx ecx, TSmallBlockType[rbx].BlockSize

  lea rdx, [rax + rcx]

  mov TSmallBlockType[rbx].NextSequentialFeedBlockAddress, rdx

  add rdi, rsi

  sub rdi, rcx

  mov TSmallBlockType[rbx].MaxSequentialFeedBlockAddress, rdi

  {Unlock the small block type}

  mov TSmallBlockType[rbx].BlockTypeLocked, False

  {Set the small block header}

  mov [rax - BlockHeaderSize], rsi

  jmp @Done

{-------------------Medium block allocation-------------------}

@NotASmallBlock:

  cmp rcx, (MaximumMediumBlockSize - BlockHeaderSize)

  ja @IsALargeBlockRequest

  {Get the bin size for this block size. Block sizes are

   rounded up to the next bin size.}

  lea ebx, [ecx + MediumBlockGranularity - 1 + BlockHeaderSize - MediumBlockSizeOffset]

  and ebx, -MediumBlockGranularity

  add ebx, MediumBlockSizeOffset

  {Do we need to lock the medium blocks?}

{$ifndef AssumeMultiThreaded}

  test esi, esi

  jz @MediumBlocksLocked

{$endif}

  call LockMediumBlocks

@MediumBlocksLocked:

  {Get the bin number in ecx and the group number in edx}

  lea edx, [ebx - MinimumMediumBlockSize]

  mov ecx, edx

  shr edx, 8 + 5

  shr ecx, 8

  {Is there a suitable block inside this group?}

  mov eax, -1

  shl eax, cl

  lea r8, MediumBlockBinBitmaps

  and eax, [r8 + rdx * 4]

  jz @GroupIsEmpty

  {Get the actual bin number}

  and ecx, -32

  bsf eax, eax

  or ecx, eax

  jmp @GotBinAndGroup

@GroupIsEmpty:

  {Try all groups greater than this group}

  mov eax, -2

  mov ecx, edx

  shl eax, cl

  and eax, MediumBlockBinGroupBitmap

  jz @TrySequentialFeedMedium

  {There is a suitable group with space: get the bin number}

  bsf edx, eax

  {Get the bin in the group with free blocks}

  mov eax, [r8 + rdx * 4]

  bsf ecx, eax

  mov eax, edx

  shl eax, 5

  or ecx, eax

  jmp @GotBinAndGroup

@TrySequentialFeedMedium:

  mov ecx, MediumSequentialFeedBytesLeft

  {Block can be fed sequentially?}

  sub ecx, ebx

  jc @AllocateNewSequentialFeedForMedium

  {Get the block address}

  mov rax, LastSequentiallyFedMediumBlock

  sub rax, rbx

  mov LastSequentiallyFedMediumBlock, rax

  {Store the remaining bytes}

  mov MediumSequentialFeedBytesLeft, ecx

  {Set the flags for the block}

  or rbx, IsMediumBlockFlag

  mov [rax - BlockHeaderSize], rbx

  jmp @MediumBlockGetDone

@AllocateNewSequentialFeedForMedium:

  mov ecx, ebx

  call AllocNewSequentialFeedMediumPool

@MediumBlockGetDone:

  xor cl, cl

  mov MediumBlocksLocked, cl //workaround for QC99023

  jmp @Done

@GotBinAndGroup:

  {ebx = block size, ecx = bin number, edx = group number}

  {Get a pointer to the bin in edi}

  lea rdi, MediumBlockBins

  lea eax, [ecx + ecx]

  lea rdi, [rdi + rax * 8]

  {Get the free block in esi}

  mov rsi, TMediumFreeBlock[rdi].NextFreeBlock

  {Remove the first block from the linked list (LIFO)}

  mov rax, TMediumFreeBlock[rsi].NextFreeBlock

  mov TMediumFreeBlock[rdi].NextFreeBlock, rax

  mov TMediumFreeBlock[rax].PreviousFreeBlock, rdi

  {Is this bin now empty?}

  cmp rdi, rax

  jne @MediumBinNotEmptyForMedium

  {edx = bin group number, ecx = bin number, rdi = @bin, rsi = free block, ebx = block size}

  {Flag this bin as empty}

  mov eax, -2

  rol eax, cl

  lea r8, MediumBlockBinBitmaps

  and [r8 + rdx * 4], eax

  jnz @MediumBinNotEmptyForMedium

  {Flag the group as empty}

  btr MediumBlockBinGroupBitmap, edx

@MediumBinNotEmptyForMedium:

  {rsi = free block, ebx = block size}

  {Get the size of the available medium block in edi}

  mov rdi, DropMediumAndLargeFlagsMask

  and rdi, [rsi - BlockHeaderSize]

  {Get the size of the second split in edx}

  mov edx, edi

  sub edx, ebx

  jz @UseWholeBlockForMedium

  {Split the block in two}

  lea rcx, [rsi + rbx]

  lea rax, [rdx + IsMediumBlockFlag + IsFreeBlockFlag]

  mov [rcx - BlockHeaderSize], rax

  {Store the size of the second split as the second last dword}

  mov [rcx + rdx - BlockHeaderSize * 2], rdx

  {Put the remainder in a bin}

  cmp edx, MinimumMediumBlockSize

  jb @GotMediumBlockForMedium

  call InsertMediumBlockIntoBin

  jmp @GotMediumBlockForMedium

@UseWholeBlockForMedium:

  {Mark this block as used in the block following it}

  and byte ptr [rsi + rdi - BlockHeaderSize], not PreviousMediumBlockIsFreeFlag

@GotMediumBlockForMedium:

  {Set the size and flags for this block}

  lea rcx, [rbx + IsMediumBlockFlag]

  mov [rsi - BlockHeaderSize], rcx

  {Unlock medium blocks}

  xor cl, cl

  mov MediumBlocksLocked, cl //workaround for QC99023

  mov rax, rsi

  jmp @Done

{-------------------Large block allocation-------------------}

@IsALargeBlockRequest:

  xor rax, rax

  test rcx, rcx

  js @Done

  call AllocateLargeBlock

@Done:

end;

{$endif}

{$endif}



{$ifndef ASMVersion}

{Frees a medium block, returning 0 on success, -1 otherwise}

function FreeMediumBlock(APointer: Pointer): Integer;

var

  LNextMediumBlock{$ifndef FullDebugMode}, LPreviousMediumBlock{$endif}: PMediumFreeBlock;

  LNextMediumBlockSizeAndFlags: NativeUInt;

  LBlockSize{$ifndef FullDebugMode}, LPreviousMediumBlockSize{$endif}: Cardinal;

{$ifndef FullDebugMode}

  LPPreviousMediumBlockPoolHeader, LPNextMediumBlockPoolHeader: PMediumBlockPoolHeader;

{$endif}

  LBlockHeader: NativeUInt;

begin

  {Get the block header}

  LBlockHeader := PNativeUInt(PByte(APointer) - BlockHeaderSize)^;

  {Get the medium block size}

  LBlockSize := LBlockHeader and DropMediumAndLargeFlagsMask;

  {Lock the medium blocks}

  LockMediumBlocks;

  {Can we combine this block with the next free block?}

  LNextMediumBlock := PMediumFreeBlock(PByte(APointer) + LBlockSize);

  LNextMediumBlockSizeAndFlags := PNativeUInt(PByte(LNextMediumBlock) - BlockHeaderSize)^;

{$ifndef FullDebugMode}

{$ifdef CheckHeapForCorruption}

  {Check that this block was flagged as in use in the next block}

  if (LNextMediumBlockSizeAndFlags and PreviousMediumBlockIsFreeFlag) <> 0 then

{$ifdef BCB6OrDelphi7AndUp}

    System.Error(reInvalidPtr);

{$else}

    System.RunError(reInvalidPtr);

{$endif}

{$endif}

  if (LNextMediumBlockSizeAndFlags and IsFreeBlockFlag) <> 0 then

  begin

    {Increase the size of this block}

    Inc(LBlockSize, LNextMediumBlockSizeAndFlags and DropMediumAndLargeFlagsMask);

    {Remove the next block as well}

    if LNextMediumBlockSizeAndFlags >= MinimumMediumBlockSize then

      RemoveMediumFreeBlock(LNextMediumBlock);

  end

  else

  begin

{$endif}

    {Reset the "previous in use" flag of the next block}

    PNativeUInt(PByte(LNextMediumBlock) - BlockHeaderSize)^ := LNextMediumBlockSizeAndFlags or PreviousMediumBlockIsFreeFlag;

{$ifndef FullDebugMode}

  end;

  {Can we combine this block with the previous free block? We need to

   re-read the flags since it could have changed before we could lock the

   medium blocks.}

  if (PNativeUInt(PByte(APointer) - BlockHeaderSize)^ and PreviousMediumBlockIsFreeFlag) <> 0 then

  begin

    {Get the size of the free block just before this one}

    LPreviousMediumBlockSize := PNativeUInt(PByte(APointer) - 2 * BlockHeaderSize)^;

    {Get the start of the previous block}

    LPreviousMediumBlock := PMediumFreeBlock(PByte(APointer) - LPreviousMediumBlockSize);

{$ifdef CheckHeapForCorruption}

    {Check that the previous block is actually free}

    if (PNativeUInt(PByte(LPreviousMediumBlock) - BlockHeaderSize)^ and ExtractMediumAndLargeFlagsMask) <> (IsMediumBlockFlag or IsFreeBlockFlag) then

{$ifdef BCB6OrDelphi7AndUp}

    System.Error(reInvalidPtr);

{$else}

    System.RunError(reInvalidPtr);

{$endif}

{$endif}

    {Set the new block size}

    Inc(LBlockSize, LPreviousMediumBlockSize);

    {This is the new current block}

    APointer := LPreviousMediumBlock;

    {Remove the previous block from the linked list}

    if LPreviousMediumBlockSize >= MinimumMediumBlockSize then

      RemoveMediumFreeBlock(LPreviousMediumBlock);

  end;

{$ifdef CheckHeapForCorruption}

  {Check that the previous block is currently flagged as in use}

  if (PNativeUInt(PByte(APointer) - BlockHeaderSize)^ and PreviousMediumBlockIsFreeFlag) <> 0 then

{$ifdef BCB6OrDelphi7AndUp}

    System.Error(reInvalidPtr);

{$else}

    System.RunError(reInvalidPtr);

{$endif}

{$endif}

  {Is the entire medium block pool free, and there are other free blocks

   that can fit the largest possible medium block? -> free it. (Except in

   full debug mode where medium pools are never freed.)}

  if (LBlockSize <> (MediumBlockPoolSize - MediumBlockPoolHeaderSize)) then

  begin

    {Store the size of the block as well as the flags}

    PNativeUInt(PByte(APointer) - BlockHeaderSize)^ := LBlockSize or (IsMediumBlockFlag or IsFreeBlockFlag);

{$else}

    {Mark the block as free}

    Inc(PNativeUInt(PByte(APointer) - BlockHeaderSize)^, IsFreeBlockFlag);

{$endif}

    {Store the trailing size marker}

    PNativeUInt(PByte(APointer) + LBlockSize - 2 * BlockHeaderSize)^ := LBlockSize;

    {Insert this block back into the bins: Size check not required here,

     since medium blocks that are in use are not allowed to be

     shrunk smaller than MinimumMediumBlockSize}

    InsertMediumBlockIntoBin(APointer, LBlockSize);

{$ifndef FullDebugMode}

{$ifdef CheckHeapForCorruption}

    {Check that this block is actually free and the next and previous blocks are both in use.}

    if ((PNativeUInt(PByte(APointer) - BlockHeaderSize)^ and ExtractMediumAndLargeFlagsMask) <> (IsMediumBlockFlag or IsFreeBlockFlag))

      or ((PNativeUInt(PByte(APointer) + (PNativeUInt(PByte(APointer) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask) - BlockHeaderSize)^ and IsFreeBlockFlag) <> 0) then

    begin

{$ifdef BCB6OrDelphi7AndUp}

    System.Error(reInvalidPtr);

{$else}

    System.RunError(reInvalidPtr);

{$endif}

    end;

{$endif}

{$endif}

    {Unlock medium blocks}

    MediumBlocksLocked := False;

    {All OK}

    Result := 0;

{$ifndef FullDebugMode}

  end

  else

  begin

    {Should this become the new sequential feed?}

    if MediumSequentialFeedBytesLeft <> MediumBlockPoolSize - MediumBlockPoolHeaderSize then

    begin

      {Bin the current sequential feed}

      BinMediumSequentialFeedRemainder;

      {Set this medium pool up as the new sequential feed pool:

       Store the sequential feed pool trailer}

      PNativeUInt(PByte(APointer) + LBlockSize - BlockHeaderSize)^ := IsMediumBlockFlag;

      {Store the number of bytes available in the sequential feed chunk}

      MediumSequentialFeedBytesLeft := MediumBlockPoolSize - MediumBlockPoolHeaderSize;

      {Set the last sequentially fed block}

      LastSequentiallyFedMediumBlock := Pointer(PByte(APointer) + LBlockSize);

      {Unlock medium blocks}

      MediumBlocksLocked := False;

      {Success}

      Result := 0;

    end

    else

    begin

      {Remove this medium block pool from the linked list}

      Dec(PByte(APointer), MediumBlockPoolHeaderSize);

      LPPreviousMediumBlockPoolHeader := PMediumBlockPoolHeader(APointer).PreviousMediumBlockPoolHeader;

      LPNextMediumBlockPoolHeader := PMediumBlockPoolHeader(APointer).NextMediumBlockPoolHeader;

      LPPreviousMediumBlockPoolHeader.NextMediumBlockPoolHeader := LPNextMediumBlockPoolHeader;

      LPNextMediumBlockPoolHeader.PreviousMediumBlockPoolHeader := LPPreviousMediumBlockPoolHeader;

      {Unlock medium blocks}

      MediumBlocksLocked := False;

{$ifdef ClearMediumBlockPoolsBeforeReturningToOS}

      FillChar(APointer^, MediumBlockPoolSize, 0);

{$endif}

      {Free the medium block pool}

      if VirtualFree(APointer, 0, MEM_RELEASE) then

        Result := 0

      else

        Result := -1;

    end;

  end;

{$endif}

end;

{$endif}



{Replacement for SysFreeMem}

function FastFreeMem(APointer: Pointer): Integer;

{$ifndef ASMVersion}

var

  LPSmallBlockPool{$ifndef FullDebugMode}, LPPreviousPool, LPNextPool{$endif},

    LPOldFirstPool: PSmallBlockPoolHeader;

  LPSmallBlockType: PSmallBlockType;

  LOldFirstFreeBlock: Pointer;

  LBlockHeader: NativeUInt;

begin

  {Get the small block header: Is it actually a small block?}

  LBlockHeader := PNativeUInt(PByte(APointer) - BlockHeaderSize)^;

  {Is it a small block that is in use?}

  if LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag or IsLargeBlockFlag) = 0 then

  begin

    {Get a pointer to the block pool}

    LPSmallBlockPool := PSmallBlockPoolHeader(LBlockHeader);

    {Get the block type}

    LPSmallBlockType := LPSmallBlockPool.BlockType;

{$ifdef ClearSmallAndMediumBlocksInFreeMem}

    FillChar(APointer^, LPSmallBlockType.BlockSize - BlockHeaderSize, 0);

{$endif}

    {Lock the block type}

{$ifndef AssumeMultiThreaded}

    if IsMultiThread then

{$endif}

    begin

      while (LockCmpxchg(0, 1, @LPSmallBlockType.BlockTypeLocked) <> 0) do

      begin

{$ifdef NeverSleepOnThreadContention}

  {$ifdef UseSwitchToThread}

        SwitchToThread;

  {$endif}

{$else}

        Sleep(InitialSleepTime);

        if LockCmpxchg(0, 1, @LPSmallBlockType.BlockTypeLocked) = 0 then

          Break;

        Sleep(AdditionalSleepTime);

{$endif}

      end;

    end;

    {Get the old first free block}

    LOldFirstFreeBlock := LPSmallBlockPool.FirstFreeBlock;

    {Was the pool manager previously full?}

    if LOldFirstFreeBlock = nil then

    begin

      {Insert this as the first partially free pool for the block size}

      LPOldFirstPool := LPSmallBlockType.NextPartiallyFreePool;

      LPSmallBlockPool.NextPartiallyFreePool := LPOldFirstPool;

      LPOldFirstPool.PreviousPartiallyFreePool := LPSmallBlockPool;

      LPSmallBlockPool.PreviousPartiallyFreePool := PSmallBlockPoolHeader(LPSmallBlockType);

      LPSmallBlockType.NextPartiallyFreePool := LPSmallBlockPool;

    end;

    {Store the old first free block}

    PNativeUInt(PByte(APointer) - BlockHeaderSize)^ := UIntPtr(LOldFirstFreeBlock) or IsFreeBlockFlag;

    {Store this as the new first free block}

    LPSmallBlockPool.FirstFreeBlock := APointer;

    {Decrement the number of allocated blocks}

    Dec(LPSmallBlockPool.BlocksInUse);

    {Small block pools are never freed in full debug mode. This increases the

     likehood of success in catching objects still being used after being

     destroyed.}

{$ifndef FullDebugMode}

    {Is the entire pool now free? -> Free it.}

    if LPSmallBlockPool.BlocksInUse = 0 then

    begin

      {Get the previous and next chunk managers}

      LPPreviousPool := LPSmallBlockPool.PreviousPartiallyFreePool;

      LPNextPool := LPSmallBlockPool.NextPartiallyFreePool;

      {Remove this manager}

      LPPreviousPool.NextPartiallyFreePool := LPNextPool;

      LPNextPool.PreviousPartiallyFreePool := LPPreviousPool;

      {Is this the sequential feed pool? If so, stop sequential feeding}

      if (LPSmallBlockType.CurrentSequentialFeedPool = LPSmallBlockPool) then

        LPSmallBlockType.MaxSequentialFeedBlockAddress := nil;

      {Unlock this block type}

      LPSmallBlockType.BlockTypeLocked := False;

      {Free the block pool}

      FreeMediumBlock(LPSmallBlockPool);

    end

    else

    begin

{$endif}

      {Unlock this block type}

      LPSmallBlockType.BlockTypeLocked := False;

{$ifndef FullDebugMode}

    end;

{$endif}

    {No error}

    Result := 0;

  end

  else

  begin

    {Is this a medium block or a large block?}

    if LBlockHeader and (IsFreeBlockFlag or IsLargeBlockFlag) = 0 then

    begin

{$ifdef ClearSmallAndMediumBlocksInFreeMem}

      {Get the block header, extract the block size and clear the block it.}

      LBlockHeader := PNativeUInt(PByte(APointer) - BlockHeaderSize)^;

      FillChar(APointer^,

        (LBlockHeader and DropMediumAndLargeFlagsMask) - BlockHeaderSize, 0);

{$endif}

      Result := FreeMediumBlock(APointer);

    end

    else

    begin

      {Validate: Is this actually a Large block, or is it an attempt to free an

       already freed small block?}

      if LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag) = 0 then

        Result := FreeLargeBlock(APointer)

      else

        Result := -1;

    end;

  end;

end;

{$else}

{$ifdef 32Bit}

asm

  {Get the block header in edx}

  mov edx, [eax - 4]

  {Is it a small block in use?}

  test dl, IsFreeBlockFlag + IsMediumBlockFlag + IsLargeBlockFlag

  {Save the pointer in ecx}

  mov ecx, eax

  {Save ebx}

  push ebx

  {Get the IsMultiThread variable in bl}

{$ifndef AssumeMultiThreaded}

  mov bl, IsMultiThread

{$endif}

  {Is it a small block that is in use?}

  jnz @NotSmallBlockInUse

{$ifdef ClearSmallAndMediumBlocksInFreeMem}

  push edx

  push ecx

  mov edx, TSmallBlockPoolHeader[edx].BlockType

  movzx edx, TSmallBlockType(edx).BlockSize

  sub edx, BlockHeaderSize

  xor ecx, ecx

  call System.@FillChar

  pop ecx

  pop edx

{$endif}

  {Do we need to lock the block type?}

{$ifndef AssumeMultiThreaded}

  test bl, bl

{$endif}

  {Get the small block type in ebx}

  mov ebx, TSmallBlockPoolHeader[edx].BlockType

  {Do we need to lock the block type?}

{$ifndef AssumeMultiThreaded}

  jnz @LockBlockTypeLoop

{$else}

  jmp @LockBlockTypeLoop

  {Align branch target}

  nop

{$endif}

@GotLockOnSmallBlockType:

  {Current state: edx = @SmallBlockPoolHeader, ecx = APointer, ebx = @SmallBlockType}

  {Decrement the number of blocks in use}

  sub TSmallBlockPoolHeader[edx].BlocksInUse, 1

  {Get the old first free block}

  mov eax, TSmallBlockPoolHeader[edx].FirstFreeBlock

  {Is the pool now empty?}

  jz @PoolIsNowEmpty

  {Was the pool full?}

  test eax, eax

  {Store this as the new first free block}

  mov TSmallBlockPoolHeader[edx].FirstFreeBlock, ecx

  {Store the previous first free block as the block header}

  lea eax, [eax + IsFreeBlockFlag]

  mov [ecx - 4], eax

  {Insert the pool back into the linked list if it was full}

  jz @SmallPoolWasFull

  {All ok}

  xor eax, eax

  {Unlock the block type}

  mov TSmallBlockType[ebx].BlockTypeLocked, al

  {Restore registers}

  pop ebx

  {Done}

  ret

  {Align branch target}

{$ifndef AssumeMultiThreaded}

  nop

{$endif}

@SmallPoolWasFull:

  {Insert this as the first partially free pool for the block size}

  mov ecx, TSmallBlockType[ebx].NextPartiallyFreePool

  mov TSmallBlockPoolHeader[edx].PreviousPartiallyFreePool, ebx

  mov TSmallBlockPoolHeader[edx].NextPartiallyFreePool, ecx

  mov TSmallBlockPoolHeader[ecx].PreviousPartiallyFreePool, edx

  mov TSmallBlockType[ebx].NextPartiallyFreePool, edx

  {Unlock the block type}

  mov TSmallBlockType[ebx].BlockTypeLocked, False

  {All ok}

  xor eax, eax

  {Restore registers}

  pop ebx

  {Done}

  ret

  {Align branch target}

  nop

  nop

@PoolIsNowEmpty:

  {Was this pool actually in the linked list of pools with space? If not, it

   can only be the sequential feed pool (it is the only pool that may contain

   only one block, i.e. other blocks have not been split off yet)}

  test eax, eax

  jz @IsSequentialFeedPool

  {Pool is now empty: Remove it from the linked list and free it}

  mov eax, TSmallBlockPoolHeader[edx].PreviousPartiallyFreePool

  mov ecx, TSmallBlockPoolHeader[edx].NextPartiallyFreePool

  {Remove this manager}

  mov TSmallBlockPoolHeader[eax].NextPartiallyFreePool, ecx

  mov TSmallBlockPoolHeader[ecx].PreviousPartiallyFreePool, eax

  {Zero out eax}

  xor eax, eax

  {Is this the sequential feed pool? If so, stop sequential feeding}

  cmp TSmallBlockType[ebx].CurrentSequentialFeedPool, edx

  jne @NotSequentialFeedPool

@IsSequentialFeedPool:

  mov TSmallBlockType[ebx].MaxSequentialFeedBlockAddress, eax

@NotSequentialFeedPool:

  {Unlock the block type}

  mov TSmallBlockType[ebx].BlockTypeLocked, al

  {Release this pool}

  mov eax, edx

  mov edx, [edx - 4]

{$ifndef AssumeMultiThreaded}

  mov bl, IsMultiThread

{$endif}

  jmp @FreeMediumBlock

  {Align branch target}

{$ifndef AssumeMultiThreaded}

  nop

  nop

{$endif}

  nop

@LockBlockTypeLoop:

  mov eax, $100

  {Attempt to grab the block type}

  lock cmpxchg TSmallBlockType([ebx]).BlockTypeLocked, ah

  je @GotLockOnSmallBlockType

{$ifdef NeverSleepOnThreadContention}

  {Pause instruction (improves performance on P4)}

  rep nop

  {$ifdef UseSwitchToThread}

  push ecx

  push edx

  call SwitchToThread

  pop edx

  pop ecx

  {$endif}

  {Try again}

  jmp @LockBlockTypeLoop

  {Align branch target}

  {$ifndef UseSwitchToThread}

  nop

  {$endif}

{$else}

  {Couldn't grab the block type - sleep and try again}

  push ecx

  push edx

  push InitialSleepTime

  call Sleep

  pop edx

  pop ecx

  {Try again}

  mov eax, $100

  {Attempt to grab the block type}

  lock cmpxchg TSmallBlockType([ebx]).BlockTypeLocked, ah

  je @GotLockOnSmallBlockType

  {Couldn't grab the block type - sleep and try again}

  push ecx

  push edx

  push AdditionalSleepTime

  call Sleep

  pop edx

  pop ecx

  {Try again}

  jmp @LockBlockTypeLoop

  {Align branch target}

  nop

  nop

{$endif}

  {---------------------Medium blocks------------------------------}

  {Align branch target}

@NotSmallBlockInUse:

  {Not a small block in use: is it a medium or large block?}

  test dl, IsFreeBlockFlag + IsLargeBlockFlag

  jnz @NotASmallOrMediumBlock

@FreeMediumBlock:

{$ifdef ClearSmallAndMediumBlocksInFreeMem}

  push eax

  push edx

  and edx, DropMediumAndLargeFlagsMask

  sub edx, BlockHeaderSize

  xor ecx, ecx

  call System.@FillChar

  pop edx

  pop eax

{$endif}

  {Drop the flags}

  and edx, DropMediumAndLargeFlagsMask

  {Free the medium block pointed to by eax, header in edx, bl = IsMultiThread}

{$ifndef AssumeMultiThreaded}

  {Do we need to lock the medium blocks?}

  test bl, bl

{$endif}

  {Block size in ebx}

  mov ebx, edx

  {Save registers}

  push esi

  {Pointer in esi}

  mov esi, eax

  {Do we need to lock the medium blocks?}

{$ifndef AssumeMultiThreaded}

  jz @MediumBlocksLocked

{$endif}

  call LockMediumBlocks

@MediumBlocksLocked:

  {Can we combine this block with the next free block?}

  test dword ptr [esi + ebx - 4], IsFreeBlockFlag

  {Get the next block size and flags in ecx}

  mov ecx, [esi + ebx - 4]

  jnz @NextBlockIsFree

  {Set the "PreviousIsFree" flag in the next block}

  or ecx, PreviousMediumBlockIsFreeFlag

  mov [esi + ebx - 4], ecx

@NextBlockChecked:

  {Can we combine this block with the previous free block? We need to

   re-read the flags since it could have changed before we could lock the

   medium blocks.}

  test byte ptr [esi - 4], PreviousMediumBlockIsFreeFlag

  jnz @PreviousBlockIsFree

@PreviousBlockChecked:

  {Is the entire medium block pool free, and there are other free blocks

   that can fit the largest possible medium block -> free it.}

  cmp ebx, (MediumBlockPoolSize - MediumBlockPoolHeaderSize)

  je @EntireMediumPoolFree

@BinFreeMediumBlock:

  {Store the size of the block as well as the flags}

  lea eax, [ebx + IsMediumBlockFlag + IsFreeBlockFlag]

  mov [esi - 4], eax

  {Store the trailing size marker}

  mov [esi + ebx - 8], ebx

  {Insert this block back into the bins: Size check not required here,

   since medium blocks that are in use are not allowed to be

   shrunk smaller than MinimumMediumBlockSize}

  mov eax, esi

  mov edx, ebx

  {Insert into bin}

  call InsertMediumBlockIntoBin

  {Unlock medium blocks}

  mov MediumBlocksLocked, False;

  {All OK}

  xor eax, eax

  {Restore registers}

  pop esi

  pop ebx

  {Return}

  ret

  {Align branch target}

@NextBlockIsFree:

  {Get the next block address in eax}

  lea eax, [esi + ebx]

  {Increase the size of this block}

  and ecx, DropMediumAndLargeFlagsMask

  add ebx, ecx

  {Was the block binned?}

  cmp ecx, MinimumMediumBlockSize

  jb @NextBlockChecked

  call RemoveMediumFreeBlock

  jmp @NextBlockChecked

  {Align branch target}

  nop

@PreviousBlockIsFree:

  {Get the size of the free block just before this one}

  mov ecx, [esi - 8]

  {Include the previous block}

  sub esi, ecx

  {Set the new block size}

  add ebx, ecx

  {Remove the previous block from the linked list}

  cmp ecx, MinimumMediumBlockSize

  jb @PreviousBlockChecked

  mov eax, esi

  call RemoveMediumFreeBlock

  jmp @PreviousBlockChecked

  {Align branch target}

@EntireMediumPoolFree:

  {Should we make this the new sequential feed medium block pool? If the

   current sequential feed pool is not entirely free, we make this the new

   sequential feed pool.}

  cmp MediumSequentialFeedBytesLeft, MediumBlockPoolSize - MediumBlockPoolHeaderSize

  jne @MakeEmptyMediumPoolSequentialFeed

  {Point esi to the medium block pool header}

  sub esi, MediumBlockPoolHeaderSize

  {Remove this medium block pool from the linked list}

  mov eax, TMediumBlockPoolHeader[esi].PreviousMediumBlockPoolHeader

  mov edx, TMediumBlockPoolHeader[esi].NextMediumBlockPoolHeader

  mov TMediumBlockPoolHeader[eax].NextMediumBlockPoolHeader, edx

  mov TMediumBlockPoolHeader[edx].PreviousMediumBlockPoolHeader, eax

  {Unlock medium blocks}

  mov MediumBlocksLocked, False;

{$ifdef ClearMediumBlockPoolsBeforeReturningToOS}

  mov eax, esi

  mov edx, MediumBlockPoolSize

  xor ecx, ecx

  call System.@FillChar

{$endif}

  {Free the medium block pool}

  push MEM_RELEASE

  push 0

  push esi

  call VirtualFree

  {VirtualFree returns >0 if all is ok}

  cmp eax, 1

  {Return 0 on all ok}

  sbb eax, eax

  {Restore registers}

  pop esi

  pop ebx

  ret

  {Align branch target}

  nop

  nop

  nop

@MakeEmptyMediumPoolSequentialFeed:

  {Get a pointer to the end-marker block}

  lea ebx, [esi + MediumBlockPoolSize - MediumBlockPoolHeaderSize]

  {Bin the current sequential feed pool}

  call BinMediumSequentialFeedRemainder

  {Set this medium pool up as the new sequential feed pool:

   Store the sequential feed pool trailer}

  mov dword ptr [ebx - BlockHeaderSize], IsMediumBlockFlag

  {Store the number of bytes available in the sequential feed chunk}

  mov MediumSequentialFeedBytesLeft, MediumBlockPoolSize - MediumBlockPoolHeaderSize

  {Set the last sequentially fed block}

  mov LastSequentiallyFedMediumBlock, ebx

  {Unlock medium blocks}

  mov MediumBlocksLocked, False;

  {Success}

  xor eax, eax

  {Restore registers}

  pop esi

  pop ebx

  ret

  {Align branch target}

  nop

  nop

@NotASmallOrMediumBlock:

  {Restore ebx}

  pop ebx

  {Is it in fact a large block?}

  test dl, IsFreeBlockFlag + IsMediumBlockFlag

  jz FreeLargeBlock

  {Attempt to free an already free block}

  mov eax, -1

end;



{$else}



{---------------64-bit BASM FastFreeMem---------------}

asm

  .params 3

  .pushnv rbx

  .pushnv rsi

  {Get the block header in rdx}

  mov rdx, [rcx - BlockHeaderSize]

  {Is it a small block in use?}

  test dl, IsFreeBlockFlag + IsMediumBlockFlag + IsLargeBlockFlag

  {Get the IsMultiThread variable in bl}

{$ifndef AssumeMultiThreaded}

  mov bl, IsMultiThread

{$endif}

  {Is it a small block that is in use?}

  jnz @NotSmallBlockInUse

{$ifdef ClearSmallAndMediumBlocksInFreeMem}

  mov rsi, rcx

  mov rdx, TSmallBlockPoolHeader[rdx].BlockType

  movzx edx, TSmallBlockType(rdx).BlockSize

  sub edx, BlockHeaderSize

  xor r8, r8

  call System.@FillChar

  mov rcx, rsi

  mov rdx, [rcx - BlockHeaderSize]

{$endif}

  {Do we need to lock the block type?}

{$ifndef AssumeMultiThreaded}

  test bl, bl

{$endif}

  {Get the small block type in rbx}

  mov rbx, TSmallBlockPoolHeader[rdx].BlockType

  {Do we need to lock the block type?}

{$ifndef AssumeMultiThreaded}

  jnz @LockBlockTypeLoop

{$else}

  jmp @LockBlockTypeLoop

{$endif}

@GotLockOnSmallBlockType:

  {Current state: rdx = @SmallBlockPoolHeader, rcx = APointer, rbx = @SmallBlockType}

  {Decrement the number of blocks in use}

  sub TSmallBlockPoolHeader[rdx].BlocksInUse, 1

  {Get the old first free block}

  mov rax, TSmallBlockPoolHeader[rdx].FirstFreeBlock

  {Is the pool now empty?}

  jz @PoolIsNowEmpty

  {Was the pool full?}

  test rax, rax

  {Store this as the new first free block}

  mov TSmallBlockPoolHeader[rdx].FirstFreeBlock, rcx

  {Store the previous first free block as the block header}

  lea rax, [rax + IsFreeBlockFlag]

  mov [rcx - BlockHeaderSize], rax

  {Insert the pool back into the linked list if it was full}

  jz @SmallPoolWasFull

  {All ok}

  xor eax, eax

  {Unlock the block type}

  mov TSmallBlockType[rbx].BlockTypeLocked, al

  jmp @Done

@SmallPoolWasFull:

  {Insert this as the first partially free pool for the block size}

  mov rcx, TSmallBlockType[rbx].NextPartiallyFreePool

  mov TSmallBlockPoolHeader[rdx].PreviousPartiallyFreePool, rbx

  mov TSmallBlockPoolHeader[rdx].NextPartiallyFreePool, rcx

  mov TSmallBlockPoolHeader[rcx].PreviousPartiallyFreePool, rdx

  mov TSmallBlockType[rbx].NextPartiallyFreePool, rdx

  {Unlock the block type}

  mov TSmallBlockType[rbx].BlockTypeLocked, False

  {All ok}

  xor eax, eax

  jmp @Done

@PoolIsNowEmpty:

  {Was this pool actually in the linked list of pools with space? If not, it

   can only be the sequential feed pool (it is the only pool that may contain

   only one block, i.e. other blocks have not been split off yet)}

  test rax, rax

  jz @IsSequentialFeedPool

  {Pool is now empty: Remove it from the linked list and free it}

  mov rax, TSmallBlockPoolHeader[rdx].PreviousPartiallyFreePool

  mov rcx, TSmallBlockPoolHeader[rdx].NextPartiallyFreePool

  {Remove this manager}

  mov TSmallBlockPoolHeader[rax].NextPartiallyFreePool, rcx

  mov TSmallBlockPoolHeader[rcx].PreviousPartiallyFreePool, rax

  {Zero out eax}

  xor rax, rax

  {Is this the sequential feed pool? If so, stop sequential feeding}

  cmp TSmallBlockType[rbx].CurrentSequentialFeedPool, rdx

  jne @NotSequentialFeedPool

@IsSequentialFeedPool:

  mov TSmallBlockType[rbx].MaxSequentialFeedBlockAddress, rax

@NotSequentialFeedPool:

  {Unlock the block type}

  mov TSmallBlockType[rbx].BlockTypeLocked, al

  {Release this pool}

  mov rcx, rdx

  mov rdx, [rdx - BlockHeaderSize]

{$ifndef AssumeMultiThreaded}

  mov bl, IsMultiThread

{$endif}

  jmp @FreeMediumBlock

@LockBlockTypeLoop:

  mov eax, $100

  {Attempt to grab the block type}

  lock cmpxchg TSmallBlockType([rbx]).BlockTypeLocked, ah

  je @GotLockOnSmallBlockType

{$ifdef NeverSleepOnThreadContention}

  {Pause instruction (improves performance on P4)}

  pause

  {$ifdef UseSwitchToThread}

  mov rsi, rcx

  call SwitchToThread

  mov rcx, rsi

  mov rdx, [rcx - BlockHeaderSize]

  {$endif}

  {Try again}

  jmp @LockBlockTypeLoop

{$else}

  {Couldn't grab the block type - sleep and try again}

  mov rsi, rcx

  mov ecx, InitialSleepTime

  call Sleep

  mov rcx, rsi

  mov rdx, [rcx - BlockHeaderSize]

  {Try again}

  mov eax, $100

  {Attempt to grab the block type}

  lock cmpxchg TSmallBlockType([rbx]).BlockTypeLocked, ah

  je @GotLockOnSmallBlockType

  {Couldn't grab the block type - sleep and try again}

  mov rsi, rcx

  mov ecx, AdditionalSleepTime

  call Sleep

  mov rcx, rsi

  mov rdx, [rcx - BlockHeaderSize]

  {Try again}

  jmp @LockBlockTypeLoop

{$endif}

  {---------------------Medium blocks------------------------------}

@NotSmallBlockInUse:

  {Not a small block in use: is it a medium or large block?}

  test dl, IsFreeBlockFlag + IsLargeBlockFlag

  jnz @NotASmallOrMediumBlock

@FreeMediumBlock:

{$ifdef ClearSmallAndMediumBlocksInFreeMem}

  mov rsi, rcx

  and rdx, DropMediumAndLargeFlagsMask

  sub rdx, BlockHeaderSize

  xor r8, r8

  call System.@FillChar

  mov rcx, rsi

  mov rdx, [rcx - BlockHeaderSize]

{$endif}

  {Drop the flags}

  and rdx, DropMediumAndLargeFlagsMask

  {Free the medium block pointed to by eax, header in edx, bl = IsMultiThread}

{$ifndef AssumeMultiThreaded}

  {Do we need to lock the medium blocks?}

  test bl, bl

{$endif}

  {Block size in rbx}

  mov rbx, rdx

  {Pointer in rsi}

  mov rsi, rcx

  {Do we need to lock the medium blocks?}

{$ifndef AssumeMultiThreaded}

  jz @MediumBlocksLocked

{$endif}

  call LockMediumBlocks

@MediumBlocksLocked:

  {Can we combine this block with the next free block?}

  test qword ptr [rsi + rbx - BlockHeaderSize], IsFreeBlockFlag

  {Get the next block size and flags in rcx}

  mov rcx, [rsi + rbx - BlockHeaderSize]

  jnz @NextBlockIsFree

  {Set the "PreviousIsFree" flag in the next block}

  or rcx, PreviousMediumBlockIsFreeFlag

  mov [rsi + rbx - BlockHeaderSize], rcx

@NextBlockChecked:

  {Can we combine this block with the previous free block? We need to

   re-read the flags since it could have changed before we could lock the

   medium blocks.}

  test byte ptr [rsi - BlockHeaderSize], PreviousMediumBlockIsFreeFlag

  jnz @PreviousBlockIsFree

@PreviousBlockChecked:

  {Is the entire medium block pool free, and there are other free blocks

   that can fit the largest possible medium block -> free it.}

  cmp ebx, (MediumBlockPoolSize - MediumBlockPoolHeaderSize)

  je @EntireMediumPoolFree

@BinFreeMediumBlock:

  {Store the size of the block as well as the flags}

  lea rax, [rbx + IsMediumBlockFlag + IsFreeBlockFlag]

  mov [rsi - BlockHeaderSize], rax

  {Store the trailing size marker}

  mov [rsi + rbx - 2 * BlockHeaderSize], rbx

  {Insert this block back into the bins: Size check not required here,

   since medium blocks that are in use are not allowed to be

   shrunk smaller than MinimumMediumBlockSize}

  mov rcx, rsi

  mov rdx, rbx

  {Insert into bin}

  call InsertMediumBlockIntoBin

  {All OK}

  xor eax, eax

  {Unlock medium blocks}

  mov MediumBlocksLocked, al

  jmp @Done

@NextBlockIsFree:

  {Get the next block address in rax}

  lea rax, [rsi + rbx]

  {Increase the size of this block}

  and rcx, DropMediumAndLargeFlagsMask

  add rbx, rcx

  {Was the block binned?}

  cmp rcx, MinimumMediumBlockSize

  jb @NextBlockChecked

  mov rcx, rax

  call RemoveMediumFreeBlock

  jmp @NextBlockChecked

@PreviousBlockIsFree:

  {Get the size of the free block just before this one}

  mov rcx, [rsi - 2 * BlockHeaderSize]

  {Include the previous block}

  sub rsi, rcx

  {Set the new block size}

  add rbx, rcx

  {Remove the previous block from the linked list}

  cmp ecx, MinimumMediumBlockSize

  jb @PreviousBlockChecked

  mov rcx, rsi

  call RemoveMediumFreeBlock

  jmp @PreviousBlockChecked

@EntireMediumPoolFree:

  {Should we make this the new sequential feed medium block pool? If the

   current sequential feed pool is not entirely free, we make this the new

   sequential feed pool.}

  lea r8, MediumSequentialFeedBytesLeft

  cmp dword ptr [r8], MediumBlockPoolSize - MediumBlockPoolHeaderSize //workaround for QC99023

  jne @MakeEmptyMediumPoolSequentialFeed

  {Point esi to the medium block pool header}

  sub rsi, MediumBlockPoolHeaderSize

  {Remove this medium block pool from the linked list}

  mov rax, TMediumBlockPoolHeader[rsi].PreviousMediumBlockPoolHeader

  mov rdx, TMediumBlockPoolHeader[rsi].NextMediumBlockPoolHeader

  mov TMediumBlockPoolHeader[rax].NextMediumBlockPoolHeader, rdx

  mov TMediumBlockPoolHeader[rdx].PreviousMediumBlockPoolHeader, rax

  {Unlock medium blocks}

  xor eax, eax

  mov MediumBlocksLocked, al

{$ifdef ClearMediumBlockPoolsBeforeReturningToOS}

  mov rcx, rsi

  mov edx, MediumBlockPoolSize

  xor r8, r8

  call System.@FillChar

{$endif}

  {Free the medium block pool}

  mov rcx, rsi

  xor edx, edx

  mov r8d, MEM_RELEASE

  call VirtualFree

  {VirtualFree returns >0 if all is ok}

  cmp eax, 1

  {Return 0 on all ok}

  sbb eax, eax

  jmp @Done

@MakeEmptyMediumPoolSequentialFeed:

  {Get a pointer to the end-marker block}

  lea rbx, [rsi + MediumBlockPoolSize - MediumBlockPoolHeaderSize]

  {Bin the current sequential feed pool}

  call BinMediumSequentialFeedRemainder

  {Set this medium pool up as the new sequential feed pool:

   Store the sequential feed pool trailer}

  mov qword ptr [rbx - BlockHeaderSize], IsMediumBlockFlag

  {Store the number of bytes available in the sequential feed chunk}

  lea rax, MediumSequentialFeedBytesLeft

  mov dword ptr [rax], MediumBlockPoolSize - MediumBlockPoolHeaderSize //QC99023 workaround

  {Set the last sequentially fed block}

  mov LastSequentiallyFedMediumBlock, rbx

  {Success}

  xor eax, eax

  {Unlock medium blocks}

  mov MediumBlocksLocked, al

  jmp @Done

@NotASmallOrMediumBlock:

  {Attempt to free an already free block?}

  mov eax, -1

  {Is it in fact a large block?}

  test dl, IsFreeBlockFlag + IsMediumBlockFlag

  jnz @Done

  call FreeLargeBlock

@Done:

end;

{$endif}

{$endif}



{$ifndef FullDebugMode}

{Replacement for SysReallocMem}

function FastReallocMem(APointer: Pointer; ANewSize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer;

{$ifndef ASMVersion}

var

  LBlockHeader, LNextBlockSizeAndFlags, LNewAllocSize, LBlockFlags,

    LOldAvailableSize, LNextBlockSize, LNewAvailableSize, LMinimumUpsize,

    LSecondSplitSize, LNewBlockSize: NativeUInt;

  LPSmallBlockType: PSmallBlockType;

  LPNextBlock, LPNextBlockHeader: Pointer;



  {Upsizes a large block in-place. The following variables are assumed correct:

    LBlockFlags, LOldAvailableSize, LPNextBlock, LNextBlockSizeAndFlags,

    LNextBlockSize, LNewAvailableSize. Medium blocks must be locked on entry if

    required.}

  procedure MediumBlockInPlaceUpsize;

  begin

    {Remove the next block}

    if LNextBlockSizeAndFlags >= MinimumMediumBlockSize then

      RemoveMediumFreeBlock(LPNextBlock);

    {Add 25% for medium block in-place upsizes}

    LMinimumUpsize := LOldAvailableSize + (LOldAvailableSize shr 2);

    if NativeUInt(ANewSize) < LMinimumUpsize then

      LNewAllocSize := LMinimumUpsize

    else

      LNewAllocSize := NativeUInt(ANewSize);

    {Round up to the nearest block size granularity}

    LNewBlockSize := ((LNewAllocSize + (BlockHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset))

      and -MediumBlockGranularity) + MediumBlockSizeOffset;

    {Calculate the size of the second split}

    LSecondSplitSize := LNewAvailableSize + BlockHeaderSize - LNewBlockSize;

    {Does it fit?}

    if NativeInt(LSecondSplitSize) <= 0 then

    begin

      {The block size is the full available size plus header}

      LNewBlockSize := LNewAvailableSize + BlockHeaderSize;

      {Grab the whole block: Mark it as used in the block following it}

      LPNextBlockHeader := Pointer(PByte(APointer) + LNewAvailableSize);

      PNativeUInt(LPNextBlockHeader)^ :=

        PNativeUInt(LPNextBlockHeader)^ and (not PreviousMediumBlockIsFreeFlag);

    end

    else

    begin

      {Split the block in two}

      LPNextBlock := PMediumFreeBlock(PByte(APointer) + LNewBlockSize);

      {Set the size of the second split}

      PNativeUInt(PByte(LPNextBlock) - BlockHeaderSize)^ := LSecondSplitSize or (IsMediumBlockFlag or IsFreeBlockFlag);

      {Store the size of the second split before the header of the next block}

      PNativeUInt(PByte(LPNextBlock) + LSecondSplitSize - 2 * BlockHeaderSize)^ := LSecondSplitSize;

      {Put the remainder in a bin if it is big enough}

      if LSecondSplitSize >= MinimumMediumBlockSize then

        InsertMediumBlockIntoBin(LPNextBlock, LSecondSplitSize);

    end;

    {Set the size and flags for this block}

    PNativeUInt(PByte(APointer) - BlockHeaderSize)^ := LNewBlockSize or LBlockFlags;

  end;



  {In-place downsize of a medium block. On entry Size must be less than half of

   LOldAvailableSize.}

  procedure MediumBlockInPlaceDownsize;

  begin

    {Round up to the next medium block size}

    LNewBlockSize := ((ANewSize + (BlockHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset))

      and -MediumBlockGranularity) + MediumBlockSizeOffset;

    {Get the size of the second split}

    LSecondSplitSize := (LOldAvailableSize + BlockHeaderSize) - LNewBlockSize;

    {Lock the medium blocks}

    LockMediumBlocks;

    {Set the new size}

    PNativeUInt(PByte(APointer) - BlockHeaderSize)^ :=

      (PNativeUInt(PByte(APointer) - BlockHeaderSize)^ and ExtractMediumAndLargeFlagsMask)

      or LNewBlockSize;

    {Is the next block in use?}

    LPNextBlock := PNativeUInt(PByte(APointer) + LOldAvailableSize + BlockHeaderSize);

    LNextBlockSizeAndFlags := PNativeUInt(PByte(LPNextBlock) - BlockHeaderSize)^;

    if LNextBlockSizeAndFlags and IsFreeBlockFlag = 0 then

    begin

      {The next block is in use: flag its previous block as free}

      PNativeUInt(PByte(LPNextBlock) - BlockHeaderSize)^ :=

        LNextBlockSizeAndFlags or PreviousMediumBlockIsFreeFlag;

    end

    else

    begin

      {The next block is free: combine it}

      LNextBlockSizeAndFlags := LNextBlockSizeAndFlags and DropMediumAndLargeFlagsMask;

      Inc(LSecondSplitSize, LNextBlockSizeAndFlags);

      if LNextBlockSizeAndFlags >= MinimumMediumBlockSize then

        RemoveMediumFreeBlock(LPNextBlock);

    end;

    {Set the split}

    LPNextBlock := PNativeUInt(PByte(APointer) + LNewBlockSize);

    {Store the free part's header}

    PNativeUInt(PByte(LPNextBlock) - BlockHeaderSize)^ := LSecondSplitSize or (IsMediumBlockFlag or IsFreeBlockFlag);

    {Store the trailing size field}

    PNativeUInt(PByte(LPNextBlock) + LSecondSplitSize - 2 * BlockHeaderSize)^ := LSecondSplitSize;

    {Bin this free block}

    if LSecondSplitSize >= MinimumMediumBlockSize then

      InsertMediumBlockIntoBin(LPNextBlock, LSecondSplitSize);

    {Unlock the medium blocks}

    MediumBlocksLocked := False;

  end;



begin

  {Get the block header: Is it actually a small block?}

  LBlockHeader := PNativeUInt(PByte(APointer) - BlockHeaderSize)^;

  {Is it a small block that is in use?}

  if LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag or IsLargeBlockFlag) = 0 then

  begin

    {-----------------------------------Small block-------------------------------------}

    {The block header is a pointer to the block pool: Get the block type}

    LPSmallBlockType := PSmallBlockPoolHeader(LBlockHeader).BlockType;

    {Get the available size inside blocks of this type.}

    LOldAvailableSize := LPSmallBlockType.BlockSize - BlockHeaderSize;

    {Is it an upsize or a downsize?}

    if LOldAvailableSize >= NativeUInt(ANewSize) then

    begin

      {It's a downsize. Do we need to allocate a smaller block? Only if the new

       block size is less than a quarter of the available size less

       SmallBlockDownsizeCheckAdder bytes}

      if (NativeUInt(ANewSize) * 4 + SmallBlockDownsizeCheckAdder) >= LOldAvailableSize then

      begin

        {In-place downsize - return the pointer}

        Result := APointer;

        Exit;

      end

      else

      begin

        {Allocate a smaller block}

        Result := FastGetMem(ANewSize);

        {Allocated OK?}

        if Result <> nil then

        begin

          {Move the data across}

{$ifdef UseCustomVariableSizeMoveRoutines}

  {$ifdef Align16Bytes}

          MoveX16LP(APointer^, Result^, ANewSize);

  {$else}

          MoveX8LP(APointer^, Result^, ANewSize);

  {$endif}

{$else}

          System.Move(APointer^, Result^, ANewSize);

{$endif}

          {Free the old pointer}

          FastFreeMem(APointer);

        end;

      end;

    end

    else

    begin

      {This pointer is being reallocated to a larger block and therefore it is

       logical to assume that it may be enlarged again. Since reallocations are

       expensive, there is a minimum upsize percentage to avoid unnecessary

       future move operations.}

      {Must grow with at least 100% + x bytes}

      LNewAllocSize := LOldAvailableSize * 2 + SmallBlockUpsizeAdder;

      {Still not large enough?}

      if LNewAllocSize < NativeUInt(ANewSize) then

        LNewAllocSize := NativeUInt(ANewSize);

      {Allocate the new block}

      Result := FastGetMem(LNewAllocSize);

      {Allocated OK?}

      if Result <> nil then

      begin

        {Do we need to store the requested size? Only large blocks store the

         requested size.}

        if LNewAllocSize > (MaximumMediumBlockSize - BlockHeaderSize) then

          PLargeBlockHeader(PByte(Result) - LargeBlockHeaderSize).UserAllocatedSize := ANewSize;

        {Move the data across}

{$ifdef UseCustomFixedSizeMoveRoutines}

        LPSmallBlockType.UpsizeMoveProcedure(APointer^, Result^, LOldAvailableSize);

{$else}

        System.Move(APointer^, Result^, LOldAvailableSize);

{$endif}

        {Free the old pointer}

        FastFreeMem(APointer);

      end;

    end;

  end

  else

  begin

    {Is this a medium block or a large block?}

    if LBlockHeader and (IsFreeBlockFlag or IsLargeBlockFlag) = 0 then

    begin

      {-------------------------------Medium block--------------------------------------}

      {What is the available size in the block being reallocated?}

      LOldAvailableSize := (LBlockHeader and DropMediumAndLargeFlagsMask);

      {Get a pointer to the next block}

      LPNextBlock := PNativeUInt(PByte(APointer) + LOldAvailableSize);

      {Subtract the block header size from the old available size}

      Dec(LOldAvailableSize, BlockHeaderSize);

      {Is it an upsize or a downsize?}

      if NativeUInt(ANewSize) > LOldAvailableSize then

      begin

        {Can we do an in-place upsize?}

        LNextBlockSizeAndFlags := PNativeUInt(PByte(LPNextBlock) - BlockHeaderSize)^;

        {Is the next block free?}

        if LNextBlockSizeAndFlags and IsFreeBlockFlag <> 0 then

        begin

          LNextBlockSize := LNextBlockSizeAndFlags and DropMediumAndLargeFlagsMask;

          {The available size including the next block}

          LNewAvailableSize := LOldAvailableSize + LNextBlockSize;

          {Can the block fit?}

          if NativeUInt(ANewSize) <= LNewAvailableSize then

          begin

            {The next block is free and there is enough space to grow this

             block in place.}

{$ifndef AssumeMultiThreaded}

            if IsMultiThread then

            begin

{$endif}

              {Multi-threaded application - lock medium blocks and re-read the

               information on the blocks.}

              LockMediumBlocks;

              {Re-read the info for this block}

              LBlockFlags := PNativeUInt(PByte(APointer) - BlockHeaderSize)^ and ExtractMediumAndLargeFlagsMask;

              {Re-read the info for the next block}

              LNextBlockSizeAndFlags := PNativeUInt(PByte(LPNextBlock) - BlockHeaderSize)^;

              {Recalculate the next block size}

              LNextBlockSize := LNextBlockSizeAndFlags and DropMediumAndLargeFlagsMask;

              {The available size including the next block}

              LNewAvailableSize := LOldAvailableSize + LNextBlockSize;

              {Is the next block still free and the size still sufficient?}

              if (LNextBlockSizeAndFlags and IsFreeBlockFlag <> 0)

                and (NativeUInt(ANewSize) <= LNewAvailableSize) then

              begin

                {Upsize the block in-place}

                MediumBlockInPlaceUpsize;

                {Unlock the medium blocks}

                MediumBlocksLocked := False;

                {Return the result}

                Result := APointer;

                {Done}

                Exit;

              end;

              {Couldn't use the block: Unlock the medium blocks}

              MediumBlocksLocked := False;

{$ifndef AssumeMultiThreaded}

            end

            else

            begin

              {Extract the block flags}

              LBlockFlags := ExtractMediumAndLargeFlagsMask and LBlockHeader;

              {Upsize the block in-place}

              MediumBlockInPlaceUpsize;

              {Return the result}

              Result := APointer;

              {Done}

              Exit;

            end;

{$endif}

          end;

        end;

        {Couldn't upsize in place. Grab a new block and move the data across:

         If we have to reallocate and move medium blocks, we grow by at

         least 25%}

        LMinimumUpsize := LOldAvailableSize + (LOldAvailableSize shr 2);

        if NativeUInt(ANewSize) < LMinimumUpsize then

          LNewAllocSize := LMinimumUpsize

        else

          LNewAllocSize := NativeUInt(ANewSize);

        {Allocate the new block}

        Result := FastGetMem(LNewAllocSize);

        if Result <> nil then

        begin

          {If it's a large block - store the actual user requested size}

          if LNewAllocSize > (MaximumMediumBlockSize - BlockHeaderSize) then

            PLargeBlockHeader(PByte(Result) - LargeBlockHeaderSize).UserAllocatedSize := ANewSize;

          {Move the data across}

{$ifdef UseCustomVariableSizeMoveRoutines}

          MoveX16LP(APointer^, Result^, LOldAvailableSize);

{$else}

          System.Move(APointer^, Result^, LOldAvailableSize);

{$endif}

          {Free the old block}

          FastFreeMem(APointer);

        end;

      end

      else

      begin

        {Must be less than half the current size or we don't bother resizing.}

        if NativeUInt(ANewSize * 2) >= LOldAvailableSize then

        begin

          Result := APointer;

        end

        else

        begin

          {In-place downsize? Balance the cost of moving the data vs. the cost

           of fragmenting the memory pool. Medium blocks in use may never be

           smaller than MinimumMediumBlockSize.}

          if NativeUInt(ANewSize) >= (MinimumMediumBlockSize - BlockHeaderSize) then

          begin

            MediumBlockInPlaceDownsize;

            Result := APointer;

          end

          else

          begin

            {The requested size is less than the minimum medium block size. If

             the requested size is less than the threshold value (currently a

             quarter of the minimum medium block size), move the data to a small

             block, otherwise shrink the medium block to the minimum allowable

             medium block size.}

            if NativeUInt(ANewSize) >= MediumInPlaceDownsizeLimit then

            begin

              {The request is for a size smaller than the minimum medium block

               size, but not small enough to justify moving data: Reduce the

               block size to the minimum medium block size}

              ANewSize := MinimumMediumBlockSize - BlockHeaderSize;

              {Is it already at the minimum medium block size?}

              if LOldAvailableSize > NativeUInt(ANewSize) then

                MediumBlockInPlaceDownsize;

              Result := APointer;

            end

            else

            begin

              {Allocate the new block}

              Result := FastGetMem(ANewSize);

              if Result <> nil then

              begin

                {Move the data across}

{$ifdef UseCustomVariableSizeMoveRoutines}

  {$ifdef Align16Bytes}

                MoveX16LP(APointer^, Result^, ANewSize);

  {$else}

                MoveX8LP(APointer^, Result^, ANewSize);

  {$endif}

{$else}

                System.Move(APointer^, Result^, ANewSize);

{$endif}

                {Free the old block}

                FastFreeMem(APointer);

              end;

            end;

          end;

        end;

      end;

    end

    else

    begin

      {Is this a valid large block?}

      if LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag) = 0 then

      begin

        {-----------------------Large block------------------------------}

        Result := ReallocateLargeBlock(APointer, ANewSize);

      end

      else

      begin

        {-----------------------Invalid block------------------------------}

        {Bad pointer: probably an attempt to reallocate a free memory block.}

        Result := nil;

      end;

    end;

  end;

end;

{$else}

{$ifdef 32Bit}

asm

  {On entry: eax = APointer; edx = ANewSize}

  {Get the block header: Is it actually a small block?}

  mov ecx, [eax - 4]

  {Is it a small block?}

  test cl, IsFreeBlockFlag + IsMediumBlockFlag + IsLargeBlockFlag

  {Save ebx}

  push ebx

  {Save esi}

  push esi

  {Save the original pointer in esi}

  mov esi, eax

  {Is it a small block?}

  jnz @NotASmallBlock

  {-----------------------------------Small block-------------------------------------}

  {Get the block type in ebx}

  mov ebx, TSmallBlockPoolHeader[ecx].BlockType

  {Get the available size inside blocks of this type.}

  movzx ecx, TSmallBlockType[ebx].BlockSize

  sub ecx, 4

  {Is it an upsize or a downsize?}

  cmp ecx, edx

  jb @SmallUpsize

  {It's a downsize. Do we need to allocate a smaller block? Only if the new

   size is less than a quarter of the available size less

   SmallBlockDownsizeCheckAdder bytes}

  lea ebx, [edx * 4 + SmallBlockDownsizeCheckAdder]

  cmp ebx, ecx

  jb @NotSmallInPlaceDownsize

  {In-place downsize - return the original pointer}

  pop esi

  pop ebx

  ret

  {Align branch target}

  nop

@NotSmallInPlaceDownsize:

  {Save the requested size}

  mov ebx, edx

  {Allocate a smaller block}

  mov eax, edx

  call FastGetMem

  {Allocated OK?}

  test eax, eax

  jz @SmallDownsizeDone

  {Move data across: count in ecx}

  mov ecx, ebx

  {Destination in edx}

  mov edx, eax

  {Save the result in ebx}

  mov ebx, eax

  {Original pointer in eax}

  mov eax, esi

  {Move the data across}

{$ifdef UseCustomVariableSizeMoveRoutines}

  {$ifdef Align16Bytes}

  call MoveX16LP

  {$else}

  call MoveX8LP

  {$endif}

{$else}

  call System.Move

{$endif}

  {Free the original pointer}

  mov eax, esi

  call FastFreeMem

  {Return the pointer}

  mov eax, ebx

@SmallDownsizeDone:

  pop esi

  pop ebx

  ret

  {Align branch target}

  nop

  nop

@SmallUpsize:

  {State: esi = APointer, edx = ANewSize, ecx = Current Block Size, ebx = Current Block Type}

  {This pointer is being reallocated to a larger block and therefore it is

   logical to assume that it may be enlarged again. Since reallocations are

   expensive, there is a minimum upsize percentage to avoid unnecessary

   future move operations.}

  {Small blocks always grow with at least 100% + SmallBlockUpsizeAdder bytes}

  lea ecx, [ecx + ecx + SmallBlockUpsizeAdder]

  {save edi}

  push edi

  {Save the requested size in edi}

  mov edi, edx

  {New allocated size is the maximum of the requested size and the minimum

   upsize}

  xor eax, eax

  sub ecx, edx

  adc eax, -1

  and eax, ecx

  add eax, edx

  {Allocate the new block}

  call FastGetMem

  {Allocated OK?}

  test eax, eax

  jz @SmallUpsizeDone

  {Do we need to store the requested size? Only large blocks store the

   requested size.}

  cmp edi, MaximumMediumBlockSize - BlockHeaderSize

  jbe @NotSmallUpsizeToLargeBlock

  {Store the user requested size}

  mov [eax - 8], edi

@NotSmallUpsizeToLargeBlock:

  {Get the size to move across}

  movzx ecx, TSmallBlockType[ebx].BlockSize

  sub ecx, BlockHeaderSize

  {Move to the new block}

  mov edx, eax

  {Save the result in edi}

  mov edi, eax

  {Move from the old block}

  mov eax, esi

  {Move the data across}

{$ifdef UseCustomFixedSizeMoveRoutines}

  call TSmallBlockType[ebx].UpsizeMoveProcedure

{$else}

  call System.Move

{$endif}

  {Free the old pointer}

  mov eax, esi

  call FastFreeMem

  {Done}

  mov eax, edi

@SmallUpsizeDone:

  pop edi

  pop esi

  pop ebx

  ret

  {Align branch target}

  nop

@NotASmallBlock:

  {Is this a medium block or a large block?}

  test cl, IsFreeBlockFlag + IsLargeBlockFlag

  jnz @PossibleLargeBlock

  {-------------------------------Medium block--------------------------------------}

  {Status: ecx = Current Block Size + Flags, eax/esi = APointer,

   edx = Requested Size}

  mov ebx, ecx

  {Drop the flags from the header}

  and ecx, DropMediumAndLargeFlagsMask

  {Save edi}

  push edi

  {Get a pointer to the next block in edi}

  lea edi, [eax + ecx]

  {Subtract the block header size from the old available size}

  sub ecx, BlockHeaderSize

  {Get the complete flags in ebx}

  and ebx, ExtractMediumAndLargeFlagsMask

  {Is it an upsize or a downsize?}

  cmp edx, ecx

  {Save ebp}

  push ebp

  {Is it an upsize or a downsize?}

  ja @MediumBlockUpsize

  {Status: ecx = Current Block Size - 4, bl = Current Block Flags,

   edi = @Next Block, eax/esi = APointer, edx = Requested Size}

  {Must be less than half the current size or we don't bother resizing.}

  lea ebp, [edx + edx]

  cmp ebp, ecx

  jb @MediumMustDownsize

@MediumNoResize:

  {Restore registers}

  pop ebp

  pop edi

  pop esi

  pop ebx

  {Return}

  ret

  {Align branch target}

  nop

  nop

  nop

@MediumMustDownsize:

  {In-place downsize? Balance the cost of moving the data vs. the cost of

   fragmenting the memory pool. Medium blocks in use may never be smaller

   than MinimumMediumBlockSize.}

  cmp edx, MinimumMediumBlockSize - BlockHeaderSize

  jae @MediumBlockInPlaceDownsize

  {The requested size is less than the minimum medium block size. If the

  requested size is less than the threshold value (currently a quarter of the

  minimum medium block size), move the data to a small block, otherwise shrink

  the medium block to the minimum allowable medium block size.}

  cmp edx, MediumInPlaceDownsizeLimit

  jb @MediumDownsizeRealloc

  {The request is for a size smaller than the minimum medium block size, but

   not small enough to justify moving data: Reduce the block size to the

   minimum medium block size}

  mov edx, MinimumMediumBlockSize - BlockHeaderSize

  {Is it already at the minimum medium block size?}

  cmp ecx, edx

  jna @MediumNoResize

@MediumBlockInPlaceDownsize:

  {Round up to the next medium block size}

  lea ebp, [edx + BlockHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset]

  and ebp, -MediumBlockGranularity;

  add ebp, MediumBlockSizeOffset

  {Get the size of the second split}

  add ecx, BlockHeaderSize

  sub ecx, ebp

  {Lock the medium blocks}

{$ifndef AssumeMultiThreaded}

  cmp IsMultiThread, False

  je @DoMediumInPlaceDownsize

{$endif}

@DoMediumLockForDownsize:

  {Lock the medium blocks (ecx *must* be preserved)}

  call LockMediumBlocks

  {Reread the flags - they may have changed before medium blocks could be

   locked.}

  mov ebx, ExtractMediumAndLargeFlagsMask

  and ebx, [esi - 4]

@DoMediumInPlaceDownsize:

  {Set the new size}

  or ebx, ebp

  mov [esi - 4], ebx

  {Get the second split size in ebx}

  mov ebx, ecx

  {Is the next block in use?}

  mov edx, [edi - 4]

  test dl, IsFreeBlockFlag

  jnz @MediumDownsizeNextBlockFree

  {The next block is in use: flag its previous block as free}

  or edx, PreviousMediumBlockIsFreeFlag

  mov [edi - 4], edx

  jmp @MediumDownsizeDoSplit

  {Align branch target}

  nop

  nop

{$ifdef AssumeMultiThreaded}

  nop

{$endif}

@MediumDownsizeNextBlockFree:

  {The next block is free: combine it}

  mov eax, edi

  and edx, DropMediumAndLargeFlagsMask

  add ebx, edx

  add edi, edx

  cmp edx, MinimumMediumBlockSize

  jb @MediumDownsizeDoSplit

  call RemoveMediumFreeBlock

@MediumDownsizeDoSplit:

  {Store the trailing size field}

  mov [edi - 8], ebx

  {Store the free part's header}

  lea eax, [ebx + IsMediumBlockFlag + IsFreeBlockFlag];

  mov [esi + ebp - 4], eax

  {Bin this free block}

  cmp ebx, MinimumMediumBlockSize

  jb @MediumBlockDownsizeDone

  lea eax, [esi + ebp]

  mov edx, ebx

  call InsertMediumBlockIntoBin

@MediumBlockDownsizeDone:

  {Unlock the medium blocks}

  mov MediumBlocksLocked, False

  {Result = old pointer}

  mov eax, esi

  {Restore registers}

  pop ebp

  pop edi

  pop esi

  pop ebx

  {Return}

  ret

  {Align branch target}

@MediumDownsizeRealloc:

  {Save the requested size}

  mov edi, edx

  mov eax, edx

  {Allocate the new block}

  call FastGetMem

  test eax, eax

  jz @MediumBlockDownsizeExit

  {Save the result}

  mov ebp, eax

  mov edx, eax

  mov eax, esi

  mov ecx, edi

  {Move the data across}

{$ifdef UseCustomVariableSizeMoveRoutines}

  {$ifdef Align16Bytes}

  call MoveX16LP

  {$else}

  call MoveX8LP

  {$endif}

{$else}

  call System.Move

{$endif}

  mov eax, esi

  call FastFreeMem

  {Return the result}

  mov eax, ebp

@MediumBlockDownsizeExit:

  pop ebp

  pop edi

  pop esi

  pop ebx

  ret

  {Align branch target}

@MediumBlockUpsize:

  {Status: ecx = Current Block Size - 4, bl = Current Block Flags,

   edi = @Next Block, eax/esi = APointer, edx = Requested Size}

  {Can we do an in-place upsize?}

  mov eax, [edi - 4]

  test al, IsFreeBlockFlag

  jz @CannotUpsizeMediumBlockInPlace

  {Get the total available size including the next block}

  and eax, DropMediumAndLargeFlagsMask

  {ebp = total available size including the next block (excluding the header)}

  lea ebp, [eax + ecx]

  {Can the block fit?}

  cmp edx, ebp

  ja @CannotUpsizeMediumBlockInPlace

  {The next block is free and there is enough space to grow this

   block in place.}

{$ifndef AssumeMultiThreaded}

  cmp IsMultiThread, False

  je @DoMediumInPlaceUpsize

{$endif}

@DoMediumLockForUpsize:

  {Lock the medium blocks (ecx and edx *must* be preserved}

  call LockMediumBlocks

  {Re-read the info for this block (since it may have changed before the medium

   blocks could be locked)}

  mov ebx, ExtractMediumAndLargeFlagsMask

  and ebx, [esi - 4]

  {Re-read the info for the next block}

  mov eax, [edi - 4]

  {Next block still free?}

  test al, IsFreeBlockFlag

  jz @NextMediumBlockChanged

  {Recalculate the next block size}

  and eax, DropMediumAndLargeFlagsMask

  {The available size including the next block}

  lea ebp, [eax + ecx]

  {Can the block still fit?}

  cmp edx, ebp

  ja @NextMediumBlockChanged

@DoMediumInPlaceUpsize:

  {Is the next block binnable?}

  cmp eax, MinimumMediumBlockSize

  {Remove the next block}

  jb @MediumInPlaceNoNextRemove

  mov eax, edi

  push ecx

  push edx

  call RemoveMediumFreeBlock

  pop edx

  pop ecx

@MediumInPlaceNoNextRemove:

  {Medium blocks grow a minimum of 25% in in-place upsizes}

  mov eax, ecx

  shr eax, 2

  add eax, ecx

  {Get the maximum of the requested size and the minimum growth size}

  xor edi, edi

  sub eax, edx

  adc edi, -1

  and eax, edi

  {Round up to the nearest block size granularity}

  lea eax, [eax + edx + BlockHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset]

  and eax, -MediumBlockGranularity

  add eax, MediumBlockSizeOffset

  {Calculate the size of the second split}

  lea edx, [ebp + BlockHeaderSize]

  sub edx, eax

  {Does it fit?}

  ja @MediumInPlaceUpsizeSplit

  {Grab the whole block: Mark it as used in the block following it}

  and dword ptr [esi + ebp], not PreviousMediumBlockIsFreeFlag

  {The block size is the full available size plus header}

  add ebp, 4

  {Upsize done}

  jmp @MediumUpsizeInPlaceDone

  {Align branch target}

{$ifndef AssumeMultiThreaded}

  nop

  nop

  nop

{$endif}

@MediumInPlaceUpsizeSplit:

  {Store the size of the second split as the second last dword}

  mov [esi + ebp - 4], edx

  {Set the second split header}

  lea edi, [edx + IsMediumBlockFlag + IsFreeBlockFlag]

  mov [esi + eax - 4], edi

  mov ebp, eax

  cmp edx, MinimumMediumBlockSize

  jb @MediumUpsizeInPlaceDone

  add eax, esi

  call InsertMediumBlockIntoBin

@MediumUpsizeInPlaceDone:

  {Set the size and flags for this block}

  or ebp, ebx

  mov [esi - 4], ebp

  {Unlock the medium blocks}

  mov MediumBlocksLocked, False

  {Result = old pointer}

  mov eax, esi

@MediumBlockResizeDone2:

  {Restore registers}

  pop ebp

  pop edi

  pop esi

  pop ebx

  {Return}

  ret

  {Align branch target for "@CannotUpsizeMediumBlockInPlace"}

  nop

  nop

@NextMediumBlockChanged:

  {The next medium block changed while the medium blocks were being locked}

  mov MediumBlocksLocked, False

@CannotUpsizeMediumBlockInPlace:

  {Couldn't upsize in place. Grab a new block and move the data across:

   If we have to reallocate and move medium blocks, we grow by at

   least 25%}

  mov eax, ecx

  shr eax, 2

  add eax, ecx

  {Get the maximum of the requested size and the minimum growth size}

  xor edi, edi

  sub eax, edx

  adc edi, -1

  and eax, edi

  add eax, edx

  {Save the size to allocate}

  mov ebp, eax

  {Save the size to move across}

  mov edi, ecx

  {Get the block}

  push edx

  call FastGetMem

  pop edx

  {Success?}

  test eax, eax

  jz @MediumBlockResizeDone2

  {If it's a Large block - store the actual user requested size}

  cmp ebp, MaximumMediumBlockSize - BlockHeaderSize

  jbe @MediumUpsizeNotLarge

  mov [eax - 8], edx

@MediumUpsizeNotLarge:

  {Save the result}

  mov ebp, eax

  {Move the data across}

  mov edx, eax

  mov eax, esi

  mov ecx, edi

{$ifdef UseCustomVariableSizeMoveRoutines}

  call MoveX16LP

{$else}

  call System.Move

{$endif}

  {Free the old block}

  mov eax, esi

  call FastFreeMem

  {Restore the result}

  mov eax, ebp

  {Restore registers}

  pop ebp

  pop edi

  pop esi

  pop ebx

  {Return}

  ret

  {Align branch target}

  nop

@PossibleLargeBlock:

  {-----------------------Large block------------------------------}

  {Restore registers}

  pop esi

  pop ebx

  {Is this a valid large block?}

  test cl, IsFreeBlockFlag + IsMediumBlockFlag

  jz ReallocateLargeBlock

  {-----------------------Invalid block------------------------------}

  xor eax, eax

end;



{$else}



{-----------------64-bit BASM FastReallocMem-----------------}

asm

  .params 3

  .pushnv rbx

  .pushnv rsi

  .pushnv rdi

  .pushnv r14

  .pushnv r15

  {On entry: rcx = APointer; rdx = ANewSize}

  {Save the original pointer in rsi}

  mov rsi, rcx

  {Get the block header}

  mov rcx, [rcx - BlockHeaderSize]

  {Is it a small block?}

  test cl, IsFreeBlockFlag + IsMediumBlockFlag + IsLargeBlockFlag

  jnz @NotASmallBlock

  {-----------------------------------Small block-------------------------------------}

  {Get the block type in rbx}

  mov rbx, TSmallBlockPoolHeader[rcx].BlockType

  {Get the available size inside blocks of this type.}

  movzx ecx, TSmallBlockType[rbx].BlockSize

  sub ecx, BlockHeaderSize

  {Is it an upsize or a downsize?}

  cmp rcx, rdx

  jb @SmallUpsize

  {It's a downsize. Do we need to allocate a smaller block? Only if the new

   size is less than a quarter of the available size less

   SmallBlockDownsizeCheckAdder bytes}

  lea ebx, [edx * 4 + SmallBlockDownsizeCheckAdder]

  cmp ebx, ecx

  jb @NotSmallInPlaceDownsize

  {In-place downsize - return the original pointer}

  mov rax, rsi

  jmp @Done

@NotSmallInPlaceDownsize:

  {Save the requested size}

  mov rbx, rdx

  {Allocate a smaller block}

  mov rcx, rdx

  call FastGetMem

  {Allocated OK?}

  test rax, rax

  jz @Done

  {Move data across: count in r8}

  mov r8, rbx

  {Destination in edx}

  mov rdx, rax

  {Save the result in ebx}

  mov rbx, rax

  {Original pointer in ecx}

  mov rcx, rsi

  {Move the data across}

{$ifdef UseCustomVariableSizeMoveRoutines}

  {$ifdef Align16Bytes}

  call MoveX16LP

  {$else}

  call MoveX8LP

  {$endif}

{$else}

  call System.Move

{$endif}

  {Free the original pointer}

  mov rcx, rsi

  call FastFreeMem

  {Return the pointer}

  mov rax, rbx

  jmp @Done

@SmallUpsize:

  {State: rsi = APointer, rdx = ANewSize, rcx = Current Block Size, rbx = Current Block Type}

  {This pointer is being reallocated to a larger block and therefore it is

   logical to assume that it may be enlarged again. Since reallocations are

   expensive, there is a minimum upsize percentage to avoid unnecessary

   future move operations.}

  {Small blocks always grow with at least 100% + SmallBlockUpsizeAdder bytes}

  lea ecx, [ecx + ecx + SmallBlockUpsizeAdder]

  {Save the requested size in rdi}

  mov rdi, rdx

  {New allocated size is the maximum of the requested size and the minimum

   upsize}

  xor rax, rax

  sub rcx, rdx

  adc rax, -1

  and rcx, rax

  add rcx, rdx

  {Allocate the new block}

  call FastGetMem

  {Allocated OK?}

  test rax, rax

  jz @Done

  {Do we need to store the requested size? Only large blocks store the

   requested size.}

  cmp rdi, MaximumMediumBlockSize - BlockHeaderSize

  jbe @NotSmallUpsizeToLargeBlock

  {Store the user requested size}

  mov [rax - 2 * BlockHeaderSize], rdi

@NotSmallUpsizeToLargeBlock:

  {Get the size to move across}

  movzx r8d, TSmallBlockType[rbx].BlockSize

  sub r8d, BlockHeaderSize

  {Move to the new block}

  mov rdx, rax

  {Save the result in edi}

  mov rdi, rax

  {Move from the old block}

  mov rcx, rsi

  {Move the data across}

{$ifdef UseCustomFixedSizeMoveRoutines}

  call TSmallBlockType[rbx].UpsizeMoveProcedure

{$else}

  call System.Move

{$endif}

  {Free the old pointer}

  mov rcx, rsi

  call FastFreeMem

  {Done}

  mov rax, rdi

  jmp @Done

@NotASmallBlock:

  {Is this a medium block or a large block?}

  test cl, IsFreeBlockFlag + IsLargeBlockFlag

  jnz @PossibleLargeBlock

  {-------------------------------Medium block--------------------------------------}

  {Status: rcx = Current Block Size + Flags, rsi = APointer,

   rdx = Requested Size}

  mov rbx, rcx

  {Drop the flags from the header}

  and ecx, DropMediumAndLargeFlagsMask

  {Get a pointer to the next block in rdi}

  lea rdi, [rsi + rcx]

  {Subtract the block header size from the old available size}

  sub ecx, BlockHeaderSize

  {Get the complete flags in ebx}

  and ebx, ExtractMediumAndLargeFlagsMask

  {Is it an upsize or a downsize?}

  cmp rdx, rcx

  ja @MediumBlockUpsize

  {Status: ecx = Current Block Size - BlockHeaderSize, bl = Current Block Flags,

   rdi = @Next Block, rsi = APointer, rdx = Requested Size}

  {Must be less than half the current size or we don't bother resizing.}

  lea r15, [rdx + rdx]

  cmp r15, rcx

  jb @MediumMustDownsize

@MediumNoResize:

  mov rax, rsi

  jmp @Done

@MediumMustDownsize:

  {In-place downsize? Balance the cost of moving the data vs. the cost of

   fragmenting the memory pool. Medium blocks in use may never be smaller

   than MinimumMediumBlockSize.}

  cmp edx, MinimumMediumBlockSize - BlockHeaderSize

  jae @MediumBlockInPlaceDownsize

  {The requested size is less than the minimum medium block size. If the

  requested size is less than the threshold value (currently a quarter of the

  minimum medium block size), move the data to a small block, otherwise shrink

  the medium block to the minimum allowable medium block size.}

  cmp edx, MediumInPlaceDownsizeLimit

  jb @MediumDownsizeRealloc

  {The request is for a size smaller than the minimum medium block size, but

   not small enough to justify moving data: Reduce the block size to the

   minimum medium block size}

  mov edx, MinimumMediumBlockSize - BlockHeaderSize

  {Is it already at the minimum medium block size?}

  cmp ecx, edx

  jna @MediumNoResize

@MediumBlockInPlaceDownsize:

  {Round up to the next medium block size}

  lea r15, [rdx + BlockHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset]

  and r15, -MediumBlockGranularity

  add r15, MediumBlockSizeOffset

  {Get the size of the second split}

  add ecx, BlockHeaderSize

  sub ecx, r15d

  {Lock the medium blocks}

{$ifndef AssumeMultiThreaded}

  lea r8, IsMultiThread

  cmp byte ptr [r8], False

  je @DoMediumInPlaceDownsize

{$endif}

@DoMediumLockForDownsize:

  {Lock the medium blocks}

  mov ebx, ecx

  call LockMediumBlocks

  mov ecx, ebx

  {Reread the flags - they may have changed before medium blocks could be

   locked.}

  mov rbx, ExtractMediumAndLargeFlagsMask

  and rbx, [rsi - BlockHeaderSize]

@DoMediumInPlaceDownsize:

  {Set the new size}

  or rbx, r15

  mov [rsi - BlockHeaderSize], rbx

  {Get the second split size in ebx}

  mov ebx, ecx

  {Is the next block in use?}

  mov rdx, [rdi - BlockHeaderSize]

  test dl, IsFreeBlockFlag

  jnz @MediumDownsizeNextBlockFree

  {The next block is in use: flag its previous block as free}

  or rdx, PreviousMediumBlockIsFreeFlag

  mov [rdi - BlockHeaderSize], rdx

  jmp @MediumDownsizeDoSplit

@MediumDownsizeNextBlockFree:

  {The next block is free: combine it}

  mov rcx, rdi

  and rdx, DropMediumAndLargeFlagsMask

  add rbx, rdx

  add rdi, rdx

  cmp edx, MinimumMediumBlockSize

  jb @MediumDownsizeDoSplit

  call RemoveMediumFreeBlock

@MediumDownsizeDoSplit:

  {Store the trailing size field}

  mov [rdi - 2 * BlockHeaderSize], rbx

  {Store the free part's header}

  lea rcx, [rbx + IsMediumBlockFlag + IsFreeBlockFlag];

  mov [rsi + r15 - BlockHeaderSize], rcx

  {Bin this free block}

  cmp rbx, MinimumMediumBlockSize

  jb @MediumBlockDownsizeDone

  lea rcx, [rsi + r15]

  mov rdx, rbx

  call InsertMediumBlockIntoBin

@MediumBlockDownsizeDone:

  {Unlock the medium blocks}

  lea rax, MediumBlocksLocked

  mov byte ptr [rax], False

  {Result = old pointer}

  mov rax, rsi

  jmp @Done

@MediumDownsizeRealloc:

  {Save the requested size}

  mov rdi, rdx

  mov rcx, rdx

  {Allocate the new block}

  call FastGetMem

  test rax, rax

  jz @Done

  {Save the result}

  mov r15, rax

  mov rdx, rax

  mov rcx, rsi

  mov r8, rdi

  {Move the data across}

{$ifdef UseCustomVariableSizeMoveRoutines}

  {$ifdef Align16Bytes}

  call MoveX16LP

  {$else}

  call MoveX8LP

  {$endif}

{$else}

  call System.Move

{$endif}

  mov rcx, rsi

  call FastFreeMem

  {Return the result}

  mov rax, r15

  jmp @Done

@MediumBlockUpsize:

  {Status: ecx = Current Block Size - BlockHeaderSize, bl = Current Block Flags,

   rdi = @Next Block, rsi = APointer, rdx = Requested Size}

  {Can we do an in-place upsize?}

  mov rax, [rdi - BlockHeaderSize]

  test al, IsFreeBlockFlag

  jz @CannotUpsizeMediumBlockInPlace

  {Get the total available size including the next block}

  and rax, DropMediumAndLargeFlagsMask

  {r15 = total available size including the next block (excluding the header)}

  lea r15, [rax + rcx]

  {Can the block fit?}

  cmp rdx, r15

  ja @CannotUpsizeMediumBlockInPlace

  {The next block is free and there is enough space to grow this

   block in place.}

{$ifndef AssumeMultiThreaded}

  lea r8, IsMultiThread

  cmp byte ptr [r8], False

  je @DoMediumInPlaceUpsize

{$endif}

@DoMediumLockForUpsize:

  {Lock the medium blocks.}

  mov rbx, rcx

  mov r15, rdx

  call LockMediumBlocks

  mov rcx, rbx

  mov rdx, r15

  {Re-read the info for this block (since it may have changed before the medium

   blocks could be locked)}

  mov rbx, ExtractMediumAndLargeFlagsMask

  and rbx, [rsi - BlockHeaderSize]

  {Re-read the info for the next block}

  mov rax, [rdi - BlockheaderSize]

  {Next block still free?}

  test al, IsFreeBlockFlag

  jz @NextMediumBlockChanged

  {Recalculate the next block size}

  and eax, DropMediumAndLargeFlagsMask

  {The available size including the next block}

  lea r15, [rax + rcx]

  {Can the block still fit?}

  cmp rdx, r15

  ja @NextMediumBlockChanged

@DoMediumInPlaceUpsize:

  {Is the next block binnable?}

  cmp eax, MinimumMediumBlockSize

  {Remove the next block}

  jb @MediumInPlaceNoNextRemove

  mov r14, rcx

  mov rcx, rdi

  mov rdi, rdx

  call RemoveMediumFreeBlock

  mov rcx, r14

  mov rdx, rdi

@MediumInPlaceNoNextRemove:

  {Medium blocks grow a minimum of 25% in in-place upsizes}

  mov eax, ecx

  shr eax, 2

  add eax, ecx

  {Get the maximum of the requested size and the minimum growth size}

  xor edi, edi

  sub eax, edx

  adc edi, -1

  and eax, edi

  {Round up to the nearest block size granularity}

  lea eax, [eax + edx + BlockHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset]

  and eax, -MediumBlockGranularity

  add eax, MediumBlockSizeOffset

  {Calculate the size of the second split}

  lea rdx, [r15 + BlockHeaderSize]

  sub edx, eax

  {Does it fit?}

  ja @MediumInPlaceUpsizeSplit

  {Grab the whole block: Mark it as used in the block following it}

  and qword ptr [rsi + r15], not PreviousMediumBlockIsFreeFlag

  {The block size is the full available size plus header}

  add r15, BlockHeaderSize

  {Upsize done}

  jmp @MediumUpsizeInPlaceDone

@MediumInPlaceUpsizeSplit:

  {Store the size of the second split as the second last dword}

  mov [rsi + r15 - BlockHeaderSize], rdx

  {Set the second split header}

  lea edi, [edx + IsMediumBlockFlag + IsFreeBlockFlag]

  mov [rsi + rax - BlockHeaderSize], rdi

  mov r15, rax

  cmp edx, MinimumMediumBlockSize

  jb @MediumUpsizeInPlaceDone

  lea rcx, [rsi + rax]

  call InsertMediumBlockIntoBin

@MediumUpsizeInPlaceDone:

  {Set the size and flags for this block}

  or r15, rbx

  mov [rsi - BlockHeaderSize], r15

  {Unlock the medium blocks}

  lea rax, MediumBlocksLocked

  mov byte ptr [rax], False

  {Result = old pointer}

  mov rax, rsi

  jmp @Done

@NextMediumBlockChanged:

  {The next medium block changed while the medium blocks were being locked}

  lea rax, MediumBlocksLocked

  mov byte ptr [rax], False

@CannotUpsizeMediumBlockInPlace:

  {Couldn't upsize in place. Grab a new block and move the data across:

   If we have to reallocate and move medium blocks, we grow by at

   least 25%}

  mov eax, ecx

  shr eax, 2

  add eax, ecx

  {Get the maximum of the requested size and the minimum growth size}

  xor rdi, rdi

  sub rax, rdx

  adc rdi, -1

  and rax, rdi

  add rax, rdx

  {Save the size to allocate}

  mov r15, rax

  {Save the size to move across}

  mov edi, ecx

  {Save the requested size}

  mov rbx, rdx

  {Get the block}

  mov rcx, rax

  call FastGetMem

  mov rdx, rbx

  {Success?}

  test eax, eax

  jz @Done

  {If it's a Large block - store the actual user requested size}

  cmp r15, MaximumMediumBlockSize - BlockHeaderSize

  jbe @MediumUpsizeNotLarge

  mov [rax - 2 * BlockHeaderSize], rdx

@MediumUpsizeNotLarge:

  {Save the result}

  mov r15, rax

  {Move the data across}

  mov rdx, rax

  mov rcx, rsi

  mov r8, rdi

{$ifdef UseCustomVariableSizeMoveRoutines}

  call MoveX16LP

{$else}

  call System.Move

{$endif}

  {Free the old block}

  mov rcx, rsi

  call FastFreeMem

  {Restore the result}

  mov rax, r15

  jmp @Done

@PossibleLargeBlock:

  {-----------------------Large block------------------------------}

  {Is this a valid large block?}

  test cl, IsFreeBlockFlag + IsMediumBlockFlag

  jnz @Error

  mov rcx, rsi

  call ReallocateLargeBlock

  jmp @Done

  {-----------------------Invalid block------------------------------}

@Error:

  xor eax, eax

@Done:

end;

{$endif}

{$endif}

{$endif}



{Allocates a block and fills it with zeroes}

function FastAllocMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Cardinal{$endif}): Pointer;

{$ifndef ASMVersion}

begin

  Result := FastGetMem(ASize);

  {Large blocks are already zero filled}

  if (Result <> nil) and (ASize <= (MaximumMediumBlockSize - BlockHeaderSize)) then

    FillChar(Result^, ASize, 0);

end;

{$else}

{$ifdef 32Bit}

asm

  push ebx

  {Get the size rounded down to the previous multiple of 4 into ebx}

  lea ebx, [eax - 1]

  and ebx, -4

  {Get the block}

  call FastGetMem

  {Could a block be allocated? ecx = 0 if yes, $ffffffff if no}

  cmp eax, 1

  sbb ecx, ecx

  {Point edx to the last dword}

  lea edx, [eax + ebx]

  {ebx = $ffffffff if no block could be allocated, otherwise size rounded down

   to previous multiple of 4. If ebx = 0 then the block size is 1..4 bytes and

   the FPU based clearing loop should not be used (since it clears 8 bytes per

   iteration).}

  or ebx, ecx

  jz @ClearLastDWord

  {Large blocks are already zero filled}

  cmp ebx, MaximumMediumBlockSize - BlockHeaderSize

  jae @Done

  {Make the counter negative based}

  neg ebx

  {Load zero into st(0)}

  fldz

  {Clear groups of 8 bytes. Block sizes are always four less than a multiple

   of 8.}

@FillLoop:

  fst qword ptr [edx + ebx]

  add ebx, 8

  js @FillLoop

  {Clear st(0)}

  ffree st(0)

  {Correct the stack top}

  fincstp

  {Clear the last four bytes}

@ClearLastDWord:

  mov [edx], ecx

@Done:

  pop ebx

end;



{$else}



{---------------64-bit BASM FastAllocMem---------------}

asm

  .params 1

  .pushnv rbx

  {Get the size rounded down to the previous multiple of SizeOf(Pointer) into

   ebx}

  lea rbx, [rcx - 1]

  and rbx, -8

  {Get the block}

  call FastGetMem

  {Could a block be allocated? rcx = 0 if yes, -1 if no}

  cmp rax, 1

  sbb rcx, rcx

  {Point rdx to the last dword}

  lea rdx, [rax + rbx]

  {rbx = -1 if no block could be allocated, otherwise size rounded down

   to previous multiple of 8. If rbx = 0 then the block size is 1..8 bytes and

   the SSE2 based clearing loop should not be used (since it clears 16 bytes per

   iteration).}

  or rbx, rcx

  jz @ClearLastQWord

  {Large blocks are already zero filled}

  cmp rbx, MaximumMediumBlockSize - BlockHeaderSize

  jae @Done

  {Make the counter negative based}

  neg rbx

  {Load zero into xmm0}

  pxor xmm0, xmm0

  {Clear groups of 16 bytes. Block sizes are always 8 less than a multiple of

   16.}

@FillLoop:

  movdqa [rdx + rbx], xmm0

  add rbx, 16

  js @FillLoop

  {Clear the last 8 bytes}

@ClearLastQWord:

  xor rcx, rcx

  mov [rdx], rcx

@Done:

end;

{$endif}

{$endif}



{-----------------Post Uninstall GetMem/FreeMem/ReallocMem-------------------}



{$ifdef DetectMMOperationsAfterUninstall}



function InvalidGetMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer;

{$ifndef NoMessageBoxes}

var

  LErrorMessageTitle: array[0..1023] of AnsiChar;

{$endif}

begin

{$ifdef UseOutputDebugString}

  OutputDebugStringA(InvalidGetMemMsg);

{$endif}

{$ifndef NoMessageBoxes}

  AppendStringToModuleName(InvalidOperationTitle, LErrorMessageTitle);

  ShowMessageBox(InvalidGetMemMsg, LErrorMessageTitle);

{$endif}

  Result := nil;

end;



function InvalidFreeMem(APointer: Pointer): Integer;

{$ifndef NoMessageBoxes}

var

  LErrorMessageTitle: array[0..1023] of AnsiChar;

{$endif}

begin

{$ifdef UseOutputDebugString}

  OutputDebugStringA(InvalidFreeMemMsg);

{$endif}

{$ifndef NoMessageBoxes}

  AppendStringToModuleName(InvalidOperationTitle, LErrorMessageTitle);

  ShowMessageBox(InvalidFreeMemMsg, LErrorMessageTitle);

{$endif}

  Result := -1;

end;



function InvalidReallocMem(APointer: Pointer; ANewSize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer;

{$ifndef NoMessageBoxes}

var

  LErrorMessageTitle: array[0..1023] of AnsiChar;

{$endif}

begin

{$ifdef UseOutputDebugString}

  OutputDebugStringA(InvalidReallocMemMsg);

{$endif}

{$ifndef NoMessageBoxes}

  AppendStringToModuleName(InvalidOperationTitle, LErrorMessageTitle);

  ShowMessageBox(InvalidReallocMemMsg, LErrorMessageTitle);

{$endif}

  Result := nil;

end;



function InvalidAllocMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Cardinal{$endif}): Pointer;

{$ifndef NoMessageBoxes}

var

  LErrorMessageTitle: array[0..1023] of AnsiChar;

{$endif}

begin

{$ifdef UseOutputDebugString}

  OutputDebugStringA(InvalidAllocMemMsg);

{$endif}

{$ifndef NoMessageBoxes}

  AppendStringToModuleName(InvalidOperationTitle, LErrorMessageTitle);

  ShowMessageBox(InvalidAllocMemMsg, LErrorMessageTitle);

{$endif}

  Result := nil;

end;



function InvalidRegisterAndUnRegisterMemoryLeak(APointer: Pointer): Boolean;

begin

  Result := False;

end;



{$endif}



{-----------------Full Debug Mode Memory Manager Interface--------------------}



{$ifdef FullDebugMode}



{Compare [AAddress], CompareVal:

 If Equal: [AAddress] := NewVal and result = CompareVal

 If Unequal: Result := [AAddress]}

function LockCmpxchg32(CompareVal, NewVal: Integer; AAddress: PInteger): Integer;

asm

{$ifdef 32Bit}

  {On entry:

    eax = CompareVal,

    edx = NewVal,

    ecx = AAddress}

  lock cmpxchg [ecx], edx

{$else}

.noframe

  {On entry:

    ecx = CompareVal,

    edx = NewVal,

    r8 = AAddress}

  mov eax, ecx

  lock cmpxchg [r8], edx

{$endif}

end;



{Called by DebugGetMem, DebugFreeMem and DebugReallocMem in order to block a

 free block scan operation while the memory pool is being modified.}

procedure StartChangingFullDebugModeBlock;

var

  LOldCount: Integer;

begin

  while True do

  begin

    {Get the old thread count}

    LOldCount := ThreadsInFullDebugModeRoutine;

    if (LOldCount >= 0)

      and (LockCmpxchg32(LOldCount, LOldCount + 1, @ThreadsInFullDebugModeRoutine) = LOldCount) then

    begin

      Break;

    end;

  {$ifdef NeverSleepOnThreadContention}

    {$ifdef UseSwitchToThread}

    SwitchToThread;

    {$endif}

  {$else}

    Sleep(InitialSleepTime);

    {Try again}

    LOldCount := ThreadsInFullDebugModeRoutine;

    if (LOldCount >= 0)

      and (LockCmpxchg32(LOldCount, LOldCount + 1, @ThreadsInFullDebugModeRoutine) = LOldCount) then

    begin

      Break;

    end;

    Sleep(AdditionalSleepTime);

  {$endif}

  end;

end;



procedure DoneChangingFullDebugModeBlock;

asm

{$ifdef 32Bit}

  lock dec ThreadsInFullDebugModeRoutine

{$else}

.noframe

  lea rax, ThreadsInFullDebugModeRoutine

  lock dec dword ptr [rax]

{$endif}

end;



{Increments the allocation number}

procedure IncrementAllocationNumber;

asm

{$ifdef 32Bit}

  lock inc CurrentAllocationNumber

{$else}

.noframe

  lea rax, CurrentAllocationNumber

  lock inc dword ptr [rax]

{$endif}

end;



{Called by a routine wanting to lock the entire memory pool in FullDebugMode, e.g. before scanning the memory

 pool for corruptions.}

procedure BlockFullDebugModeMMRoutines;

begin

  while True do

  begin

    {Get the old thread count}

    if LockCmpxchg32(0, -1, @ThreadsInFullDebugModeRoutine) = 0 then

      Break;

{$ifdef NeverSleepOnThreadContention}

  {$ifdef UseSwitchToThread}

    SwitchToThread;

  {$endif}

{$else}

    Sleep(InitialSleepTime);

    {Try again}

    if LockCmpxchg32(0, -1, @ThreadsInFullDebugModeRoutine) = 0 then

      Break;

    Sleep(AdditionalSleepTime);

{$endif}

  end;

end;



procedure UnblockFullDebugModeMMRoutines;

begin

  {Currently blocked? If so, unblock the FullDebugMode routines.}

  if ThreadsInFullDebugModeRoutine = -1 then

    ThreadsInFullDebugModeRoutine := 0;

end;



procedure DeleteEventLog;

begin

  {Delete the file}

  DeleteFileA(MMLogFileName);

end;



{Finds the start and length of the file name given a full path.}

procedure ExtractFileName(APFullPath: PAnsiChar; var APFileNameStart: PAnsiChar; var AFileNameLength: Integer);

var

  LChar: AnsiChar;

begin

  {Initialize}

  APFileNameStart := APFullPath;

  AFileNameLength := 0;

  {Find the file }

  while True do

  begin

    {Get the next character}

    LChar := APFullPath^;

    {End of the path string?}

    if LChar = #0 then

      Break;

    {Advance the buffer position}

    Inc(APFullPath);

    {Found a backslash? -> May be the start of the file name}

    if LChar = '\' then

      APFileNameStart := APFullPath;

  end;

  {Calculate the length of the file name}

  AFileNameLength := IntPtr(APFullPath) - IntPtr(APFileNameStart);

end;



procedure AppendEventLog(ABuffer: Pointer; ACount: Cardinal);

const

  {Declared here, because it is not declared in the SHFolder.pas unit of some older Delphi versions.}

  SHGFP_TYPE_CURRENT = 0;

var

  LFileHandle, LBytesWritten: Cardinal;

  LEventHeader: array[0..1023] of AnsiChar;

  LAlternateLogFileName: array[0..2047] of AnsiChar;

  LPathLen, LNameLength: Integer;

  LMsgPtr, LPFileName: PAnsiChar;

  LSystemTime: TSystemTime;

begin

  {Try to open the log file in read/write mode.}

  LFileHandle := CreateFileA(MMLogFileName, GENERIC_READ or GENERIC_WRITE,

    0, nil, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);

  {Did log file creation fail? If so, the destination folder is perhaps read-only:

   Try to redirect logging to a file in the user's "My Documents" folder.}

  if (LFileHandle = INVALID_HANDLE_VALUE)

{$ifdef Delphi4or5}

    and SHGetSpecialFolderPathA(0, @LAlternateLogFileName, CSIDL_PERSONAL, True) then

{$else}

    and (SHGetFolderPathA(0, CSIDL_PERSONAL or CSIDL_FLAG_CREATE, 0,

      SHGFP_TYPE_CURRENT, @LAlternateLogFileName) = S_OK) then

{$endif}

  begin

    {Extract the filename part from MMLogFileName and append it to the path of

     the "My Documents" folder.}

    LPathLen := StrLen(LAlternateLogFileName);

    {Ensure that there is a trailing backslash in the path}

    if (LPathLen = 0) or (LAlternateLogFileName[LPathLen - 1] <> '\') then

    begin

      LAlternateLogFileName[LPathLen] := '\';

      Inc(LPathLen);

    end;

    {Add the filename to the path}

    ExtractFileName(@MMLogFileName, LPFileName, LNameLength);

    System.Move(LPFileName^, LAlternateLogFileName[LPathLen], LNameLength + 1);

    {Try to open the alternate log file}

    LFileHandle := CreateFileA(LAlternateLogFileName, GENERIC_READ or GENERIC_WRITE,

      0, nil, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);

  end;

  {Was the log file opened/created successfully?}

  if LFileHandle <> INVALID_HANDLE_VALUE then

  begin

    {Seek to the end of the file}

    SetFilePointer(LFileHandle, 0, nil, FILE_END);

    {Set the separator}

    LMsgPtr := AppendStringToBuffer(CRLF, @LEventHeader[0], Length(CRLF));

    LMsgPtr := AppendStringToBuffer(EventSeparator, LMsgPtr, Length(EventSeparator));

    {Set the date & time}

    GetLocalTime(LSystemTime);

    LMsgPtr := NativeUIntToStrBuf(LSystemTime.wYear, LMsgPtr);

    LMsgPtr^ := '/';

    Inc(LMsgPtr);

    LMsgPtr := NativeUIntToStrBuf(LSystemTime.wMonth, LMsgPtr);

    LMsgPtr^ := '/';

    Inc(LMsgPtr);

    LMsgPtr := NativeUIntToStrBuf(LSystemTime.wDay, LMsgPtr);

    LMsgPtr^ := ' ';

    Inc(LMsgPtr);

    LMsgPtr := NativeUIntToStrBuf(LSystemTime.wHour, LMsgPtr);

    LMsgPtr^ := ':';

    Inc(LMsgPtr);

    if LSystemTime.wMinute < 10 then

    begin

      LMsgPtr^ := '0';

      Inc(LMsgPtr);

    end;

    LMsgPtr := NativeUIntToStrBuf(LSystemTime.wMinute, LMsgPtr);

    LMsgPtr^ := ':';

    Inc(LMsgPtr);

    if LSystemTime.wSecond < 10 then

    begin

      LMsgPtr^ := '0';

      Inc(LMsgPtr);

    end;

    LMsgPtr := NativeUIntToStrBuf(LSystemTime.WSecond, LMsgPtr);

    {Write the header}

    LMsgPtr := AppendStringToBuffer(EventSeparator, LMsgPtr, Length(EventSeparator));

    LMsgPtr := AppendStringToBuffer(CRLF, LMsgPtr, Length(CRLF));

    WriteFile(LFileHandle, LEventHeader[0], NativeUInt(LMsgPtr) - NativeUInt(@LEventHeader[0]), LBytesWritten, nil);

    {Write the data}

    WriteFile(LFileHandle, ABuffer^, ACount, LBytesWritten, nil);

    {Close the file}

    CloseHandle(LFileHandle);

  end;

end;



{Sets the default log filename}

procedure SetDefaultMMLogFileName;

const

  LogFileExtAnsi: PAnsiChar = LogFileExtension;

var

  LEnvVarLength, LModuleNameLength: Cardinal;

  LPathOverride: array[0..2047] of AnsiChar;

  LPFileName: PAnsiChar;

  LFileNameLength: Integer;

begin

  {Get the name of the application}

  LModuleNameLength := AppendModuleFileName(@MMLogFileName[0]);

  {Replace the last few characters of the module name, and optionally override

   the path.}

  if LModuleNameLength > 0 then

  begin

    {Change the filename}

    System.Move(LogFileExtAnsi^, MMLogFileName[LModuleNameLength - 4],

      StrLen(LogFileExtAnsi) + 1);

    {Try to read the FastMMLogFilePath environment variable}

    LEnvVarLength := GetEnvironmentVariableA('FastMMLogFilePath',

      @LPathOverride, 1023);

    {Does the environment variable exist? If so, override the log file path.}

    if LEnvVarLength > 0 then

    begin

      {Ensure that there's a trailing backslash.}

      if LPathOverride[LEnvVarLength - 1] <> '\' then

      begin

        LPathOverride[LEnvVarLength] := '\';

        Inc(LEnvVarLength);

      end;

      {Add the filename to the path override}

      ExtractFileName(@MMLogFileName[0], LPFileName, LFileNameLength);

      System.Move(LPFileName^, LPathOverride[LEnvVarLength], LFileNameLength + 1);

      {Copy the override path back to the filename buffer}

      System.Move(LPathOverride, MMLogFileName, SizeOf(MMLogFileName) - 1);

    end;

  end;

end;



{Specify the full path and name for the filename to be used for logging memory

 errors, etc. If ALogFileName is nil or points to an empty string it will

 revert to the default log file name.}

procedure SetMMLogFileName(ALogFileName: PAnsiChar = nil);

var

  LLogFileNameLen: Integer;

begin

  {Is ALogFileName valid?}

  if (ALogFileName <> nil) and (ALogFileName^ <> #0) then

  begin

    LLogFileNameLen := StrLen(ALogFileName);

    if LLogFileNameLen < Length(MMLogFileName) then

    begin

      {Set the log file name}

      System.Move(ALogFileName^, MMLogFileName, LLogFileNameLen + 1);

      Exit;

    end;

  end;

  {Invalid log file name}

  SetDefaultMMLogFileName;

end;



{Returns the current "allocation group". Whenever a GetMem request is serviced

 in FullDebugMode, the current "allocation group" is stored in the block header.

 This may help with debugging. Note that if a block is subsequently reallocated

 that it keeps its original "allocation group" and "allocation number" (all

 allocations are also numbered sequentially).}

function GetCurrentAllocationGroup: Cardinal;

begin

  Result := AllocationGroupStack[AllocationGroupStackTop];

end;



{Allocation groups work in a stack like fashion. Group numbers are pushed onto

 and popped off the stack. Note that the stack size is limited, so every push

 should have a matching pop.}

procedure PushAllocationGroup(ANewCurrentAllocationGroup: Cardinal);

begin

  if AllocationGroupStackTop < AllocationGroupStackSize - 1 then

  begin

    Inc(AllocationGroupStackTop);

    AllocationGroupStack[AllocationGroupStackTop] := ANewCurrentAllocationGroup;

  end

  else

  begin

    {Raise a runtime error if the stack overflows}

  {$ifdef BCB6OrDelphi7AndUp}

    System.Error(reInvalidPtr);

  {$else}

    System.RunError(reInvalidPtr);

  {$endif}

  end;

end;



procedure PopAllocationGroup;

begin

  if AllocationGroupStackTop > 0 then

  begin

    Dec(AllocationGroupStackTop);

  end

  else

  begin

    {Raise a runtime error if the stack underflows}

  {$ifdef BCB6OrDelphi7AndUp}

    System.Error(reInvalidPtr);

  {$else}

    System.RunError(reInvalidPtr);

  {$endif}

  end;

end;



{Sums all the dwords starting at the given address. ACount must be > 0 and a

 multiple of SizeOf(Pointer).}

function SumNativeUInts(AStartValue: NativeUInt; APointer: PNativeUInt;

  ACount: NativeUInt): NativeUInt;

asm

{$ifdef 32Bit}

  {On entry: eax = AStartValue, edx = APointer; ecx = ACount}

  add edx, ecx

  neg ecx

@AddLoop:

  add eax, [edx + ecx]

  add ecx, 4

  js @AddLoop

{$else}

  {On entry: rcx = AStartValue, rdx = APointer; r8 = ACount}

  add rdx, r8

  neg r8

  mov rax, rcx

@AddLoop:

  add rax, [rdx + r8]

  add r8, 8

  js @AddLoop

{$endif}

end;



{Checks the memory starting at the given address for the fill pattern.

 Returns True if all bytes are all valid. ACount must be >0 and a multiple of

 SizeOf(Pointer).}

function CheckFillPattern(APointer: Pointer; ACount: NativeUInt;

  AFillPattern: NativeUInt): Boolean;

asm

{$ifdef 32Bit}

  {On entry: eax = APointer; edx = ACount; ecx = AFillPattern}

  add eax, edx

  neg edx

@CheckLoop:

  cmp [eax + edx], ecx

  jne @Done

  add edx, 4

  js @CheckLoop

@Done:

  sete al

{$else}

  {On entry: rcx = APointer; rdx = ACount; r8 = AFillPattern}

  add rcx, rdx

  neg rdx

@CheckLoop:

  cmp [rcx + rdx], r8

  jne @Done

  add rdx, 8

  js @CheckLoop

@Done:

  sete al

{$endif}

end;



{Calculates the checksum for the debug header. Adds all dwords in the debug

 header to the start address of the block.}

function CalculateHeaderCheckSum(APointer: PFullDebugBlockHeader): NativeUInt;

begin

  Result := SumNativeUInts(

    NativeUInt(APointer),

    PNativeUInt(PByte(APointer) + 2 * SizeOf(Pointer)),

    SizeOf(TFullDebugBlockHeader) - 2 * SizeOf(Pointer) - SizeOf(NativeUInt));

end;



procedure UpdateHeaderAndFooterCheckSums(APointer: PFullDebugBlockHeader);

var

  LHeaderCheckSum: NativeUInt;

begin

  LHeaderCheckSum := CalculateHeaderCheckSum(APointer);

  APointer.HeaderCheckSum := LHeaderCheckSum;

  PNativeUInt(PByte(APointer) + SizeOf(TFullDebugBlockHeader) + APointer.UserSize)^ := not LHeaderCheckSum;

end;



function LogCurrentThreadAndStackTrace(ASkipFrames: Cardinal; ABuffer: PAnsiChar): PAnsiChar;

var

  LCurrentStackTrace: TStackTrace;

begin

  {Get the current call stack}

  GetStackTrace(@LCurrentStackTrace[0], StackTraceDepth, ASkipFrames);

  {Log the thread ID}

  Result := AppendStringToBuffer(CurrentThreadIDMsg, ABuffer, Length(CurrentThreadIDMsg));

  Result := NativeUIntToHexBuf(GetThreadID, Result);

  {List the stack trace}

  Result := AppendStringToBuffer(CurrentStackTraceMsg, Result, Length(CurrentStackTraceMsg));

  Result := LogStackTrace(@LCurrentStackTrace, StackTraceDepth, Result);

end;



{$ifndef DisableLoggingOfMemoryDumps}

function LogMemoryDump(APointer: PFullDebugBlockHeader; ABuffer: PAnsiChar): PAnsiChar;

var

  LByteNum, LVal: Cardinal;

  LDataPtr: PByte;

begin

  Result := AppendStringToBuffer(MemoryDumpMsg, ABuffer, Length(MemoryDumpMsg));

  Result := NativeUIntToHexBuf(NativeUInt(APointer) + SizeOf(TFullDebugBlockHeader), Result);

  Result^ := ':';

  Inc(Result);

  {Add the bytes}

  LDataPtr := PByte(PByte(APointer) + SizeOf(TFullDebugBlockHeader));

  for LByteNum := 0 to 255 do

  begin

    if LByteNum and 31 = 0 then

    begin

      Result^ := #13;

      Inc(Result);

      Result^ := #10;

      Inc(Result);

    end

    else

    begin

      Result^ := ' ';

      Inc(Result);

    end;

    {Set the hex data}

    LVal := Byte(LDataPtr^);

    Result^ := HexTable[LVal shr 4];

    Inc(Result);

    Result^ := HexTable[LVal and $f];

    Inc(Result);

    {Next byte}

    Inc(LDataPtr);

  end;

  {Dump ASCII}

  LDataPtr := PByte(PByte(APointer) + SizeOf(TFullDebugBlockHeader));

  for LByteNum := 0 to 255 do

  begin

    if LByteNum and 31 = 0 then

    begin

      Result^ := #13;

      Inc(Result);

      Result^ := #10;

      Inc(Result);

    end

    else

    begin

      Result^ := ' ';

      Inc(Result);

      Result^ := ' ';

      Inc(Result);

    end;

    {Set the hex data}

    LVal := Byte(LDataPtr^);

    if LVal < 32 then

      Result^ := '.'

    else

      Result^ := AnsiChar(LVal);

    Inc(Result);

    {Next byte}

    Inc(LDataPtr);

  end;

end;

{$endif}



{Rotates AValue ABitCount bits to the right}

function RotateRight(AValue, ABitCount: NativeUInt): NativeUInt;

asm

{$ifdef 32Bit}

  mov ecx, edx

  ror eax, cl

{$else}

  mov rax, rcx

  mov rcx, rdx

  ror rax, cl

{$endif}

end;



{Determines whether a byte in the user portion of the freed block has been modified. Does not work beyond

 the end of the user portion (i.e. footer and beyond).}

function FreeBlockByteWasModified(APointer: PFullDebugBlockHeader; AUserOffset: NativeUInt): Boolean;

var

  LFillPattern: NativeUInt;

begin

  {Get the expected fill pattern}

  if AUserOffset < SizeOf(Pointer) then

  begin

    LFillPattern := NativeUInt(@FreedObjectVMT.VMTMethods[0]);

  end

  else

  begin

{$ifndef CatchUseOfFreedInterfaces}

    LFillPattern := DebugFillPattern;

{$else}

    LFillPattern := NativeUInt(@VMTBadInterface);

{$endif}

  end;

  {Compare the byte value}

  Result := Byte(PByte(PByte(APointer) + SizeOf(TFullDebugBlockHeader) + AUserOffset)^) <>

    Byte(RotateRight(LFillPattern, (AUserOffset and (SizeOf(Pointer) - 1)) * 8));

end;



function LogBlockChanges(APointer: PFullDebugBlockHeader; ABuffer: PAnsiChar): PAnsiChar;

var

  LOffset, LChangeStart, LCount: NativeUInt;

  LLogCount: Integer;

begin

  {No errors logged so far}

  LLogCount := 0;

  {Log a maximum of 32 changes}

  LOffset := 0;

  while (LOffset < APointer.UserSize) and (LLogCount < 32) do

  begin

    {Has the byte been modified?}

    if FreeBlockByteWasModified(APointer, LOffset) then

    begin

      {Found the start of a changed block, now find the length}

      LChangeStart := LOffset;

      LCount := 0;

      while True do

      begin

        Inc(LCount);

        Inc(LOffset);

        if (LOffset >= APointer.UserSize)

          or (not FreeBlockByteWasModified(APointer, LOffset)) then

        begin

          Break;

        end;

      end;

      {Got the offset and length, now log it.}

      if LLogCount = 0 then

      begin

        ABuffer := AppendStringToBuffer(FreeModifiedDetailMsg, ABuffer, Length(FreeModifiedDetailMsg));

      end

      else

      begin

        ABuffer^ := ',';

        Inc(ABuffer);

        ABuffer^ := ' ';

        Inc(ABuffer);

      end;

      ABuffer := NativeUIntToStrBuf(LChangeStart, ABuffer);

      ABuffer^ := '(';

      Inc(ABuffer);

      ABuffer := NativeUIntToStrBuf(LCount, ABuffer);

      ABuffer^ := ')';

      Inc(ABuffer);

      {Increment the log count}

      Inc(LLogCount);

    end;

    {Next byte}

    Inc(LOffset);

  end;

  {Return the current buffer position}

  Result := ABuffer;

end;



procedure LogBlockError(APointer: PFullDebugBlockHeader; AOperation: TBlockOperation; LHeaderValid, LFooterValid: Boolean);

var

  LMsgPtr: PAnsiChar;

  LErrorMessage: array[0..32767] of AnsiChar;

{$ifndef NoMessageBoxes}

  LErrorMessageTitle: array[0..1023] of AnsiChar;

{$endif}

  LClass: TClass;

  {$ifdef CheckCppObjectTypeEnabled}

  LCppObjectTypeName: PAnsiChar;

  {$endif}

begin

  {Display the error header and the operation type.}

  LMsgPtr := AppendStringToBuffer(ErrorMsgHeader, @LErrorMessage[0], Length(ErrorMsgHeader));

  case AOperation of

    boGetMem: LMsgPtr := AppendStringToBuffer(GetMemMsg, LMsgPtr, Length(GetMemMsg));

    boFreeMem: LMsgPtr := AppendStringToBuffer(FreeMemMsg, LMsgPtr, Length(FreeMemMsg));

    boReallocMem: LMsgPtr := AppendStringToBuffer(ReallocMemMsg, LMsgPtr, Length(ReallocMemMsg));

    boBlockCheck: LMsgPtr := AppendStringToBuffer(BlockCheckMsg, LMsgPtr, Length(BlockCheckMsg));

  end;

  LMsgPtr := AppendStringToBuffer(OperationMsg, LMsgPtr, Length(OperationMsg));

  {Is the header still intact?}

  if LHeaderValid then

  begin

    {Is the footer still valid?}

    if LFooterValid then

    begin

      {A freed block has been modified, a double free has occurred, or an

       attempt was made to free a memory block allocated by a different

       instance of FastMM.}

      if AOperation <= boGetMem then

      begin

        LMsgPtr := AppendStringToBuffer(FreeModifiedErrorMsg, LMsgPtr, Length(FreeModifiedErrorMsg));

        {Log the exact changes that caused the error.}

        LMsgPtr := LogBlockChanges(APointer, LMsgPtr);

      end

      else

      begin

        {It is either a double free, or an attempt was made to free a block

         that was allocated via a different memory manager.}

        if APointer.AllocatedByRoutine = nil then

          LMsgPtr := AppendStringToBuffer(DoubleFreeErrorMsg, LMsgPtr, Length(DoubleFreeErrorMsg))

        else

          LMsgPtr := AppendStringToBuffer(WrongMMFreeErrorMsg, LMsgPtr, Length(WrongMMFreeErrorMsg));

      end;

    end

    else

    begin

      LMsgPtr := AppendStringToBuffer(BlockFooterCorruptedMsg, LMsgPtr, Length(BlockFooterCorruptedMsg))

    end;

    {Set the block size message}

    if AOperation <= boGetMem then

      LMsgPtr := AppendStringToBuffer(PreviousBlockSizeMsg, LMsgPtr, Length(PreviousBlockSizeMsg))

    else

      LMsgPtr := AppendStringToBuffer(CurrentBlockSizeMsg, LMsgPtr, Length(CurrentBlockSizeMsg));

    LMsgPtr := NativeUIntToStrBuf(APointer.UserSize, LMsgPtr);

    {The header is still intact - display info about the this/previous allocation}

    if APointer.AllocationStackTrace[0] <> 0 then

    begin

      if AOperation <= boGetMem then

        LMsgPtr := AppendStringToBuffer(ThreadIDPrevAllocMsg, LMsgPtr, Length(ThreadIDPrevAllocMsg))

      else

        LMsgPtr := AppendStringToBuffer(ThreadIDAtAllocMsg, LMsgPtr, Length(ThreadIDAtAllocMsg));

      LMsgPtr := NativeUIntToHexBuf(APointer.AllocatedByThread, LMsgPtr);

      LMsgPtr := AppendStringToBuffer(StackTraceMsg, LMsgPtr, Length(StackTraceMsg));

      LMsgPtr := LogStackTrace(@APointer.AllocationStackTrace, StackTraceDepth, LMsgPtr);

    end;

    {Get the class this block was used for previously}

    LClass := DetectClassInstance(@APointer.PreviouslyUsedByClass);

    if (LClass <> nil) and (IntPtr(LClass) <> IntPtr(@FreedObjectVMT.VMTMethods[0])) then

    begin

      LMsgPtr := AppendStringToBuffer(PreviousObjectClassMsg, LMsgPtr, Length(PreviousObjectClassMsg));

      LMsgPtr := AppendClassNameToBuffer(LClass, LMsgPtr);

    end;

    {$ifdef CheckCppObjectTypeEnabled}

    if (LClass = nil) and Assigned(GetCppVirtObjTypeNameByVTablePtrFunc) then

    begin

      LCppObjectTypeName := GetCppVirtObjTypeNameByVTablePtrFunc(Pointer(APointer.PreviouslyUsedByClass), 0);

      if Assigned(LCppObjectTypeName) then

      begin

        LMsgPtr := AppendStringToBuffer(PreviousObjectClassMsg, LMsgPtr, Length(PreviousObjectClassMsg));

        LMsgPtr := AppendStringToBuffer(LCppObjectTypeName, LMsgPtr, StrLen(LCppObjectTypeName));

      end;

    end;

    {$endif}

    {Get the current class for this block}

    if (AOperation > boGetMem) and (APointer.AllocatedByRoutine <> nil) then

    begin

      LMsgPtr := AppendStringToBuffer(CurrentObjectClassMsg, LMsgPtr, Length(CurrentObjectClassMsg));

      LClass := DetectClassInstance(Pointer(PByte(APointer) + SizeOf(TFullDebugBlockHeader)));

      if IntPtr(LClass) = IntPtr(@FreedObjectVMT.VMTMethods[0]) then

        LClass := nil;

      {$ifndef CheckCppObjectTypeEnabled}

      LMsgPtr := AppendClassNameToBuffer(LClass, LMsgPtr);

      {$else}

      if (LClass = nil) and Assigned(GetCppVirtObjTypeNameFunc) then

      begin

        LCppObjectTypeName := GetCppVirtObjTypeNameFunc(Pointer(PByte(APointer) + SizeOf(TFullDebugBlockHeader)),

          APointer.UserSize);

        if LCppObjectTypeName <> nil then

          LMsgPtr := AppendStringToBuffer(LCppObjectTypeName, LMsgPtr, StrLen(LCppObjectTypeName))

        else

          LMsgPtr := AppendClassNameToBuffer(LClass, LMsgPtr);

      end

      else

      begin

        LMsgPtr := AppendClassNameToBuffer(LClass, LMsgPtr);

      end;

      {$endif}

      {Log the allocation group}

      if APointer.AllocationGroup > 0 then

      begin

        LMsgPtr := AppendStringToBuffer(CurrentAllocationGroupMsg, LMsgPtr, Length(CurrentAllocationGroupMsg));

        LMsgPtr := NativeUIntToStrBuf(APointer.AllocationGroup, LMsgPtr);

      end;

      {Log the allocation number}

      LMsgPtr := AppendStringToBuffer(CurrentAllocationNumberMsg, LMsgPtr, Length(CurrentAllocationNumberMsg));

      LMsgPtr := NativeUIntToStrBuf(APointer.AllocationNumber, LMsgPtr);

    end

    else

    begin

      {Log the allocation group}

      if APointer.AllocationGroup > 0 then

      begin

        LMsgPtr := AppendStringToBuffer(PreviousAllocationGroupMsg, LMsgPtr, Length(PreviousAllocationGroupMsg));

        LMsgPtr := NativeUIntToStrBuf(APointer.AllocationGroup, LMsgPtr);

      end;

      {Log the allocation number}

      LMsgPtr := AppendStringToBuffer(PreviousAllocationNumberMsg, LMsgPtr, Length(PreviousAllocationNumberMsg));

      LMsgPtr := NativeUIntToStrBuf(APointer.AllocationNumber, LMsgPtr);

    end;

    {Get the call stack for the previous free}

    if APointer.FreeStackTrace[0] <> 0 then

    begin

      LMsgPtr := AppendStringToBuffer(ThreadIDAtFreeMsg, LMsgPtr, Length(ThreadIDAtFreeMsg));

      LMsgPtr := NativeUIntToHexBuf(APointer.FreedByThread, LMsgPtr);

      LMsgPtr := AppendStringToBuffer(StackTraceMsg, LMsgPtr, Length(StackTraceMsg));

      LMsgPtr := LogStackTrace(@APointer.FreeStackTrace, StackTraceDepth, LMsgPtr);

    end;

  end

  else

  begin

    {Header has been corrupted}

    LMsgPtr := AppendStringToBuffer(BlockHeaderCorruptedMsg, LMsgPtr, Length(BlockHeaderCorruptedMsg));

  end;

  {Add the current stack trace}

  LMsgPtr := LogCurrentThreadAndStackTrace(3 + Ord(AOperation <> boGetMem) + Ord(AOperation = boReallocMem), LMsgPtr);

{$ifndef DisableLoggingOfMemoryDumps}

  {Add the memory dump}

  LMsgPtr := LogMemoryDump(APointer, LMsgPtr);

{$endif}

  {Trailing CRLF}

  LMsgPtr^ := #13;

  Inc(LMsgPtr);

  LMsgPtr^ := #10;

  Inc(LMsgPtr);

  {Trailing #0}

  LMsgPtr^ := #0;

{$ifdef LogErrorsToFile}

  {Log the error}

  AppendEventLog(@LErrorMessage[0], NativeUInt(LMsgPtr) - NativeUInt(@LErrorMessage[0]));

{$endif}

{$ifdef UseOutputDebugString}

  OutputDebugStringA(LErrorMessage);

{$endif}

  {Show the message}

{$ifndef NoMessageBoxes}

  AppendStringToModuleName(BlockErrorMsgTitle, LErrorMessageTitle);

  ShowMessageBox(LErrorMessage, LErrorMessageTitle);

{$endif}

end;



{Logs the stack traces for a memory leak to file}

procedure LogMemoryLeakOrAllocatedBlock(APointer: PFullDebugBlockHeader; IsALeak: Boolean);

var

  LHeaderValid: Boolean;

  LMsgPtr: PAnsiChar;

  LErrorMessage: array[0..32767] of AnsiChar;

  LClass: TClass;

  {$ifdef CheckCppObjectTypeEnabled}

  LCppObjectTypeName: PAnsiChar;

  {$endif}

begin

  {Display the error header and the operation type.}

  if IsALeak then

    LMsgPtr := AppendStringToBuffer(LeakLogHeader, @LErrorMessage[0], Length(LeakLogHeader))

  else

    LMsgPtr := AppendStringToBuffer(BlockScanLogHeader, @LErrorMessage[0], Length(BlockScanLogHeader));

  LMsgPtr := NativeUIntToStrBuf(GetAvailableSpaceInBlock(APointer) - FullDebugBlockOverhead, LMsgPtr);

  {Is the debug info surrounding the block valid?}

  LHeaderValid := CalculateHeaderCheckSum(APointer) = APointer.HeaderCheckSum;

  {Is the header still intact?}

  if LHeaderValid then

  begin

    {The header is still intact - display info about this/previous allocation}

    if APointer.AllocationStackTrace[0] <> 0 then

    begin

      LMsgPtr := AppendStringToBuffer(ThreadIDAtAllocMsg, LMsgPtr, Length(ThreadIDAtAllocMsg));

      LMsgPtr := NativeUIntToHexBuf(APointer.AllocatedByThread, LMsgPtr);

      LMsgPtr := AppendStringToBuffer(StackTraceMsg, LMsgPtr, Length(StackTraceMsg));

      LMsgPtr := LogStackTrace(@APointer.AllocationStackTrace, StackTraceDepth, LMsgPtr);

    end;

    LMsgPtr := AppendStringToBuffer(CurrentObjectClassMsg, LMsgPtr, Length(CurrentObjectClassMsg));

    {Get the current class for this block}

    LClass := DetectClassInstance(Pointer(PByte(APointer) + SizeOf(TFullDebugBlockHeader)));

    if IntPtr(LClass) = IntPtr(@FreedObjectVMT.VMTMethods[0]) then

      LClass := nil;

    {$ifndef CheckCppObjectTypeEnabled}

    if LClass <> nil then

    begin

      LMsgPtr := AppendClassNameToBuffer(LClass, LMsgPtr);

    end

    else

    begin

      case DetectStringData(Pointer(PByte(APointer) + SizeOf(TFullDebugBlockHeader)), APointer.UserSize) of

        stUnknown: LMsgPtr := AppendClassNameToBuffer(nil, LMsgPtr);

        stAnsiString: LMsgPtr := AppendStringToBuffer(AnsiStringBlockMessage, LMsgPtr, Length(AnsiStringBlockMessage));

        stUnicodeString: LMsgPtr := AppendStringToBuffer(UnicodeStringBlockMessage, LMsgPtr, Length(UnicodeStringBlockMessage));

      end;

    end;

    {$else}

    if (LClass = nil) and Assigned(GetCppVirtObjTypeNameFunc) then

    begin

      LCppObjectTypeName := GetCppVirtObjTypeNameFunc(Pointer(PByte(APointer) + SizeOf(TFullDebugBlockHeader)),

        APointer.UserSize);

      if LCppObjectTypeName <> nil then

        LMsgPtr := AppendStringToBuffer(LCppObjectTypeName, LMsgPtr, StrLen(LCppObjectTypeName))

      else

      begin

        case DetectStringData(Pointer(PByte(APointer) + SizeOf(TFullDebugBlockHeader)), APointer.UserSize) of

          stUnknown: LMsgPtr := AppendClassNameToBuffer(nil, LMsgPtr);

          stAnsiString: LMsgPtr := AppendStringToBuffer(AnsiStringBlockMessage, LMsgPtr, Length(AnsiStringBlockMessage));

          stUnicodeString: LMsgPtr := AppendStringToBuffer(UnicodeStringBlockMessage, LMsgPtr, Length(UnicodeStringBlockMessage));

        end;

      end;

    end

    else

      LMsgPtr := AppendClassNameToBuffer(LClass, LMsgPtr);

    {$endif}

    {Log the allocation group}

    if APointer.AllocationGroup > 0 then

    begin

      LMsgPtr := AppendStringToBuffer(CurrentAllocationGroupMsg, LMsgPtr, Length(CurrentAllocationGroupMsg));

      LMsgPtr := NativeUIntToStrBuf(APointer.AllocationGroup, LMsgPtr);

    end;

    {Log the allocation number}

    LMsgPtr := AppendStringToBuffer(CurrentAllocationNumberMsg, LMsgPtr, Length(CurrentAllocationNumberMsg));

    LMsgPtr := NativeUIntToStrBuf(APointer.AllocationNumber, LMsgPtr);

  end

  else

  begin

    {Header has been corrupted}

    LMsgPtr^ := '.';

    Inc(LMsgPtr);

    LMsgPtr^ := ' ';

    Inc(LMsgPtr);

    LMsgPtr := AppendStringToBuffer(BlockHeaderCorruptedMsg, LMsgPtr, Length(BlockHeaderCorruptedMsg));

  end;

{$ifndef DisableLoggingOfMemoryDumps}

  {Add the memory dump}

  LMsgPtr := LogMemoryDump(APointer, LMsgPtr);

{$endif}

  {Trailing CRLF}

  LMsgPtr^ := #13;

  Inc(LMsgPtr);

  LMsgPtr^ := #10;

  Inc(LMsgPtr);

  {Trailing #0}

  LMsgPtr^ := #0;

  {Log the error}

  AppendEventLog(@LErrorMessage[0], NativeUInt(LMsgPtr) - NativeUInt(@LErrorMessage[0]));

end;



{Checks that a free block is unmodified}

function CheckFreeBlockUnmodified(APBlock: PFullDebugBlockHeader; ABlockSize: NativeUInt;

  AOperation: TBlockOperation): Boolean;

var

  LHeaderCheckSum: NativeUInt;

  LHeaderValid, LFooterValid, LBlockUnmodified: Boolean;

begin

  LHeaderCheckSum := CalculateHeaderCheckSum(APBlock);

  LHeaderValid := LHeaderCheckSum = APBlock.HeaderCheckSum;

  {Is the footer itself still in place}

  LFooterValid := LHeaderValid

    and (PNativeUInt(PByte(APBlock) + SizeOf(TFullDebugBlockHeader) + APBlock.UserSize)^ = (not LHeaderCheckSum));

  {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.}

  if LFooterValid

    and (APBlock.UserSize < SizeOf(Pointer)) or (PNativeUInt(PByte(APBlock) + SizeOf(TFullDebugBlockHeader))^ = NativeUInt(@FreedObjectVMT.VMTMethods[0])) then

  begin

    {Store the debug fill pattern in place of the footer in order to simplify

     checking for block modifications.}

    PNativeUInt(PByte(APBlock) + SizeOf(TFullDebugBlockHeader) + APBlock.UserSize)^ :=

    {$ifndef CatchUseOfFreedInterfaces}

      DebugFillPattern;

    {$else}

      RotateRight(NativeUInt(@VMTBadInterface), (APBlock.UserSize and (SizeOf(Pointer) - 1)) * 8);

    {$endif}

    {Check that all the filler bytes are valid inside the block, except for

     the "dummy" class header}

    LBlockUnmodified := CheckFillPattern(PNativeUInt(PByte(APBlock) + (SizeOf(TFullDebugBlockHeader) + SizeOf(Pointer))),

      ABlockSize - (FullDebugBlockOverhead + SizeOf(Pointer)),

      {$ifndef CatchUseOfFreedInterfaces}DebugFillPattern{$else}NativeUInt(@VMTBadInterface){$endif});

    {Reset the old footer}

    PNativeUInt(PByte(APBlock) + SizeOf(TFullDebugBlockHeader) + APBlock.UserSize)^ := not LHeaderCheckSum;

  end

  else

    LBlockUnmodified := False;

  if (not LHeaderValid) or (not LFooterValid) or (not LBlockUnmodified) then

  begin

    LogBlockError(APBlock, AOperation, LHeaderValid, LFooterValid);

    Result := False;

  end

  else

    Result := True;

end;



function DebugGetMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer;

begin

  {Scan the entire memory pool first?}

  if FullDebugModeScanMemoryPoolBeforeEveryOperation then

    ScanMemoryPoolForCorruptions;

  {Enter the memory manager: block scans may not be performed now}

  StartChangingFullDebugModeBlock;

  try

    {We need extra space for (a) The debug header, (b) the block debug trailer

     and (c) the trailing block size pointer for free blocks}

    Result := FastGetMem(ASize + FullDebugBlockOverhead);

    if Result <> nil then

    begin

      {Large blocks are always newly allocated (and never reused), so checking

       for a modify-after-free is not necessary.}

      if (ASize > (MaximumMediumBlockSize - BlockHeaderSize - FullDebugBlockOverhead))

        or CheckFreeBlockUnmodified(Result, GetAvailableSpaceInBlock(Result) + BlockHeaderSize, boGetMem) then

      begin

        {Set the allocation call stack}

        GetStackTrace(@PFullDebugBlockHeader(Result).AllocationStackTrace, StackTraceDepth, 1);

        {Set the thread ID of the thread that allocated the block}

        PFullDebugBlockHeader(Result).AllocatedByThread := GetThreadID;

        {Block is now in use: It was allocated by this routine}

        PFullDebugBlockHeader(Result).AllocatedByRoutine := @DebugGetMem;

        {Set the group number}

        PFullDebugBlockHeader(Result).AllocationGroup := AllocationGroupStack[AllocationGroupStackTop];

        {Set the allocation number}

        IncrementAllocationNumber;

        PFullDebugBlockHeader(Result).AllocationNumber := CurrentAllocationNumber;

        {Clear the previous block trailer}

        PNativeUInt(PByte(Result) + SizeOf(TFullDebugBlockHeader) + PFullDebugBlockHeader(Result).UserSize)^ :=

        {$ifndef CatchUseOfFreedInterfaces}

          DebugFillPattern;

        {$else}

          RotateRight(NativeUInt(@VMTBadInterface), (PFullDebugBlockHeader(Result).UserSize and (SizeOf(Pointer) - 1)) * 8);

        {$endif}

        {Set the user size for the block}

        PFullDebugBlockHeader(Result).UserSize := ASize;

        {Set the checksums}

        UpdateHeaderAndFooterCheckSums(Result);

        {$ifdef FullDebugModeCallBacks}

        if Assigned(OnDebugGetMemFinish) then

          OnDebugGetMemFinish(PFullDebugBlockHeader(Result), ASize);

        {$endif}

        {Return the start of the actual block}

        Result := Pointer(PByte(Result) + SizeOf(TFullDebugBlockHeader));

{$ifdef EnableMemoryLeakReporting}

        {Should this block be marked as an expected leak automatically?}

        if FullDebugModeRegisterAllAllocsAsExpectedMemoryLeak then

          RegisterExpectedMemoryLeak(Result);

{$endif}

      end

      else

      begin

        Result := nil;

      end;

    end;

  finally

    {Leaving the memory manager routine: Block scans may be performed again.}

    DoneChangingFullDebugModeBlock;

  end;

end;



function CheckBlockBeforeFreeOrRealloc(APBlock: PFullDebugBlockHeader;

  AOperation: TBlockOperation): Boolean;

var

  LHeaderValid, LFooterValid: Boolean;

  LPFooter: PNativeUInt;

{$ifndef CatchUseOfFreedInterfaces}

  LBlockSize: NativeUInt;

  LPTrailingByte, LPFillPatternEnd: PByte;

{$endif}

begin

  {Is the checksum for the block header valid?}

  LHeaderValid := CalculateHeaderCheckSum(APBlock) = APBlock.HeaderCheckSum;

  {If the header is corrupted then the footer is assumed to be corrupt too.}

  if LHeaderValid then

  begin

    {Check the footer checksum: The footer checksum should equal the header

     checksum with all bits inverted.}

    LPFooter := PNativeUInt(PByte(APBlock) + SizeOf(TFullDebugBlockHeader) + PFullDebugBlockHeader(APBlock).UserSize);

    if APBlock.HeaderCheckSum = (not (LPFooter^)) then

    begin

      LFooterValid := True;

{$ifndef CatchUseOfFreedInterfaces}

      {Large blocks do not have the debug fill pattern, since they are never reused.}

      if PNativeUInt(PByte(APBlock) - BlockHeaderSize)^ and (IsMediumBlockFlag or IsLargeBlockFlag) <> IsLargeBlockFlag then

      begin

        {Check that the application has not modified bytes beyond the block

         footer. The $80 fill pattern should extend up to 2 nativeints before

         the start of the next block (leaving space for the free block size and

         next block header.)}

        LBlockSize := GetAvailableSpaceInBlock(APBlock);

        LPFillPatternEnd := PByte(PByte(APBlock) + LBlockSize - SizeOf(Pointer));

        LPTrailingByte := PByte(PByte(LPFooter) + SizeOf(NativeUInt));

        while UIntPtr(LPTrailingByte) < UIntPtr(LPFillPatternEnd) do

        begin

          if Byte(LPTrailingByte^) <> DebugFillByte then

          begin

            LFooterValid := False;

            Break;

          end;

          Inc(LPTrailingByte);

        end;

      end;

{$endif}

    end

    else

      LFooterValid := False;

  end

  else

    LFooterValid := False;

  {The header and footer must be intact and the block must have been allocated

   by this memory manager instance.}

  if LFooterValid and (APBlock.AllocatedByRoutine = @DebugGetMem) then

  begin

    Result := True;

  end

  else

  begin

    {Log the error}

    LogBlockError(APBlock, AOperation, LHeaderValid, LFooterValid);

    {Return an error}

    Result := False;

  end;

end;



function DebugFreeMem(APointer: Pointer): Integer;

var

  LActualBlock: PFullDebugBlockHeader;

  LBlockHeader: NativeUInt;

begin

  {Scan the entire memory pool first?}

  if FullDebugModeScanMemoryPoolBeforeEveryOperation then

    ScanMemoryPoolForCorruptions;

  {Get a pointer to the start of the actual block}

  LActualBlock := PFullDebugBlockHeader(PByte(APointer)

    - SizeOf(TFullDebugBlockHeader));

  {Is the debug info surrounding the block valid?}

  if CheckBlockBeforeFreeOrRealloc(LActualBlock, boFreeMem) then

  begin

    {Enter the memory manager: block scans may not be performed now}

    StartChangingFullDebugModeBlock;

    try

      {$ifdef FullDebugModeCallBacks}

      if Assigned(OnDebugFreeMemStart) then

        OnDebugFreeMemStart(LActualBlock);

      {$endif}

      {Large blocks are never reused, so there is no point in updating their

       headers and fill pattern.}

      LBlockHeader := PNativeUInt(PByte(LActualBlock) - BlockHeaderSize)^;

      if LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag or IsLargeBlockFlag) <> IsLargeBlockFlag then

      begin

        {Get the class the block was used for}

        LActualBlock.PreviouslyUsedByClass := PNativeUInt(APointer)^;

        {Set the free call stack}

        GetStackTrace(@LActualBlock.FreeStackTrace, StackTraceDepth, 1);

        {Set the thread ID of the thread that freed the block}

        LActualBlock.FreedByThread := GetThreadID;

        {Block is now free}

        LActualBlock.AllocatedByRoutine := nil;

        {Clear the user area of the block}

        DebugFillMem(APointer^, LActualBlock.UserSize,

          {$ifndef CatchUseOfFreedInterfaces}DebugFillPattern{$else}NativeUInt(@VMTBadInterface){$endif});

        {Set a pointer to the dummy VMT}

        PNativeUInt(APointer)^ := NativeUInt(@FreedObjectVMT.VMTMethods[0]);

        {Recalculate the checksums}

        UpdateHeaderAndFooterCheckSums(LActualBlock);

      end;

{$ifdef EnableMemoryLeakReporting}

      {Automatically deregister the expected memory leak?}

      if FullDebugModeRegisterAllAllocsAsExpectedMemoryLeak then

        UnregisterExpectedMemoryLeak(APointer);

{$endif}

      {Free the actual block}

      Result := FastFreeMem(LActualBlock);

      {$ifdef FullDebugModeCallBacks}

      if Assigned(OnDebugFreeMemFinish) then

        OnDebugFreeMemFinish(LActualBlock, Result);

      {$endif}

    finally

      {Leaving the memory manager routine: Block scans may be performed again.}

      DoneChangingFullDebugModeBlock;

    end;

  end

  else

  begin

{$ifdef SuppressFreeMemErrorsInsideException}

    if {$ifdef BDS2006AndUp}ExceptObject{$else}RaiseList{$endif} <> nil then

      Result := 0

    else

{$endif}

      Result := -1;

  end;

end;



function DebugReallocMem(APointer: Pointer; ANewSize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer;

var

  LMoveSize, LBlockSpace: NativeUInt;

  LActualBlock, LNewActualBlock: PFullDebugBlockHeader;

begin

  {Scan the entire memory pool first?}

  if FullDebugModeScanMemoryPoolBeforeEveryOperation then

    ScanMemoryPoolForCorruptions;

  {Get a pointer to the start of the actual block}

  LActualBlock := PFullDebugBlockHeader(PByte(APointer)

    - SizeOf(TFullDebugBlockHeader));

  {Is the debug info surrounding the block valid?}

  if CheckBlockBeforeFreeOrRealloc(LActualBlock, boReallocMem) then

  begin

    {Get the current block size}

    LBlockSpace := GetAvailableSpaceInBlock(LActualBlock);

    {Can the block fit? We need space for the debug overhead and the block header

     of the next block}

    if LBlockSpace < (NativeUInt(ANewSize) + FullDebugBlockOverhead) then

    begin

      {Get a new block of the requested size.}

      Result := DebugGetMem(ANewSize);

      if Result <> nil then

      begin

        {Block scans may not be performed now}

        StartChangingFullDebugModeBlock;

        try

          {$ifdef FullDebugModeCallBacks}

          if Assigned(OnDebugReallocMemStart) then

            OnDebugReallocMemStart(LActualBlock, ANewSize);

          {$endif}

          {We reuse the old allocation number. Since DebugGetMem always bumps

           CurrentAllocationGroup, there may be gaps in the sequence of

           allocation numbers.}

          LNewActualBlock := PFullDebugBlockHeader(PByte(Result)

            - SizeOf(TFullDebugBlockHeader));

          LNewActualBlock.AllocationGroup := LActualBlock.AllocationGroup;

          LNewActualBlock.AllocationNumber := LActualBlock.AllocationNumber;

          {Recalculate the header and footer checksums}

          UpdateHeaderAndFooterCheckSums(LNewActualBlock);

          {$ifdef FullDebugModeCallBacks}

          if Assigned(OnDebugReallocMemFinish) then

            OnDebugReallocMemFinish(LNewActualBlock, ANewSize);

          {$endif}

        finally

          {Block scans can again be performed safely}

          DoneChangingFullDebugModeBlock;

        end;

        {How many bytes to move?}

        LMoveSize := LActualBlock.UserSize;

        if LMoveSize > NativeUInt(ANewSize) then

          LMoveSize := ANewSize;

        {Move the data across}

        System.Move(APointer^, Result^, LMoveSize);

        {Free the old block}

        DebugFreeMem(APointer);

      end

      else

      begin

        Result := nil;

      end;

    end

    else

    begin

      {Block scans may not be performed now}

      StartChangingFullDebugModeBlock;

      try

        {$ifdef FullDebugModeCallBacks}

        if Assigned(OnDebugReallocMemStart) then

          OnDebugReallocMemStart(LActualBlock, ANewSize);

        {$endif}

        {Clear all data after the new end of the block up to the old end of the

         block, including the trailer.}

        DebugFillMem(Pointer(PByte(APointer) + NativeUInt(ANewSize) + SizeOf(NativeUInt))^,

          NativeInt(LActualBlock.UserSize) - ANewSize,

{$ifndef CatchUseOfFreedInterfaces}

          DebugFillPattern);

{$else}

          RotateRight(NativeUInt(@VMTBadInterface), (ANewSize and (SizeOf(Pointer) - 1)) * 8));

{$endif}

        {Update the user size}

        LActualBlock.UserSize := ANewSize;

        {Set the new checksums}

        UpdateHeaderAndFooterCheckSums(LActualBlock);

        {$ifdef FullDebugModeCallBacks}

        if Assigned(OnDebugReallocMemFinish) then

          OnDebugReallocMemFinish(LActualBlock, ANewSize);

        {$endif}

      finally

        {Block scans can again be performed safely}

        DoneChangingFullDebugModeBlock;

      end;

      {Return the old pointer}

      Result := APointer;

    end;

  end

  else

  begin

    Result := nil;

  end;

end;



{Allocates a block and fills it with zeroes}

function DebugAllocMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Cardinal{$endif}): Pointer;

begin

  Result := DebugGetMem(ASize);

  {Clear the block}

  if Result <>  nil then

    FillChar(Result^, ASize, 0);

end;



{Raises a runtime error if a memory corruption was encountered. Subroutine for

 InternalScanMemoryPool and InternalScanSmallBlockPool.}

procedure RaiseMemoryCorruptionError;

begin

  {Disable exhaustive checking in order to prevent recursive exceptions.}

  FullDebugModeScanMemoryPoolBeforeEveryOperation := False;

  {Unblock the memory manager in case the creation of the exception below

   causes an attempt to be made to allocate memory.}

  UnblockFullDebugModeMMRoutines;

  {Raise the runtime error}

{$ifdef BCB6OrDelphi7AndUp}

  System.Error(reOutOfMemory);

{$else}

  System.RunError(reOutOfMemory);

{$endif}

end;



{Subroutine for InternalScanMemoryPool: Checks the given small block pool for

 allocated blocks}

procedure InternalScanSmallBlockPool(APSmallBlockPool: PSmallBlockPoolHeader;

  AFirstAllocationGroupToLog, ALastAllocationGroupToLog: Cardinal);

var

  LCurPtr, LEndPtr: Pointer;

begin

  {Get the first and last pointer for the pool}

  GetFirstAndLastSmallBlockInPool(APSmallBlockPool, LCurPtr, LEndPtr);

  {Step through all blocks}

  while UIntPtr(LCurPtr) <= UIntPtr(LEndPtr) do

  begin

    {Is this block in use? If so, is the debug info intact?}

    if ((PNativeUInt(PByte(LCurPtr) - BlockHeaderSize)^ and IsFreeBlockFlag) = 0) then

    begin

      if CheckBlockBeforeFreeOrRealloc(LCurPtr, boBlockCheck) then

      begin

        if (PFullDebugBlockHeader(LCurPtr).AllocationGroup >= AFirstAllocationGroupToLog)

          and (PFullDebugBlockHeader(LCurPtr).AllocationGroup <= ALastAllocationGroupToLog) then

        begin

          LogMemoryLeakOrAllocatedBlock(LCurPtr, False);

        end;

      end

      else

        RaiseMemoryCorruptionError;

    end

    else

    begin

      {Check that the block has not been modified since being freed}

      if not CheckFreeBlockUnmodified(LCurPtr, APSmallBlockPool.BlockType.BlockSize, boBlockCheck) then

        RaiseMemoryCorruptionError;

    end;

    {Next block}

    Inc(PByte(LCurPtr), APSmallBlockPool.BlockType.BlockSize);

  end;

end;



{Subroutine for LogAllocatedBlocksToFile and ScanMemoryPoolForCorruptions:

 Scans the memory pool for corruptions and optionally logs allocated blocks

 in the allocation group range.}

procedure InternalScanMemoryPool(AFirstAllocationGroupToLog, ALastAllocationGroupToLog: Cardinal);

var

  LPLargeBlock: PLargeBlockHeader;

  LPMediumBlock: Pointer;

  LPMediumBlockPoolHeader: PMediumBlockPoolHeader;

  LMediumBlockHeader: NativeUInt;

begin

  {Block all the memory manager routines while performing the scan. No memory

   block may be allocated or freed, and no FullDebugMode block header or

   footer may be modified, while the scan is in progress.}

  BlockFullDebugModeMMRoutines;

  try

    {Step through all the medium block pools}

    LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader;

    while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do

    begin

      LPMediumBlock := GetFirstMediumBlockInPool(LPMediumBlockPoolHeader);

      while LPMediumBlock <> nil do

      begin

        LMediumBlockHeader := PNativeUInt(PByte(LPMediumBlock) - BlockHeaderSize)^;

        {Is the block in use?}

        if LMediumBlockHeader and IsFreeBlockFlag = 0 then

        begin

          {Block is in use: Is it a medium block or small block pool?}

          if (LMediumBlockHeader and IsSmallBlockPoolInUseFlag) <> 0 then

          begin

            {Get all the leaks for the small block pool}

            InternalScanSmallBlockPool(LPMediumBlock, AFirstAllocationGroupToLog, ALastAllocationGroupToLog);

          end

          else

          begin

            if CheckBlockBeforeFreeOrRealloc(LPMediumBlock, boBlockCheck) then

            begin

              if (PFullDebugBlockHeader(LPMediumBlock).AllocationGroup >= AFirstAllocationGroupToLog)

                and (PFullDebugBlockHeader(LPMediumBlock).AllocationGroup <= ALastAllocationGroupToLog) then

              begin

                LogMemoryLeakOrAllocatedBlock(LPMediumBlock, False);

              end;

            end

            else

              RaiseMemoryCorruptionError;

          end;

        end

        else

        begin

          {Check that the block has not been modified since being freed}

          if not CheckFreeBlockUnmodified(LPMediumBlock, LMediumBlockHeader and DropMediumAndLargeFlagsMask, boBlockCheck) then

            RaiseMemoryCorruptionError;

        end;

        {Next medium block}

        LPMediumBlock := NextMediumBlock(LPMediumBlock);

      end;

      {Get the next medium block pool}

      LPMediumBlockPoolHeader := LPMediumBlockPoolHeader.NextMediumBlockPoolHeader;

    end;

    {Scan large blocks}

    LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader;

    while LPLargeBlock <> @LargeBlocksCircularList do

    begin

      if CheckBlockBeforeFreeOrRealloc(Pointer(PByte(LPLargeBlock) + LargeBlockHeaderSize), boBlockCheck) then

      begin

        if (PFullDebugBlockHeader(PByte(LPLargeBlock) + LargeBlockHeaderSize).AllocationGroup >= AFirstAllocationGroupToLog)

          and (PFullDebugBlockHeader(PByte(LPLargeBlock) + LargeBlockHeaderSize).AllocationGroup <= ALastAllocationGroupToLog) then

        begin

          LogMemoryLeakOrAllocatedBlock(Pointer(PByte(LPLargeBlock) + LargeBlockHeaderSize), False);

        end;

      end

      else

        RaiseMemoryCorruptionError;

      {Get the next large block}

      LPLargeBlock := LPLargeBlock.NextLargeBlockHeader;

    end;

  finally

    {Unblock the FullDebugMode memory manager routines.}

    UnblockFullDebugModeMMRoutines;

  end;

end;



{Logs detail about currently allocated memory blocks for the specified range of

 allocation groups. if ALastAllocationGroupToLog is less than

 AFirstAllocationGroupToLog or it is zero, then all allocation groups are

 logged. This routine also checks the memory pool for consistency at the same

 time, raising an "Out of Memory" error if the check fails.}

procedure LogAllocatedBlocksToFile(AFirstAllocationGroupToLog, ALastAllocationGroupToLog: Cardinal);

begin

  {Validate input}

  if (ALastAllocationGroupToLog = 0) or (ALastAllocationGroupToLog < AFirstAllocationGroupToLog) then

  begin

    {Bad input: log all groups}

    AFirstAllocationGroupToLog := 0;

    ALastAllocationGroupToLog := $ffffffff;

  end;

  {Scan the memory pool, logging allocated blocks in the requested range.}

  InternalScanMemoryPool(AFirstAllocationGroupToLog, ALastAllocationGroupToLog);

end;



{Scans the memory pool for any corruptions. If a corruption is encountered an "Out of Memory" exception is

 raised.}

procedure ScanMemoryPoolForCorruptions;

begin

  {Scan the memory pool for corruptions, but don't log any allocated blocks}

  InternalScanMemoryPool($ffffffff, 0);

end;



{-----------------------Invalid Virtual Method Calls-------------------------}



{ TFreedObject }



{Used to determine the index of the virtual method call on the freed object.

 Do not change this without updating MaxFakeVMTEntries. Currently 200.}

procedure TFreedObject.GetVirtualMethodIndex;

asm

  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);

  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);

  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);

  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);

  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);



  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);

  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);

  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);

  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);

  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);



  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);

  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);

  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);

  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);

  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);



  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);

  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);

  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);

  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);

  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);



  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);

  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);

  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);

  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);

  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);



  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);

  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);

  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);

  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);

  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);



  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);

  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);

  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);

  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);

  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);



  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);

  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);

  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);

  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);

  Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);



  jmp TFreedObject.VirtualMethodError

end;



procedure TFreedObject.VirtualMethodError;

var

  LVMOffset: Integer;

  LMsgPtr: PAnsiChar;

  LErrorMessage: array[0..32767] of AnsiChar;

{$ifndef NoMessageBoxes}

  LErrorMessageTitle: array[0..1023] of AnsiChar;

{$endif}

  LClass: TClass;

  LActualBlock: PFullDebugBlockHeader;

begin

  {Get the offset of the virtual method}

  LVMOffset := (MaxFakeVMTEntries - VMIndex) * SizeOf(Pointer) + vmtParent + SizeOf(Pointer);

  {Reset the index for the next error}

  VMIndex := 0;

  {Get the address of the actual block}

  LActualBlock := PFullDebugBlockHeader(PByte(Self) - SizeOf(TFullDebugBlockHeader));

  {Display the error header}

  LMsgPtr := AppendStringToBuffer(VirtualMethodErrorHeader, @LErrorMessage[0], Length(VirtualMethodErrorHeader));

  {Is the debug info surrounding the block valid?}

  if CalculateHeaderCheckSum(LActualBlock) = LActualBlock.HeaderCheckSum then

  begin

    {Get the class this block was used for previously}

    LClass := DetectClassInstance(@LActualBlock.PreviouslyUsedByClass);

    if (LClass <> nil) and (IntPtr(LClass) <> IntPtr(@FreedObjectVMT.VMTMethods[0])) then

    begin

      LMsgPtr := AppendStringToBuffer(FreedObjectClassMsg, LMsgPtr, Length(FreedObjectClassMsg));

      LMsgPtr := AppendClassNameToBuffer(LClass, LMsgPtr);

    end;

    {Get the virtual method name}

    LMsgPtr := AppendStringToBuffer(VirtualMethodName, LMsgPtr, Length(VirtualMethodName));

    if LVMOffset < 0 then

    begin

      LMsgPtr := AppendStringToBuffer(StandardVirtualMethodNames[LVMOffset div SizeOf(Pointer)], LMsgPtr, Length(StandardVirtualMethodNames[LVMOffset div SizeOf(Pointer)]));

    end

    else

    begin

      LMsgPtr := AppendStringToBuffer(VirtualMethodOffset, LMsgPtr, Length(VirtualMethodOffset));

      LMsgPtr := NativeUIntToStrBuf(LVMOffset, LMsgPtr);

    end;

    {Virtual method address}

    if (LClass <> nil) and (IntPtr(LClass) <> IntPtr(@FreedObjectVMT.VMTMethods[0])) then

    begin

      LMsgPtr := AppendStringToBuffer(VirtualMethodAddress, LMsgPtr, Length(VirtualMethodAddress));

      LMsgPtr := NativeUIntToHexBuf(PNativeUInt(PByte(LClass) + LVMOffset)^, LMsgPtr);

    end;

    {Log the allocation group}

    if LActualBlock.AllocationGroup > 0 then

    begin

      LMsgPtr := AppendStringToBuffer(PreviousAllocationGroupMsg, LMsgPtr, Length(PreviousAllocationGroupMsg));

      LMsgPtr := NativeUIntToStrBuf(LActualBlock.AllocationGroup, LMsgPtr);

    end;

    {Log the allocation number}

    LMsgPtr := AppendStringToBuffer(PreviousAllocationNumberMsg, LMsgPtr, Length(PreviousAllocationNumberMsg));

    LMsgPtr := NativeUIntToStrBuf(LActualBlock.AllocationNumber, LMsgPtr);

    {The header is still intact - display info about the this/previous allocation}

    if LActualBlock.AllocationStackTrace[0] <> 0 then

    begin

      LMsgPtr := AppendStringToBuffer(ThreadIDAtObjectAllocMsg, LMsgPtr, Length(ThreadIDAtObjectAllocMsg));

      LMsgPtr := NativeUIntToHexBuf(LActualBlock.AllocatedByThread, LMsgPtr);

      LMsgPtr := AppendStringToBuffer(StackTraceMsg, LMsgPtr, Length(StackTraceMsg));

      LMsgPtr := LogStackTrace(@LActualBlock.AllocationStackTrace, StackTraceDepth, LMsgPtr);

    end;

    {Get the call stack for the previous free}

    if LActualBlock.FreeStackTrace[0] <> 0 then

    begin

      LMsgPtr := AppendStringToBuffer(ThreadIDAtObjectFreeMsg, LMsgPtr, Length(ThreadIDAtObjectFreeMsg));

      LMsgPtr := NativeUIntToHexBuf(LActualBlock.FreedByThread, LMsgPtr);

      LMsgPtr := AppendStringToBuffer(StackTraceMsg, LMsgPtr, Length(StackTraceMsg));

      LMsgPtr := LogStackTrace(@LActualBlock.FreeStackTrace, StackTraceDepth, LMsgPtr);

    end;

  end

  else

  begin

    {Header has been corrupted}

    LMsgPtr := AppendStringToBuffer(BlockHeaderCorruptedNoHistoryMsg, LMsgPtr, Length(BlockHeaderCorruptedNoHistoryMsg));

  end;

  {Add the current stack trace}

  LMsgPtr := LogCurrentThreadAndStackTrace(2, LMsgPtr);

{$ifndef DisableLoggingOfMemoryDumps}

  {Add the pointer address}

  LMsgPtr := LogMemoryDump(LActualBlock, LMsgPtr);

{$endif}

  {Trailing CRLF}

  LMsgPtr^ := #13;

  Inc(LMsgPtr);

  LMsgPtr^ := #10;

  Inc(LMsgPtr);

  {Trailing #0}

  LMsgPtr^ := #0;

{$ifdef LogErrorsToFile}

  {Log the error}

  AppendEventLog(@LErrorMessage[0], NativeUInt(LMsgPtr) - NativeUInt(@LErrorMessage[0]));

{$endif}

{$ifdef UseOutputDebugString}

  OutputDebugStringA(LErrorMessage);

{$endif}

{$ifndef NoMessageBoxes}

  {Show the message}

  AppendStringToModuleName(BlockErrorMsgTitle, LErrorMessageTitle);

  ShowMessageBox(LErrorMessage, LErrorMessageTitle);

{$endif}

  {Raise an access violation}

  RaiseException(EXCEPTION_ACCESS_VIOLATION, 0, 0, nil);

end;



{$ifdef CatchUseOfFreedInterfaces}

procedure TFreedObject.InterfaceError;

var

  LMsgPtr: PAnsiChar;

{$ifndef NoMessageBoxes}

  LErrorMessageTitle: array[0..1023] of AnsiChar;

{$endif}

  LErrorMessage: array[0..4000] of AnsiChar;

begin

  {Display the error header}

  LMsgPtr := AppendStringToBuffer(InterfaceErrorHeader, @LErrorMessage[0], Length(InterfaceErrorHeader));

  {Add the current stack trace}

  LMsgPtr := LogCurrentThreadAndStackTrace(2, LMsgPtr);

  {Trailing CRLF}

  LMsgPtr^ := #13;

  Inc(LMsgPtr);

  LMsgPtr^ := #10;

  Inc(LMsgPtr);

  {Trailing #0}

  LMsgPtr^ := #0;

{$ifdef LogErrorsToFile}

  {Log the error}

  AppendEventLog(@LErrorMessage[0], NativeUInt(LMsgPtr) - NativeUInt(@LErrorMessage[0]));

{$endif}

{$ifdef UseOutputDebugString}

  OutputDebugStringA(LErrorMessage);

{$endif}

{$ifndef NoMessageBoxes}

  {Show the message}

  AppendStringToModuleName(BlockErrorMsgTitle, LErrorMessageTitle);

  ShowMessageBox(LErrorMessage, LErrorMessageTitle);

{$endif}

  {Raise an access violation}

  RaiseException(EXCEPTION_ACCESS_VIOLATION, 0, 0, nil);

end;

{$endif}



{$endif}



{----------------------------Memory Leak Checking-----------------------------}



{$ifdef EnableMemoryLeakReporting}



{Adds a leak to the specified list}

function UpdateExpectedLeakList(APLeakList: PPExpectedMemoryLeak;

  APNewEntry: PExpectedMemoryLeak; AExactSizeMatch: Boolean = True): Boolean;

var

  LPInsertAfter, LPNewEntry: PExpectedMemoryLeak;

begin

  {Default to error}

  Result := False;

  {Find the insertion spot}

  LPInsertAfter := APLeakList^;

  while LPInsertAfter <> nil do

  begin

    {Too big?}

    if LPInsertAfter.LeakSize > APNewEntry.LeakSize then

    begin

      LPInsertAfter := LPInsertAfter.PreviousLeak;

      Break;

    end;

    {Find a matching entry. If an exact size match is not required and the leak

     is larger than the current entry, use it if the expected size of the next

     entry is too large.}

    if (IntPtr(LPInsertAfter.LeakAddress) = IntPtr(APNewEntry.LeakAddress))

      and ((IntPtr(LPInsertAfter.LeakedClass) = IntPtr(APNewEntry.LeakedClass))

      {$ifdef CheckCppObjectTypeEnabled}

       or (LPInsertAfter.LeakedCppTypeIdPtr = APNewEntry.LeakedCppTypeIdPtr)

      {$endif}

      )

      and ((LPInsertAfter.LeakSize = APNewEntry.LeakSize)

        or ((not AExactSizeMatch)

          and (LPInsertAfter.LeakSize < APNewEntry.LeakSize)

          and ((LPInsertAfter.NextLeak = nil)

            or (LPInsertAfter.NextLeak.LeakSize > APNewEntry.LeakSize))

          )) then

    begin

      if (LPInsertAfter.LeakCount + APNewEntry.LeakCount) >= 0 then

      begin

        Inc(LPInsertAfter.LeakCount, APNewEntry.LeakCount);

        {Is the count now 0?}

        if LPInsertAfter.LeakCount = 0 then

        begin

          {Delete the entry}

          if LPInsertAfter.NextLeak <> nil then

            LPInsertAfter.NextLeak.PreviousLeak := LPInsertAfter.PreviousLeak;

          if LPInsertAfter.PreviousLeak <> nil then

            LPInsertAfter.PreviousLeak.NextLeak := LPInsertAfter.NextLeak

          else

            APLeakList^ := LPInsertAfter.NextLeak;

          {Insert it as the first free slot}

          LPInsertAfter.NextLeak := ExpectedMemoryLeaks.FirstFreeSlot;

          ExpectedMemoryLeaks.FirstFreeSlot := LPInsertAfter;

        end;

        Result := True;

      end;

      Exit;

    end;

    {Next entry}

    if LPInsertAfter.NextLeak <> nil then

      LPInsertAfter := LPInsertAfter.NextLeak

    else

      Break;

  end;

  if APNewEntry.LeakCount > 0 then

  begin

    {Get a position for the entry}

    LPNewEntry := ExpectedMemoryLeaks.FirstFreeSlot;

    if LPNewEntry <> nil then

    begin

      ExpectedMemoryLeaks.FirstFreeSlot := LPNewEntry.NextLeak;

    end

    else

    begin

      if ExpectedMemoryLeaks.EntriesUsed < Length(ExpectedMemoryLeaks.ExpectedLeaks) then

      begin

        LPNewEntry := @ExpectedMemoryLeaks.ExpectedLeaks[ExpectedMemoryLeaks.EntriesUsed];

        Inc(ExpectedMemoryLeaks.EntriesUsed);

      end

      else

      begin

        {No more space}

        Exit;

      end;

    end;

    {Set the entry}

    LPNewEntry^ := APNewEntry^;

    {Insert it into the list}

    LPNewEntry.PreviousLeak := LPInsertAfter;

    if LPInsertAfter <> nil then

    begin

      LPNewEntry.NextLeak := LPInsertAfter.NextLeak;

      if LPNewEntry.NextLeak <> nil then

        LPNewEntry.NextLeak.PreviousLeak := LPNewEntry;

      LPInsertAfter.NextLeak := LPNewEntry;

    end

    else

    begin

      LPNewEntry.NextLeak := APLeakList^;

      if LPNewEntry.NextLeak <> nil then

        LPNewEntry.NextLeak.PreviousLeak := LPNewEntry;

      APLeakList^ := LPNewEntry;

    end;

    Result := True;

  end;

end;



{Locks the expected leaks. Returns false if the list could not be allocated.}

function LockExpectedMemoryLeaksList: Boolean;

begin

  {Lock the expected leaks list}

{$ifndef AssumeMultiThreaded}

  if IsMultiThread then

{$endif}

  begin

    while LockCmpxchg(0, 1, @ExpectedMemoryLeaksListLocked) <> 0 do

    begin

{$ifdef NeverSleepOnThreadContention}

  {$ifdef UseSwitchToThread}

      SwitchToThread;

  {$endif}

{$else}

      Sleep(InitialSleepTime);

      if LockCmpxchg(0, 1, @ExpectedMemoryLeaksListLocked) = 0 then

        Break;

      Sleep(AdditionalSleepTime);

{$endif}

    end;

  end;

  {Allocate the list if it does not exist}

  if ExpectedMemoryLeaks = nil then

    ExpectedMemoryLeaks := VirtualAlloc(nil, ExpectedMemoryLeaksListSize, MEM_COMMIT, PAGE_READWRITE);

  {Done}

  Result := ExpectedMemoryLeaks <> nil;

end;



{Registers expected memory leaks. Returns true on success. The list of leaked

 blocks is limited, so failure is possible if the list is full.}

function RegisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; overload;

var

  LNewEntry: TExpectedMemoryLeak;

begin

  {Fill out the structure}

{$ifndef FullDebugMode}

  LNewEntry.LeakAddress := ALeakedPointer;

{$else}

  LNewEntry.LeakAddress := Pointer(PByte(ALeakedPointer) - SizeOf(TFullDebugBlockHeader));

{$endif}

  LNewEntry.LeakedClass := nil;

  {$ifdef CheckCppObjectTypeEnabled}

  LNewEntry.LeakedCppTypeIdPtr := nil;

  {$endif}

  LNewEntry.LeakSize := 0;

  LNewEntry.LeakCount := 1;

  {Add it to the correct list}

  Result := LockExpectedMemoryLeaksList

    and UpdateExpectedLeakList(@ExpectedMemoryLeaks.FirstEntryByAddress, @LNewEntry);

  ExpectedMemoryLeaksListLocked := False;

end;



function RegisterExpectedMemoryLeak(ALeakedObjectClass: TClass; ACount: Integer = 1): Boolean; overload;

var

  LNewEntry: TExpectedMemoryLeak;

begin

  {Fill out the structure}

  LNewEntry.LeakAddress := nil;

  LNewEntry.LeakedClass := ALeakedObjectClass;

  {$ifdef CheckCppObjectTypeEnabled}

  LNewEntry.LeakedCppTypeIdPtr := nil;

  {$endif}

  LNewEntry.LeakSize := ALeakedObjectClass.InstanceSize;

  LNewEntry.LeakCount := ACount;

  {Add it to the correct list}

  Result := LockExpectedMemoryLeaksList

    and UpdateExpectedLeakList(@ExpectedMemoryLeaks.FirstEntryByClass, @LNewEntry);

  ExpectedMemoryLeaksListLocked := False;

end;



{$ifdef CheckCppObjectTypeEnabled}

function RegisterExpectedMemoryLeak(ALeakedCppVirtObjTypeIdPtr: Pointer; ACount: Integer): Boolean; overload;

var

  LNewEntry: TExpectedMemoryLeak;

begin

  {Fill out the structure}

  if Assigned(GetCppVirtObjSizeByTypeIdPtrFunc) then

  begin

    //Return 0 if not a proper type

    LNewEntry.LeakSize := GetCppVirtObjSizeByTypeIdPtrFunc(ALeakedCppVirtObjTypeIdPtr);

    if LNewEntry.LeakSize > 0 then

    begin

      LNewEntry.LeakAddress := nil;

      LNewEntry.LeakedClass := nil;

      LNewEntry.LeakedCppTypeIdPtr := ALeakedCppVirtObjTypeIdPtr;

      LNewEntry.LeakCount := ACount;

      {Add it to the correct list}

      Result := LockExpectedMemoryLeaksList

        and UpdateExpectedLeakList(@ExpectedMemoryLeaks.FirstEntryByClass, @LNewEntry);

      ExpectedMemoryLeaksListLocked := False;

    end

    else

    begin

      Result := False;

    end;

  end

  else

  begin

    Result := False;

  end;

end;

{$endif}



function RegisterExpectedMemoryLeak(ALeakedBlockSize: NativeInt; ACount: Integer = 1): Boolean; overload;

var

  LNewEntry: TExpectedMemoryLeak;

begin

  {Fill out the structure}

  LNewEntry.LeakAddress := nil;

  LNewEntry.LeakedClass := nil;

  {$ifdef CheckCppObjectTypeEnabled}

  LNewEntry.LeakedCppTypeIdPtr := nil;

  {$endif}

  LNewEntry.LeakSize := ALeakedBlockSize;

  LNewEntry.LeakCount := ACount;

  {Add it to the correct list}

  Result := LockExpectedMemoryLeaksList

    and UpdateExpectedLeakList(@ExpectedMemoryLeaks.FirstEntryBySizeOnly, @LNewEntry);

  ExpectedMemoryLeaksListLocked := False;

end;



function UnregisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; overload;

var

  LNewEntry: TExpectedMemoryLeak;

begin

  {Fill out the structure}

{$ifndef FullDebugMode}

  LNewEntry.LeakAddress := ALeakedPointer;

{$else}

  LNewEntry.LeakAddress := Pointer(PByte(ALeakedPointer) - SizeOf(TFullDebugBlockHeader));

{$endif}

  LNewEntry.LeakedClass := nil;

  {$ifdef CheckCppObjectTypeEnabled}

  LNewEntry.LeakedCppTypeIdPtr := nil;

  {$endif}

  LNewEntry.LeakSize := 0;

  LNewEntry.LeakCount := -1;

  {Remove it from the list}

  Result := LockExpectedMemoryLeaksList

    and UpdateExpectedLeakList(@ExpectedMemoryLeaks.FirstEntryByAddress, @LNewEntry);

  ExpectedMemoryLeaksListLocked := False;

end;



function UnregisterExpectedMemoryLeak(ALeakedObjectClass: TClass; ACount: Integer = 1): Boolean; overload;

begin

  Result := RegisterExpectedMemoryLeak(ALeakedObjectClass, - ACount);

end;



{$ifdef CheckCppObjectTypeEnabled}

function UnregisterExpectedMemoryLeak(ALeakedCppVirtObjTypeIdPtr: Pointer; ACount: Integer): Boolean; overload;

begin

  Result := RegisterExpectedMemoryLeak(ALeakedCppVirtObjTypeIdPtr, - ACount);

end;

{$endif}



function UnregisterExpectedMemoryLeak(ALeakedBlockSize: NativeInt; ACount: Integer = 1): Boolean; overload;

begin

  Result := RegisterExpectedMemoryLeak(ALeakedBlockSize, - ACount);

end;



{Returns a list of all expected memory leaks}

function GetRegisteredMemoryLeaks: TRegisteredMemoryLeaks;



  procedure AddEntries(AEntry: PExpectedMemoryLeak);

  var

    LInd: Integer;

  begin

    while AEntry <> nil do

    begin

      LInd := Length(Result);

      SetLength(Result, LInd + 1);

      {Add the entry}

{$ifndef FullDebugMode}

      Result[LInd].LeakAddress := AEntry.LeakAddress;

{$else}

      Result[LInd].LeakAddress := Pointer(PByte(AEntry.LeakAddress) + SizeOf(TFullDebugBlockHeader));

{$endif}

      Result[LInd].LeakedClass := AEntry.LeakedClass;

{$ifdef CheckCppObjectTypeEnabled}

      Result[LInd].LeakedCppTypeIdPtr := AEntry.LeakedCppTypeIdPtr;

{$endif}

      Result[LInd].LeakSize := AEntry.LeakSize;

      Result[LInd].LeakCount := AEntry.LeakCount;

      {Next entry}

      AEntry := AEntry.NextLeak;

    end;

  end;



begin

  SetLength(Result, 0);

  if (ExpectedMemoryLeaks <> nil) and LockExpectedMemoryLeaksList then

  begin

    {Add all entries}

    AddEntries(ExpectedMemoryLeaks.FirstEntryByAddress);

    AddEntries(ExpectedMemoryLeaks.FirstEntryByClass);

    AddEntries(ExpectedMemoryLeaks.FirstEntryBySizeOnly);

    {Unlock the list}

    ExpectedMemoryLeaksListLocked := False;

  end;

end;



{$else}

  {$ifdef BDS2006AndUp}

function NoOpRegisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean;

begin

  {Do nothing. Used when memory leak reporting is disabled under Delphi 2006 and later.}

  Result := False;

end;



function NoOpUnregisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean;

begin

  {Do nothing. Used when memory leak reporting is disabled under Delphi 2006 and later.}

  Result := False;

end;

  {$endif}

{$endif}



{Detects the probable string data type for a memory block.}

function DetectStringData(APMemoryBlock: Pointer;

  AAvailableSpaceInBlock: NativeInt): TStringDataType;

const

  {If the string reference count field contains a value greater than this,

   then it is assumed that the block is not a string.}

  MaxRefCount = 255;

  {The lowest ASCII character code considered valid string data. If there are

   any characters below this code point then the data is assumed not to be a

   string. #9 = Tab.}

  MinCharCode = #9;

var

  LStringLength, LElemSize, LCharInd: Integer;

  LPAnsiStr: PAnsiChar;

  LPUniStr: PWideChar;

begin

  {Check that the reference count is within a reasonable range}

  if PStrRec(APMemoryBlock).refCnt > MaxRefCount then

  begin

    Result := stUnknown;

    Exit;

  end;

{$ifdef BCB6OrDelphi6AndUp}

  {$if RTLVersion >= 20}

  LElemSize := PStrRec(APMemoryBlock).elemSize;

  {Element size must be either 1 (Ansi) or 2 (Unicode)}

  if (LElemSize <> 1) and (LElemSize <> 2) then

  begin

    Result := stUnknown;

    Exit;

  end;

  {$ifend}

  {$if RTLVersion < 20}

  LElemSize := 1;

  {$ifend}

{$else}

  LElemSize := 1;

{$endif}

  {Get the string length}

  LStringLength := PStrRec(APMemoryBlock).length;

  {Does the string fit?}

  if (LStringLength <= 0)

    or (LStringLength >= (AAvailableSpaceInBlock - SizeOf(StrRec)) div LElemSize) then

  begin

    Result := stUnknown;

    Exit;

  end;

  {Check for no characters outside the expected range. If there are,

   then it is probably not a string.}

  if LElemSize = 1 then

  begin

    {Check that all characters are in the range considered valid.}

    LPAnsiStr := PAnsiChar(PByte(APMemoryBlock) + SizeOf(StrRec));

    for LCharInd := 1 to LStringLength do

    begin

      if LPAnsiStr^ < MinCharCode then

      begin

        Result := stUnknown;

        Exit;

      end;

      Inc(LPAnsiStr);

    end;

    {Must have a trailing #0}

    if LPAnsiStr^ = #0 then

      Result := stAnsiString

    else

      Result := stUnknown;

  end

  else

  begin

    {Check that all characters are in the range considered valid.}

    LPUniStr := PWideChar(PByte(APMemoryBlock) + SizeOf(StrRec));

    for LCharInd := 1 to LStringLength do

    begin

      if LPUniStr^ < MinCharCode then

      begin

        Result := stUnknown;

        Exit;

      end;

      Inc(LPUniStr);

    end;

    {Must have a trailing #0}

    if LPUniStr^ = #0 then

      Result := stUnicodeString

    else

      Result := stUnknown;

  end;

end;



{Walks all allocated blocks, calling ACallBack for each. Passes the user block size and AUserData to the callback.

 Important note: All block types will be locked during the callback, so the memory manager cannot be used inside it.}

procedure WalkAllocatedBlocks(ACallBack: TWalkAllocatedBlocksCallback; AUserData: Pointer);

const

  DebugHeaderSize = {$ifdef FullDebugMode}SizeOf(TFullDebugBlockHeader){$else}0{$endif};

  TotalDebugOverhead = {$ifdef FullDebugMode}FullDebugBlockOverhead{$else}0{$endif};

var

  LPMediumBlock: Pointer;

  LPMediumBlockPoolHeader: PMediumBlockPoolHeader;

  LMediumBlockHeader: NativeUInt;

  LPLargeBlock: PLargeBlockHeader;

  LBlockSize: NativeInt;

  LPSmallBlockPool: PSmallBlockPoolHeader;

  LCurPtr, LEndPtr: Pointer;

  LInd: Integer;

begin

  {Lock all small block types}

  LockAllSmallBlockTypes;

  {Lock the medium blocks}

  LockMediumBlocks;

  try

    {Step through all the medium block pools}

    LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader;

    while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do

    begin

      LPMediumBlock := GetFirstMediumBlockInPool(LPMediumBlockPoolHeader);

      while LPMediumBlock <> nil do

      begin

        LMediumBlockHeader := PNativeUInt(PByte(LPMediumBlock) - BlockHeaderSize)^;

        {Is the block in use?}

        if LMediumBlockHeader and IsFreeBlockFlag = 0 then

        begin

          if (LMediumBlockHeader and IsSmallBlockPoolInUseFlag) <> 0 then

          begin

            {Step through all the blocks in the small block pool}

            LPSmallBlockPool := LPMediumBlock;

            {Get the useable size inside a block}

            LBlockSize := LPSmallBlockPool.BlockType.BlockSize - BlockHeaderSize - TotalDebugOverhead;

            {Get the first and last pointer for the pool}

            GetFirstAndLastSmallBlockInPool(LPSmallBlockPool, LCurPtr, LEndPtr);

            {Step through all blocks}

            while UIntPtr(LCurPtr) <= UIntPtr(LEndPtr) do

            begin

              {Is this block in use?}

              if (PNativeUInt(PByte(LCurPtr) - BlockHeaderSize)^ and IsFreeBlockFlag) = 0 then

              begin

                ACallBack(PByte(LCurPtr) + DebugHeaderSize, LBlockSize, AUserData);

              end;

              {Next block}

              Inc(PByte(LCurPtr), LPSmallBlockPool.BlockType.BlockSize);

            end;

          end

          else

          begin

            LBlockSize := (LMediumBlockHeader and DropMediumAndLargeFlagsMask) - BlockHeaderSize - TotalDebugOverhead;

            ACallBack(PByte(LPMediumBlock) + DebugHeaderSize, LBlockSize, AUserData);

          end;

        end;

        {Next medium block}

        LPMediumBlock := NextMediumBlock(LPMediumBlock);

      end;

      {Get the next medium block pool}

      LPMediumBlockPoolHeader := LPMediumBlockPoolHeader.NextMediumBlockPoolHeader;

    end;

  finally

    {Unlock medium blocks}

    MediumBlocksLocked := False;

    {Unlock all the small block types}

    for LInd := 0 to NumSmallBlockTypes - 1 do

      SmallBlockTypes[LInd].BlockTypeLocked := False;

  end;

  {Step through all the large blocks}

  LockLargeBlocks;

  try

    {Get all leaked large blocks}

    LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader;

    while LPLargeBlock <> @LargeBlocksCircularList do

    begin

      LBlockSize := (LPLargeBlock.BlockSizeAndFlags and DropMediumAndLargeFlagsMask) - BlockHeaderSize - LargeBlockHeaderSize - TotalDebugOverhead;

      ACallBack(PByte(LPLargeBlock) + LargeBlockHeaderSize + DebugHeaderSize, LBlockSize, AUserData);

      {Get the next large block}

      LPLargeBlock := LPLargeBlock.NextLargeBlockHeader;

    end;

  finally

    LargeBlocksLocked := False;

  end;

end;



{-----------LogMemoryManagerStateToFile implementation------------}

const

  MaxMemoryLogNodes = 100000;

  QuickSortMinimumItemsInPartition = 4;



type

  {While scanning the memory pool the list of classes is built up in a binary search tree.}

  PMemoryLogNode = ^TMemoryLogNode;

  TMemoryLogNode = record

    {The left and right child nodes}

    LeftAndRightNodePointers: array[Boolean] of PMemoryLogNode;

    {The class this node belongs to}

    ClassPtr: Pointer;

    {The number of instances of the class}

    InstanceCount: NativeInt;

    {The total memory usage for this class}

    TotalMemoryUsage: NativeInt;

  end;

  TMemoryLogNodes = array[0..MaxMemoryLogNodes - 1] of TMemoryLogNode;

  PMemoryLogNodes = ^TMemoryLogNodes;



  TMemoryLogInfo = record

    {The number of nodes in "Nodes" that are used.}

    NodeCount: Integer;

    {The root node of the binary search tree. The content of this node is not actually used, it just simplifies the

     binary search code.}

    RootNode: TMemoryLogNode;

    Nodes: TMemoryLogNodes;

  end;

  PMemoryLogInfo = ^TMemoryLogInfo;



{LogMemoryManagerStateToFile callback subroutine}

procedure LogMemoryManagerStateCallBack(APBlock: Pointer; ABlockSize: NativeInt; AUserData: Pointer);

var

  LClass, LClassHashBits: NativeUInt;

  LPLogInfo: PMemoryLogInfo;

  LPParentNode, LPClassNode: PMemoryLogNode;

  LChildNodeDirection: Boolean;

begin

  LPLogInfo := AUserData;

  {Detecting an object is very expensive (due to the VirtualQuery call), so we do some basic checks and try to find

   the "class" in the tree first.}

  LClass := PNativeUInt(APBlock)^;

  {Do some basic pointer checks: The "class" must be dword aligned and beyond 64K}

  if (LClass > 65535)

    and (LClass and 3 = 0) then

  begin

    LPParentNode := @LPLogInfo.RootNode;

    LClassHashBits := LClass;

    repeat

      LChildNodeDirection := Boolean(LClassHashBits and 1);

      {Split off the next bit of the class pointer and traverse in the appropriate direction.}

      LPClassNode := LPParentNode.LeftAndRightNodePointers[LChildNodeDirection];

      {Is this child node the node the class we're looking for?}

      if (LPClassNode = nil) or (NativeUInt(LPClassNode.ClassPtr) = LClass) then

        Break;

      {The node was not found: Keep on traversing the tree.}

      LClassHashBits := LClassHashBits shr 1;

      LPParentNode := LPClassNode;

    until False;

  end

  else

    LPClassNode := nil;

  {Was the "class" found?}

  if LPClassNode = nil then

  begin

    {The "class" is not yet in the tree: Determine if it is actually a class.}

    LClass := NativeUInt(DetectClassInstance(APBlock));

    {If it is not a class, try to detect the string type.}

    if LClass = 0 then

      LClass := Ord(DetectStringData(APBlock, ABlockSize));

    {Is this class already in the tree?}

    LPParentNode := @LPLogInfo.RootNode;

    LClassHashBits := LClass;

    repeat

      LChildNodeDirection := Boolean(LClassHashBits and 1);

      {Split off the next bit of the class pointer and traverse in the appropriate direction.}

      LPClassNode := LPParentNode.LeftAndRightNodePointers[LChildNodeDirection];

      {Is this child node the node the class we're looking for?}

      if LPClassNode = nil then

      begin

        {The end of the tree was reached: Add a new child node.}

        LPClassNode := @LPLogInfo.Nodes[LPLogInfo.NodeCount];

        Inc(LPLogInfo.NodeCount);

        LPParentNode.LeftAndRightNodePointers[LChildNodeDirection] := LPClassNode;

        LPClassNode.ClassPtr := Pointer(LClass);

        Break;

      end

      else

      begin

        if NativeUInt(LPClassNode.ClassPtr) = LClass then

          Break;

      end;

      {The node was not found: Keep on traversing the tree.}

      LClassHashBits := LClassHashBits shr 1;

      LPParentNode := LPClassNode;

    until False;

  end;

  {Update the statistics for the class}

  Inc(LPClassNode.InstanceCount);

  Inc(LPClassNode.TotalMemoryUsage, ABlockSize);

end;



{LogMemoryManagerStateToFile subroutine: A median-of-3 quicksort routine for sorting a TMemoryLogNodes array.}

procedure QuickSortLogNodes(APLeftItem: PMemoryLogNodes; ARightIndex: Integer);

var

  M, I, J: Integer;

  LPivot, LTempItem: TMemoryLogNode;

begin

  while True do

  begin

    {Order the left, middle and right items in ascending order}

    M := ARightIndex shr 1;

    {Is the middle item larger than the left item?}

    if APLeftItem[0].TotalMemoryUsage > APLeftItem[M].TotalMemoryUsage then

    begin

      {Swap items 0 and M}

      LTempItem := APLeftItem[0];

      APLeftItem[0] := APLeftItem[M];

      APLeftItem[M] := LTempItem;

    end;

    {Is the middle item larger than the right?}

    if APLeftItem[M].TotalMemoryUsage > APLeftItem[ARightIndex].TotalMemoryUsage then

    begin

      {The right-hand item is not larger - swap it with the middle}

      LTempItem := APLeftItem[ARightIndex];

      APLeftItem[ARightIndex] := APLeftItem[M];

      APLeftItem[M] := LTempItem;

      {Is the left larger than the new middle?}

      if APLeftItem[0].TotalMemoryUsage > APLeftItem[M].TotalMemoryUsage then

      begin

        {Swap items 0 and M}

        LTempItem := APLeftItem[0];

        APLeftItem[0] := APLeftItem[M];

        APLeftItem[M] := LTempItem;

      end;

    end;

    {Move the pivot item out of the way by swapping M with R - 1}

    LPivot := APLeftItem[M];

    APLeftItem[M] := APLeftItem[ARightIndex - 1];

    APLeftItem[ARightIndex - 1] := LPivot;

    {Set up the loop counters}

    I := 0;

    J := ARightIndex - 1;

    while true do

    begin

      {Find the first item from the left that is not smaller than the pivot}

      repeat

        Inc(I);

      until APLeftItem[I].TotalMemoryUsage >= LPivot.TotalMemoryUsage;

      {Find the first item from the right that is not larger than the pivot}

      repeat

        Dec(J);

      until APLeftItem[J].TotalMemoryUsage <= LPivot.TotalMemoryUsage;

      {Stop the loop when the two indexes cross}

      if J < I then

        Break;

      {Swap item I and J}

      LTempItem := APLeftItem[I];

      APLeftItem[I] := APLeftItem[J];

      APLeftItem[J] := LTempItem;

    end;

    {Put the pivot item back in the correct position by swapping I with R - 1}

    APLeftItem[ARightIndex - 1] := APLeftItem[I];

    APLeftItem[I] := LPivot;

    {Sort the left-hand partition}

    if J >= (QuickSortMinimumItemsInPartition - 1) then

      QuickSortLogNodes(APLeftItem, J);

    {Sort the right-hand partition}

    APLeftItem := @APLeftItem[I + 1];

    ARightIndex := ARightIndex - I - 1;

    if ARightIndex < (QuickSortMinimumItemsInPartition - 1) then

      Break;

  end;

end;



{LogMemoryManagerStateToFile subroutine: An InsertionSort routine for sorting a TMemoryLogNodes array.}

procedure InsertionSortLogNodes(APLeftItem: PMemoryLogNodes; ARightIndex: Integer);

var

  I, J: Integer;

  LCurNode: TMemoryLogNode;

begin

  for I := 1 to ARightIndex do

  begin

    LCurNode := APLeftItem[I];

    {Scan backwards to find the best insertion spot}

    J := I;

    while (J > 0) and (APLeftItem[J - 1].TotalMemoryUsage > LCurNode.TotalMemoryUsage) do

    begin

      APLeftItem[J] := APLeftItem[J - 1];

      Dec(J);

    end;

    APLeftItem[J] := LCurNode;

  end;

end;



{Writes a log file containing a summary of the memory mananger state and a summary of allocated blocks grouped by

 class. The file will be saved in UTF-8 encoding (in supported Delphi versions). Returns True on success. }

function LogMemoryManagerStateToFile(const AFileName: string; const AAdditionalDetails: string): Boolean;

const

  MsgBufferSize = 65536;

  MaxLineLength = 512;

  {Write the UTF-8 BOM in Delphi versions that support UTF-8 conversion.}

  LogStateHeaderMsg = {$ifdef BCB6OrDelphi7AndUp}#$EF#$BB#$BF + {$endif}

    'FastMM State Capture:'#13#10'---------------------'#13#10#13#10;

  LogStateAllocatedMsg = 'K Allocated'#13#10;

  LogStateOverheadMsg = 'K Overhead'#13#10;

  LogStateEfficiencyMsg = '% Efficiency'#13#10#13#10'Usage Detail:'#13#10;

  LogStateAdditionalInfoMsg = #13#10'Additional Information:'#13#10'-----------------------'#13#10;

var

  LPLogInfo: PMemoryLogInfo;

  LInd: Integer;

  LPNode: PMemoryLogNode;

  LMsgBuffer: array[0..MsgBufferSize - 1] of AnsiChar;

  LPMsg: PAnsiChar;

  LBufferSpaceUsed, LBytesWritten: Cardinal;

  LFileHandle: NativeUInt;

  LMemoryManagerUsageSummary: TMemoryManagerUsageSummary;

  LUTF8Str: AnsiString;

begin

  {Get the current memory manager usage summary.}

  GetMemoryManagerUsageSummary(LMemoryManagerUsageSummary);

  {Allocate the memory required to capture detailed allocation information.}

  LPLogInfo := VirtualAlloc(nil, SizeOf(TMemoryLogInfo), MEM_COMMIT or MEM_TOP_DOWN, PAGE_READWRITE);

  if LPLogInfo <> nil then

  begin

    try

      {Log all allocated blocks by class.}

      WalkAllocatedBlocks(LogMemoryManagerStateCallBack, LPLogInfo);

      {Sort the classes by total memory usage: Do the initial QuickSort pass over the list to sort the list in groups

       of QuickSortMinimumItemsInPartition size.}

      if LPLogInfo.NodeCount >= QuickSortMinimumItemsInPartition then

        QuickSortLogNodes(@LPLogInfo.Nodes[0], LPLogInfo.NodeCount - 1);

      {Do the final InsertionSort pass.}

      InsertionSortLogNodes(@LPLogInfo.Nodes[0], LPLogInfo.NodeCount - 1);

      {Create the output file}

      {$ifdef POSIX}

      lFileHandle := FileCreate(AFilename);

      {$else}

      LFileHandle := CreateFile(PChar(AFilename), GENERIC_READ or GENERIC_WRITE, 0,

        nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);

      {$endif}

      if LFileHandle <> INVALID_HANDLE_VALUE then

      begin

        try

          {Log the usage summary}

          LPMsg := @LMsgBuffer;

          LPMsg := AppendStringToBuffer(LogStateHeaderMsg, LPMsg, Length(LogStateHeaderMsg));

          LPMsg := NativeUIntToStrBuf(LMemoryManagerUsageSummary.AllocatedBytes shr 10, LPMsg);

          LPMsg := AppendStringToBuffer(LogStateAllocatedMsg, LPMsg, Length(LogStateAllocatedMsg));

          LPMsg := NativeUIntToStrBuf(LMemoryManagerUsageSummary.OverheadBytes shr 10, LPMsg);

          LPMsg := AppendStringToBuffer(LogStateOverheadMsg, LPMsg, Length(LogStateOverheadMsg));

          LPMsg := NativeUIntToStrBuf(Round(LMemoryManagerUsageSummary.EfficiencyPercentage), LPMsg);

          LPMsg := AppendStringToBuffer(LogStateEfficiencyMsg, LPMsg, Length(LogStateEfficiencyMsg));

          {Log the allocation detail}

          for LInd := LPLogInfo.NodeCount - 1 downto 0 do

          begin

            LPNode := @LPLogInfo.Nodes[LInd];

            {Add the allocated size}

            LPMsg^ := ' ';

            Inc(LPMsg);

            LPMsg := NativeUIntToStrBuf(LPNode.TotalMemoryUsage, LPMsg);

            LPMsg := AppendStringToBuffer(BytesMessage, LPMsg, Length(BytesMessage));

            {Add the class type}

            case NativeInt(LPNode.ClassPtr) of

              {Unknown}

              0:

              begin

                LPMsg := AppendStringToBuffer(UnknownClassNameMsg, LPMsg, Length(UnknownClassNameMsg));

              end;

              {AnsiString}

              1:

              begin

                LPMsg := AppendStringToBuffer(AnsiStringBlockMessage, LPMsg, Length(AnsiStringBlockMessage));

              end;

              {UnicodeString}

              2:

              begin

                LPMsg := AppendStringToBuffer(UnicodeStringBlockMessage, LPMsg, Length(UnicodeStringBlockMessage));

              end;

              {Classes}

            else

              begin

                LPMsg := AppendClassNameToBuffer(LPNode.ClassPtr, LPMsg);

              end;

            end;

            {Add the count}

            LPMsg^ := ' ';

            Inc(LPMsg);

            LPMsg^ := 'x';

            Inc(LPMsg);

            LPMsg^ := ' ';

            Inc(LPMsg);

            LPMsg := NativeUIntToStrBuf(LPNode.InstanceCount, LPMsg);

            LPMsg^ := #13;

            Inc(LPMsg);

            LPMsg^ := #10;

            Inc(LPMsg);

            {Flush the buffer?}

            LBufferSpaceUsed := NativeInt(LPMsg) - NativeInt(@LMsgBuffer);

            if LBufferSpaceUsed > (MsgBufferSize - MaxLineLength) then

            begin

              WriteFile(LFileHandle, LMsgBuffer, LBufferSpaceUsed, LBytesWritten, nil);

              LPMsg := @LMsgBuffer;

            end;

          end;

          if AAdditionalDetails <> '' then

            LPMsg := AppendStringToBuffer(LogStateAdditionalInfoMsg, LPMsg, Length(LogStateAdditionalInfoMsg));

          {Flush any remaining bytes}

          LBufferSpaceUsed := NativeInt(LPMsg) - NativeInt(@LMsgBuffer);

          if LBufferSpaceUsed > 0 then

            WriteFile(LFileHandle, LMsgBuffer, LBufferSpaceUsed, LBytesWritten, nil);

          {Write the additional info}

          if AAdditionalDetails <> '' then

          begin

            {$ifdef BCB6OrDelphi7AndUp}

            LUTF8Str := UTF8Encode(AAdditionalDetails);

            {$else}

            LUTF8Str := AAdditionalDetails;

            {$endif}

            WriteFile(LFileHandle, LUTF8Str[1], Length(LUTF8Str), LBytesWritten, nil);

          end;

          {Success}

          Result := True;

        finally

          {Close the file}

          {$ifdef POSIX}

          __close(LFileHandle)

          {$else}

          CloseHandle(LFileHandle);

          {$endif}

        end;

      end

      else

        Result := False;

    finally

      VirtualFree(LPLogInfo, 0, MEM_RELEASE);

    end;

  end

  else

    Result := False;

end;



{-----------CheckBlocksOnShutdown implementation------------}



{Checks blocks for modification after free and also for memory leaks}

procedure CheckBlocksOnShutdown(ACheckForLeakedBlocks: Boolean);

{$ifdef EnableMemoryLeakReporting}

type

  {Leaked class type}

  TLeakedClass = record

    ClassPointer: TClass;

    {$ifdef CheckCppObjectTypeEnabled}

    CppTypeIdPtr: Pointer;

    {$endif}

    NumLeaks: Cardinal;

  end;

  TLeakedClasses = array[0..255] of TLeakedClass;

  PLeakedClasses = ^TLeakedClasses;

  {Leak statistics for a small block type}

  TSmallBlockLeaks = array[0..NumSmallBlockTypes - 1] of TLeakedClasses;

  {A leaked medium or large block}

  TMediumAndLargeBlockLeaks = array[0..4095] of NativeUInt;

{$endif}

var

{$ifdef EnableMemoryLeakReporting}

  {The leaked classes for small blocks}

  LSmallBlockLeaks: TSmallBlockLeaks;

  LLeakType: TMemoryLeakType;

  {$ifdef CheckCppObjectTypeEnabled}

  LLeakedCppTypeIdPtr: Pointer;

  LCppTypeName: PAnsiChar;

  {$endif}

  LMediumAndLargeBlockLeaks: TMediumAndLargeBlockLeaks;

  LNumMediumAndLargeLeaks: Integer;

  LPLargeBlock: PLargeBlockHeader;

  LLeakMessage: array[0..32767] of AnsiChar;

  {$ifndef NoMessageBoxes}

  LMessageTitleBuffer: array[0..1023] of AnsiChar;

  {$endif}

  LMsgPtr: PAnsiChar;

  LExpectedLeaksOnly, LSmallLeakHeaderAdded, LBlockSizeHeaderAdded: Boolean;

  LBlockTypeInd, LClassInd, LBlockInd: Cardinal;

  LMediumBlockSize, LPreviousBlockSize, LLargeBlockSize, LThisBlockSize: NativeUInt;

{$endif}

  LPMediumBlock: Pointer;

  LPMediumBlockPoolHeader: PMediumBlockPoolHeader;

  LMediumBlockHeader: NativeUInt;



{$ifdef EnableMemoryLeakReporting}

  {Tries to account for a memory leak. Returns true if the leak is expected and

   removes the leak from the list}

  function GetMemoryLeakType(AAddress: Pointer; ASpaceInsideBlock: NativeUInt): TMemoryLeakType;

  var

    LLeak: TExpectedMemoryLeak;

  begin

    {Default to not found}

    Result := mltUnexpectedLeak;

    if ExpectedMemoryLeaks <> nil then

    begin

      {Check by pointer address}

      LLeak.LeakAddress := AAddress;

      LLeak.LeakedClass := nil;

      {$ifdef CheckCppObjectTypeEnabled}

      LLeak.LeakedCppTypeIdPtr := nil;

      {$endif}

      LLeak.LeakSize := 0;

      LLeak.LeakCount := -1;

      if UpdateExpectedLeakList(@ExpectedMemoryLeaks.FirstEntryByAddress, @LLeak, False) then

      begin

        Result := mltExpectedLeakRegisteredByPointer;

        Exit;

      end;

      {Check by class}

      LLeak.LeakAddress := nil;

      {$ifdef FullDebugMode}

      LLeak.LeakedClass := TClass(PNativeUInt(PByte(AAddress)+ SizeOf(TFullDebugBlockHeader))^);

      {$else}

      LLeak.LeakedClass := TClass(PNativeUInt(AAddress)^);

      {$endif}

      {$ifdef CheckCppObjectTypeEnabled}

      if Assigned(GetCppVirtObjTypeIdPtrFunc) then

      begin

        {$ifdef FullDebugMode}

        LLeak.LeakedCppTypeIdPtr := GetCppVirtObjTypeIdPtrFunc(Pointer(PByte(AAddress)

          + SizeOf(TFullDebugBlockHeader)), ASpaceInsideBlock);

        {$else}

        LLeak.LeakedCppTypeIdPtr := GetCppVirtObjTypeIdPtrFunc(AAddress, ASpaceInsideBlock);

        {$endif}

      end;

      LLeakedCppTypeIdPtr := LLeak.LeakedCppTypeIdPtr;

      {$endif}

      LLeak.LeakSize := ASpaceInsideBlock;

      if UpdateExpectedLeakList(@ExpectedMemoryLeaks.FirstEntryByClass, @LLeak, False) then

      begin

        Result := mltExpectedLeakRegisteredByClass;

        Exit;

      end;

      {Check by size: the block must be large enough to hold the leak}

      LLeak.LeakedClass := nil;

      if UpdateExpectedLeakList(@ExpectedMemoryLeaks.FirstEntryBySizeOnly, @LLeak, False) then

        Result := mltExpectedLeakRegisteredBySize;

    end;

  end;



  {Checks the small block pool for leaks.}

  procedure CheckSmallBlockPoolForLeaks(APSmallBlockPool: PSmallBlockPoolHeader);

  var

    LLeakedClass: TClass;

    {$ifdef CheckCppObjectTypeEnabled}

    LLeakedCppObjectTypeId: Pointer;

    {$endif}

    LSmallBlockLeakType: TMemoryLeakType;

    LClassIndex: Integer;

    LCurPtr, LEndPtr, LDataPtr: Pointer;

    LBlockTypeIndex: Cardinal;

    LPLeakedClasses: PLeakedClasses;

    LSmallBlockSize: Cardinal;

  begin

    {Get the useable size inside a block}

    LSmallBlockSize := APSmallBlockPool.BlockType.BlockSize - BlockHeaderSize;

  {$ifdef FullDebugMode}

    Dec(LSmallBlockSize, FullDebugBlockOverhead);

  {$endif}

    {Get the block type index}

    LBlockTypeIndex := (UIntPtr(APSmallBlockPool.BlockType) - UIntPtr(@SmallBlockTypes[0])) div SizeOf(TSmallBlockType);

    LPLeakedClasses := @LSmallBlockLeaks[LBlockTypeIndex];

    {Get the first and last pointer for the pool}

    GetFirstAndLastSmallBlockInPool(APSmallBlockPool, LCurPtr, LEndPtr);

    {Step through all blocks}

    while UIntPtr(LCurPtr) <= UIntPtr(LEndPtr) do

    begin

      {Is this block in use? If so, is the debug info intact?}

      if ((PNativeUInt(PByte(LCurPtr) - BlockHeaderSize)^ and IsFreeBlockFlag) = 0) then

      begin

  {$ifdef FullDebugMode}

        if CheckBlockBeforeFreeOrRealloc(LCurPtr, boBlockCheck) then

  {$endif}

        begin

          {$ifdef CheckCppObjectTypeEnabled}

          LLeakedCppTypeIdPtr := nil;

          {$endif}

          {Get the leak type}

          LSmallBlockLeakType := GetMemoryLeakType(LCurPtr, LSmallBlockSize);

    {$ifdef LogMemoryLeakDetailToFile}

      {$ifdef HideExpectedLeaksRegisteredByPointer}

          if LSmallBlockLeakType <> mltExpectedLeakRegisteredByPointer then

      {$endif}

            LogMemoryLeakOrAllocatedBlock(LCurPtr, True);

    {$endif}

          {Only expected leaks?}

          LExpectedLeaksOnly := LExpectedLeaksOnly and (LSmallBlockLeakType <> mltUnexpectedLeak);

    {$ifdef HideExpectedLeaksRegisteredByPointer}

          if LSmallBlockLeakType <> mltExpectedLeakRegisteredByPointer then

    {$endif}

          begin

            {Get a pointer to the user data}

    {$ifndef FullDebugMode}

            LDataPtr := LCurPtr;

    {$else}

            LDataPtr := Pointer(PByte(LCurPtr) + SizeOf(TFullDebugBlockHeader));

    {$endif}

            {Default to an unknown block}

            LClassIndex := 0;

            {Get the class contained by the block}

            LLeakedClass := DetectClassInstance(LDataPtr);

            {Not a Delphi class? -> is it perhaps a string or C++ object type?}

            if LLeakedClass = nil then

            begin

              {$ifdef CheckCppObjectTypeEnabled}

              LLeakedCppObjectTypeId := LLeakedCppTypeIdPtr;

              if (LLeakedCppObjectTypeId = nil) and (ExpectedMemoryLeaks = nil) then

              begin

                if Assigned(GetCppVirtObjTypeIdPtrFunc) then

                begin

                  LLeakedCppObjectTypeId := GetCppVirtObjTypeIdPtrFunc(LDataPtr, LSmallBlockSize);

                end;

              end;

              if Assigned(LLeakedCppObjectTypeId) then

              begin

                LClassIndex := 3;

                while LClassIndex <= High(TLeakedClasses) do

                begin

                  if (Pointer(LPLeakedClasses[LClassIndex].CppTypeIdPtr) = LLeakedCppObjectTypeId)

                    or ((LPLeakedClasses[LClassIndex].CppTypeIdPtr = nil)

                    and (LPLeakedClasses[LClassIndex].ClassPointer = nil)) then

                  begin

                    Break;

                  end;

                  Inc(LClassIndex);

                end;

                if LClassIndex <= High(TLeakedClasses) then

                  Pointer(LPLeakedClasses[LClassIndex].CppTypeIdPtr) := LLeakedCppObjectTypeId

                else

                  LClassIndex := 0;

              end

              else

              begin

              {$endif}

                {Not a known class: Is it perhaps string data?}

                case DetectStringData(LDataPtr, APSmallBlockPool.BlockType.BlockSize - (BlockHeaderSize {$ifdef FullDebugMode} + FullDebugBlockOverhead{$endif})) of

                  stAnsiString: LClassIndex := 1;

                  stUnicodeString: LClassIndex := 2;

                end;

              {$ifdef CheckCppObjectTypeEnabled}

              end;

              {$endif}

            end

            else

            begin

              LClassIndex := 3;

              while LClassIndex <= High(TLeakedClasses) do

              begin

                if (LPLeakedClasses[LClassIndex].ClassPointer = LLeakedClass)

                  or ((LPLeakedClasses[LClassIndex].ClassPointer = nil)

                  {$ifdef CheckCppObjectTypeEnabled}

                  and (LPLeakedClasses[LClassIndex].CppTypeIdPtr = nil)

                  {$endif}

                  ) then

                begin

                  Break;

                end;

                Inc(LClassIndex);

              end;

              if LClassIndex <= High(TLeakedClasses) then

                LPLeakedClasses[LClassIndex].ClassPointer := LLeakedClass

              else

                LClassIndex := 0;

            end;

            {Add to the number of leaks for the class}

            Inc(LPLeakedClasses[LClassIndex].NumLeaks);

          end;

        end;

      end

      else

      begin

  {$ifdef CheckUseOfFreedBlocksOnShutdown}

        {Check that the block has not been modified since being freed}

        CheckFreeBlockUnmodified(LCurPtr, APSmallBlockPool.BlockType.BlockSize, boBlockCheck);

  {$endif}

      end;

      {Next block}

      Inc(PByte(LCurPtr), APSmallBlockPool.BlockType.BlockSize);

    end;

  end;

{$endif}



begin

{$ifdef EnableMemoryLeakReporting}

  {Clear the leak arrays}

  FillChar(LSmallBlockLeaks, SizeOf(LSmallBlockLeaks), 0);

  FillChar(LMediumAndLargeBlockLeaks, SizeOf(LMediumAndLargeBlockLeaks), 0);

  {Step through all the medium block pools}

  LNumMediumAndLargeLeaks := 0;

  {No unexpected leaks so far}

  LExpectedLeaksOnly := True;

{$endif}

  {Step through all the medium block pools}

  LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader;

  while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do

  begin

    LPMediumBlock := GetFirstMediumBlockInPool(LPMediumBlockPoolHeader);

    while LPMediumBlock <> nil do

    begin

      LMediumBlockHeader := PNativeUInt(PByte(LPMediumBlock) - BlockHeaderSize)^;

      {Is the block in use?}

      if LMediumBlockHeader and IsFreeBlockFlag = 0 then

      begin

{$ifdef EnableMemoryLeakReporting}

        if ACheckForLeakedBlocks then

        begin

          if (LMediumBlockHeader and IsSmallBlockPoolInUseFlag) <> 0 then

          begin

            {Get all the leaks for the small block pool}

            CheckSmallBlockPoolForLeaks(LPMediumBlock);

          end

          else

          begin

            if (LNumMediumAndLargeLeaks < Length(LMediumAndLargeBlockLeaks))

  {$ifdef FullDebugMode}

              and CheckBlockBeforeFreeOrRealloc(LPMediumBlock, boBlockCheck)

  {$endif}

            then

            begin

              LMediumBlockSize := (LMediumBlockHeader and DropMediumAndLargeFlagsMask) - BlockHeaderSize;

  {$ifdef FullDebugMode}

              Dec(LMediumBlockSize, FullDebugBlockOverhead);

  {$endif}

              {Get the leak type}

              LLeakType := GetMemoryLeakType(LPMediumBlock, LMediumBlockSize);

              {Is it an expected leak?}

              LExpectedLeaksOnly := LExpectedLeaksOnly and (LLeakType <> mltUnexpectedLeak);

  {$ifdef LogMemoryLeakDetailToFile}

    {$ifdef HideExpectedLeaksRegisteredByPointer}

              if LLeakType <> mltExpectedLeakRegisteredByPointer then

    {$endif}

                LogMemoryLeakOrAllocatedBlock(LPMediumBlock, True);

  {$endif}

  {$ifdef HideExpectedLeaksRegisteredByPointer}

              if LLeakType <> mltExpectedLeakRegisteredByPointer then

  {$endif}

              begin

                {Add the leak to the list}

                LMediumAndLargeBlockLeaks[LNumMediumAndLargeLeaks] := LMediumBlockSize;

                Inc(LNumMediumAndLargeLeaks);

              end;

            end;

          end;

        end;

{$endif}

      end

      else

      begin

{$ifdef CheckUseOfFreedBlocksOnShutdown}

        {Check that the block has not been modified since being freed}

        CheckFreeBlockUnmodified(LPMediumBlock, LMediumBlockHeader and DropMediumAndLargeFlagsMask, boBlockCheck);

{$endif}

      end;

      {Next medium block}

      LPMediumBlock := NextMediumBlock(LPMediumBlock);

    end;

    {Get the next medium block pool}

    LPMediumBlockPoolHeader := LPMediumBlockPoolHeader.NextMediumBlockPoolHeader;

  end;

{$ifdef EnableMemoryLeakReporting}

  if ACheckForLeakedBlocks then

  begin

    {Get all leaked large blocks}

    LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader;

    while LPLargeBlock <> @LargeBlocksCircularList do

    begin

      if (LNumMediumAndLargeLeaks < length(LMediumAndLargeBlockLeaks))

  {$ifdef FullDebugMode}

        and CheckBlockBeforeFreeOrRealloc(Pointer(PByte(LPLargeBlock) + LargeBlockHeaderSize), boBlockCheck)

  {$endif}

      then

      begin

        LLargeBlockSize := (LPLargeBlock.BlockSizeAndFlags and DropMediumAndLargeFlagsMask) - BlockHeaderSize - LargeBlockHeaderSize;

  {$ifdef FullDebugMode}

        Dec(LLargeBlockSize, FullDebugBlockOverhead);

  {$endif}

        {Get the leak type}

        LLeakType := GetMemoryLeakType(Pointer(PByte(LPLargeBlock) + LargeBlockHeaderSize), LLargeBlockSize);

        {Is it an expected leak?}

        LExpectedLeaksOnly := LExpectedLeaksOnly and (LLeakType <> mltUnexpectedLeak);

  {$ifdef LogMemoryLeakDetailToFile}

    {$ifdef HideExpectedLeaksRegisteredByPointer}

        if LLeakType <> mltExpectedLeakRegisteredByPointer then

    {$endif}

          LogMemoryLeakOrAllocatedBlock(Pointer(PByte(LPLargeBlock) + LargeBlockHeaderSize), True);

  {$endif}

  {$ifdef HideExpectedLeaksRegisteredByPointer}

        if LLeakType <> mltExpectedLeakRegisteredByPointer then

  {$endif}

        begin

          {Add the leak}

          LMediumAndLargeBlockLeaks[LNumMediumAndLargeLeaks] := LLargeBlockSize;

          Inc(LNumMediumAndLargeLeaks);

        end;

      end;

      {Get the next large block}

      LPLargeBlock := LPLargeBlock.NextLargeBlockHeader;

    end;

    {Display the leak message if required}

    if not LExpectedLeaksOnly then

    begin

      {Small leak header has not been added}

      LSmallLeakHeaderAdded := False;

      LPreviousBlockSize := 0;

      {Set up the leak message header so long}

      LMsgPtr := AppendStringToBuffer(LeakMessageHeader, @LLeakMessage[0], length(LeakMessageHeader));

      {Step through all the small block types}

      for LBlockTypeInd := 0 to NumSmallBlockTypes - 1 do

      begin

        LThisBlockSize := SmallBlockTypes[LBlockTypeInd].BlockSize - BlockHeaderSize;

  {$ifdef FullDebugMode}

        Dec(LThisBlockSize, FullDebugBlockOverhead);

        if NativeInt(LThisBlockSize) < 0 then

          LThisBlockSize := 0;

  {$endif}

        LBlockSizeHeaderAdded := False;

        {Any leaks?}

        for LClassInd := High(LSmallBlockLeaks[LBlockTypeInd]) downto 0 do

        begin

          {Is there still space in the message buffer? Reserve space for the message

           footer.}

          if LMsgPtr > @LLeakMessage[High(LLeakMessage) - 2048] then

            Break;

          {Check the count}

          if LSmallBlockLeaks[LBlockTypeInd][LClassInd].NumLeaks > 0 then

          begin

            {Need to add the header?}

            if not LSmallLeakHeaderAdded then

            begin

              LMsgPtr := AppendStringToBuffer(SmallLeakDetail, LMsgPtr, Length(SmallLeakDetail));

              LSmallLeakHeaderAdded := True;

            end;

            {Need to add the size header?}

            if not LBlockSizeHeaderAdded then

            begin

              LMsgPtr^ := #13;

              Inc(LMsgPtr);

              LMsgPtr^ := #10;

              Inc(LMsgPtr);

              LMsgPtr := NativeUIntToStrBuf(LPreviousBlockSize + 1, LMsgPtr);

              LMsgPtr^ := ' ';

              Inc(LMsgPtr);

              LMsgPtr^ := '-';

              Inc(LMsgPtr);

              LMsgPtr^ := ' ';

              Inc(LMsgPtr);

              LMsgPtr := NativeUIntToStrBuf(LThisBlockSize, LMsgPtr);

              LMsgPtr := AppendStringToBuffer(BytesMessage, LMsgPtr, Length(BytesMessage));

              LBlockSizeHeaderAdded := True;

            end

            else

            begin

              LMsgPtr^ := ',';

              Inc(LMsgPtr);

              LMsgPtr^ := ' ';

              Inc(LMsgPtr);

            end;

            {Show the count}

            case LClassInd of

              {Unknown}

              0:

              begin

                LMsgPtr := AppendStringToBuffer(UnknownClassNameMsg, LMsgPtr, Length(UnknownClassNameMsg));

              end;

              {AnsiString}

              1:

              begin

                LMsgPtr := AppendStringToBuffer(AnsiStringBlockMessage, LMsgPtr, Length(AnsiStringBlockMessage));

              end;

              {UnicodeString}

              2:

              begin

                LMsgPtr := AppendStringToBuffer(UnicodeStringBlockMessage, LMsgPtr, Length(UnicodeStringBlockMessage));

              end;

              {Classes}

            else

              begin

                {$ifdef CheckCppObjectTypeEnabled}

                if LSmallBlockLeaks[LBlockTypeInd][LClassInd].CppTypeIdPtr <> nil then

                begin

                  if Assigned(GetCppVirtObjTypeNameByTypeIdPtrFunc) then

                  begin

                    LCppTypeName := GetCppVirtObjTypeNameByTypeIdPtrFunc(LSmallBlockLeaks[LBlockTypeInd][LClassInd].CppTypeIdPtr);

                    LMsgPtr := AppendStringToBuffer(LCppTypeName, LMsgPtr, StrLen(LCppTypeName));

                  end

                  else

                    LMsgPtr := AppendClassNameToBuffer(nil, LMsgPtr);

                end

                else

                begin

                {$endif}

                  LMsgPtr := AppendClassNameToBuffer(LSmallBlockLeaks[LBlockTypeInd][LClassInd].ClassPointer, LMsgPtr);

                {$ifdef CheckCppObjectTypeEnabled}

                end;

                {$endif}

              end;

            end;

            {Add the count}

            LMsgPtr^ := ' ';

            Inc(LMsgPtr);

            LMsgPtr^ := 'x';

            Inc(LMsgPtr);

            LMsgPtr^ := ' ';

            Inc(LMsgPtr);

            LMsgPtr := NativeUIntToStrBuf(LSmallBlockLeaks[LBlockTypeInd][LClassInd].NumLeaks, LMsgPtr);

          end;

        end;

        LPreviousBlockSize := LThisBlockSize;

      end;

      {Add the medium/large block leak message}

      if LNumMediumAndLargeLeaks > 0 then

      begin

        {Any non-small leaks?}

        if LSmallLeakHeaderAdded then

        begin

          LMsgPtr^ := #13;

          Inc(LMsgPtr);

          LMsgPtr^ := #10;

          Inc(LMsgPtr);

          LMsgPtr^ := #13;

          Inc(LMsgPtr);

          LMsgPtr^ := #10;

          Inc(LMsgPtr);

        end;

        {Add the medium/large block leak message}

        LMsgPtr := AppendStringToBuffer(LargeLeakDetail, LMsgPtr, Length(LargeLeakDetail));

        {List all the blocks}

        for LBlockInd := 0 to LNumMediumAndLargeLeaks - 1 do

        begin

          if LBlockInd <> 0 then

          begin

            LMsgPtr^ := ',';

            Inc(LMsgPtr);

            LMsgPtr^ :=  ' ';

            Inc(LMsgPtr);

          end;

          LMsgPtr := NativeUIntToStrBuf(LMediumAndLargeBlockLeaks[LBlockInd], LMsgPtr);

          {Is there still space in the message buffer? Reserve space for the

           message footer.}

          if LMsgPtr > @LLeakMessage[High(LLeakMessage) - 2048] then

            Break;

        end;

      end;

  {$ifdef LogErrorsToFile}

     {Set the message footer}

      LMsgPtr := AppendStringToBuffer(LeakMessageFooter, LMsgPtr, Length(LeakMessageFooter));

      {Append the message to the memory errors file}

      AppendEventLog(@LLeakMessage[0], UIntPtr(LMsgPtr) - UIntPtr(@LLeakMessage[1]));

  {$else}

      {Set the message footer}

      AppendStringToBuffer(LeakMessageFooter, LMsgPtr, Length(LeakMessageFooter));

  {$endif}

  {$ifdef UseOutputDebugString}

      OutputDebugStringA(LLeakMessage);

  {$endif}

  {$ifndef NoMessageBoxes}

      {Show the message}

      AppendStringToModuleName(LeakMessageTitle, LMessageTitleBuffer);

      ShowMessageBox(LLeakMessage, LMessageTitleBuffer);

  {$endif}

    end;

  end;

{$endif}

end;



{Returns statistics about the current state of the memory manager}

procedure GetMemoryManagerState(var AMemoryManagerState: TMemoryManagerState);

var

  LPMediumBlockPoolHeader: PMediumBlockPoolHeader;

  LPMediumBlock: Pointer;

  LInd: Integer;

  LBlockTypeIndex, LMediumBlockSize: Cardinal;

  LMediumBlockHeader, LLargeBlockSize: NativeUInt;

  LPLargeBlock: PLargeBlockHeader;

begin

  {Clear the structure}

  FillChar(AMemoryManagerState, SizeOf(AMemoryManagerState), 0);

  {Set the small block size stats}

  for LInd := 0 to NumSmallBlockTypes - 1 do

  begin

    AMemoryManagerState.SmallBlockTypeStates[LInd].InternalBlockSize :=

      SmallBlockTypes[LInd].BlockSize;

    AMemoryManagerState.SmallBlockTypeStates[LInd].UseableBlockSize :=

      SmallBlockTypes[LInd].BlockSize - BlockHeaderSize{$ifdef FullDebugMode} - FullDebugBlockOverhead{$endif};

    if NativeInt(AMemoryManagerState.SmallBlockTypeStates[LInd].UseableBlockSize) < 0 then

      AMemoryManagerState.SmallBlockTypeStates[LInd].UseableBlockSize := 0;

  end;

  {Lock all small block types}

  LockAllSmallBlockTypes;

  {Lock the medium blocks}

  LockMediumBlocks;

  {Step through all the medium block pools}

  LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader;

  while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do

  begin

    {Add to the medium block used space}

    Inc(AMemoryManagerState.ReservedMediumBlockAddressSpace, MediumBlockPoolSize);

    LPMediumBlock := GetFirstMediumBlockInPool(LPMediumBlockPoolHeader);

    while LPMediumBlock <> nil do

    begin

      LMediumBlockHeader := PNativeUInt(PByte(LPMediumBlock) - BlockHeaderSize)^;

      {Is the block in use?}

      if LMediumBlockHeader and IsFreeBlockFlag = 0 then

      begin

        {Get the block size}

        LMediumBlockSize := LMediumBlockHeader and DropMediumAndLargeFlagsMask;

        if (LMediumBlockHeader and IsSmallBlockPoolInUseFlag) <> 0 then

        begin

          {Get the block type index}

          LBlockTypeIndex := (UIntPtr(PSmallBlockPoolHeader(LPMediumBlock).BlockType) - UIntPtr(@SmallBlockTypes[0])) div SizeOf(TSmallBlockType);

          {Subtract from medium block usage}

          Dec(AMemoryManagerState.ReservedMediumBlockAddressSpace, LMediumBlockSize);

          {Add it to the reserved space for the block size}

          Inc(AMemoryManagerState.SmallBlockTypeStates[LBlockTypeIndex].ReservedAddressSpace, LMediumBlockSize);

          {Add the usage for the pool}

          Inc(AMemoryManagerState.SmallBlockTypeStates[LBlockTypeIndex].AllocatedBlockCount,

            PSmallBlockPoolHeader(LPMediumBlock).BlocksInUse);

        end

        else

        begin

{$ifdef FullDebugMode}

          Dec(LMediumBlockSize, FullDebugBlockOverhead);

{$endif}

          Inc(AMemoryManagerState.AllocatedMediumBlockCount);

          Inc(AMemoryManagerState.TotalAllocatedMediumBlockSize, LMediumBlockSize - BlockHeaderSize);

        end;

      end;

      {Next medium block}

      LPMediumBlock := NextMediumBlock(LPMediumBlock);

    end;

    {Get the next medium block pool}

    LPMediumBlockPoolHeader := LPMediumBlockPoolHeader.NextMediumBlockPoolHeader;

  end;

  {Unlock medium blocks}

  MediumBlocksLocked := False;

  {Unlock all the small block types}

  for LInd := 0 to NumSmallBlockTypes - 1 do

    SmallBlockTypes[LInd].BlockTypeLocked := False;

  {Step through all the large blocks}

  LockLargeBlocks;

  LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader;

  while LPLargeBlock <> @LargeBlocksCircularList do

  begin

    LLargeBlockSize := LPLargeBlock.BlockSizeAndFlags and DropMediumAndLargeFlagsMask;

    Inc(AMemoryManagerState.AllocatedLargeBlockCount);

    Inc(AMemoryManagerState.ReservedLargeBlockAddressSpace, LLargeBlockSize);

    Inc(AMemoryManagerState.TotalAllocatedLargeBlockSize, LPLargeBlock.UserAllocatedSize);

    {Get the next large block}

    LPLargeBlock := LPLargeBlock.NextLargeBlockHeader;

  end;

  LargeBlocksLocked := False;

end;



{Returns a summary of the information returned by GetMemoryManagerState}

procedure GetMemoryManagerUsageSummary(

  var AMemoryManagerUsageSummary: TMemoryManagerUsageSummary);

var

  LMMS: TMemoryManagerState;

  LAllocatedBytes, LReservedBytes: NativeUInt;

  LSBTIndex: Integer;

begin

  {Get the memory manager state}

  GetMemoryManagerState(LMMS);

  {Add up the totals}

  LAllocatedBytes := LMMS.TotalAllocatedMediumBlockSize

    + LMMS.TotalAllocatedLargeBlockSize;

  LReservedBytes := LMMS.ReservedMediumBlockAddressSpace

    + LMMS.ReservedLargeBlockAddressSpace;

  for LSBTIndex := 0 to NumSmallBlockTypes - 1 do

  begin

    Inc(LAllocatedBytes, LMMS.SmallBlockTypeStates[LSBTIndex].UseableBlockSize

      * LMMS.SmallBlockTypeStates[LSBTIndex].AllocatedBlockCount);

    Inc(LReservedBytes, LMMS.SmallBlockTypeStates[LSBTIndex].ReservedAddressSpace);

  end;

  {Set the structure values}

  AMemoryManagerUsageSummary.AllocatedBytes := LAllocatedBytes;

  AMemoryManagerUsageSummary.OverheadBytes := LReservedBytes - LAllocatedBytes;

  if LReservedBytes > 0 then

  begin

    AMemoryManagerUsageSummary.EfficiencyPercentage :=

      LAllocatedBytes / LReservedBytes * 100;

  end

  else

    AMemoryManagerUsageSummary.EfficiencyPercentage := 100;

end;



{$ifndef POSIX}

{Gets the state of every 64K block in the 4GB address space. Under 64-bit this

 returns only the state for the low 4GB.}

procedure GetMemoryMap(var AMemoryMap: TMemoryMap);

var

  LPMediumBlockPoolHeader: PMediumBlockPoolHeader;

  LPLargeBlock: PLargeBlockHeader;

  LInd, LChunkIndex, LNextChunk, LLargeBlockSize: NativeUInt;

  LMBI: TMemoryBasicInformation;

begin

  {Clear the map}

  FillChar(AMemoryMap, SizeOf(AMemoryMap), Ord(csUnallocated));

  {Step through all the medium block pools}

  LockMediumBlocks;

  LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader;

  while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do

  begin

    {Add to the medium block used space}

    LChunkIndex := NativeUInt(LPMediumBlockPoolHeader) shr 16;

    for LInd := 0 to (MediumBlockPoolSize - 1) shr 16 do

    begin

      if (LChunkIndex + LInd) > High(AMemoryMap) then

        Break;

      AMemoryMap[LChunkIndex + LInd] := csAllocated;

    end;

    {Get the next medium block pool}

    LPMediumBlockPoolHeader := LPMediumBlockPoolHeader.NextMediumBlockPoolHeader;

  end;

  MediumBlocksLocked := False;

  {Step through all the large blocks}

  LockLargeBlocks;

  LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader;

  while LPLargeBlock <> @LargeBlocksCircularList do

  begin

    LChunkIndex := UIntPtr(LPLargeBlock) shr 16;

    LLargeBlockSize := LPLargeBlock.BlockSizeAndFlags and DropMediumAndLargeFlagsMask;

    for LInd := 0 to (LLargeBlockSize - 1) shr 16 do

    begin

      if (LChunkIndex + LInd) > High(AMemoryMap) then

        Break;

      AMemoryMap[LChunkIndex + LInd] := csAllocated;

    end;

    {Get the next large block}

    LPLargeBlock := LPLargeBlock.NextLargeBlockHeader;

  end;

  LargeBlocksLocked := False;

  {Fill in the rest of the map}

  LInd := 0;

  while LInd <= 65535 do

  begin

    {If the chunk is not allocated by this MM, what is its status?}

    if AMemoryMap[LInd] = csUnallocated then

    begin

      {Query the address space starting at the chunk boundary}

      if VirtualQuery(Pointer(LInd * 65536), LMBI, SizeOf(LMBI)) = 0 then

      begin

        {VirtualQuery may fail for addresses >2GB if a large address space is

         not enabled.}

        FillChar(AMemoryMap[LInd], 65536 - LInd, csSysReserved);

        Break;

      end;

      {Get the chunk number after the region}

      LNextChunk := (LMBI.RegionSize - 1) shr 16 + LInd + 1;

      {Validate}

      if LNextChunk > 65536 then

        LNextChunk := 65536;

      {Set the status of all the chunks in the region}

      if LMBI.State = MEM_COMMIT then

      begin

        FillChar(AMemoryMap[LInd], LNextChunk - LInd, csSysAllocated);

      end

      else

      begin

        if LMBI.State = MEM_RESERVE then

          FillChar(AMemoryMap[LInd], LNextChunk - LInd, csSysReserved);

      end;

      {Point to the start of the next chunk}

      LInd := LNextChunk;

    end

    else

    begin

      {Next chunk}

      Inc(LInd);

    end;

  end;

end;

{$endif}



{Returns summarised information about the state of the memory manager. (For

 backward compatibility.)}

function FastGetHeapStatus: THeapStatus;

var

  LPMediumBlockPoolHeader: PMediumBlockPoolHeader;

  LPMediumBlock: Pointer;

  LBlockTypeIndex, LMediumBlockSize: Cardinal;

  LSmallBlockUsage, LSmallBlockOverhead, LMediumBlockHeader, LLargeBlockSize: NativeUInt;

  LInd: Integer;

  LPLargeBlock: PLargeBlockHeader;

begin

  {Clear the structure}

  FillChar(Result, SizeOf(Result), 0);

  {Lock all small block types}

  LockAllSmallBlockTypes;

  {Lock the medium blocks}

  LockMediumBlocks;

  {Step through all the medium block pools}

  LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader;

  while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do

  begin

    {Add to the total and committed address space}

    Inc(Result.TotalAddrSpace, ((MediumBlockPoolSize + $ffff) and $ffff0000));

    Inc(Result.TotalCommitted, ((MediumBlockPoolSize + $ffff) and $ffff0000));

    {Add the medium block pool overhead}

    Inc(Result.Overhead, (((MediumBlockPoolSize + $ffff) and $ffff0000)

      - MediumBlockPoolSize + MediumBlockPoolHeaderSize));

    {Get the first medium block in the pool}

    LPMediumBlock := GetFirstMediumBlockInPool(LPMediumBlockPoolHeader);

    while LPMediumBlock <> nil do

    begin

      {Get the block header}

      LMediumBlockHeader := PNativeUInt(PByte(LPMediumBlock) - BlockHeaderSize)^;

      {Get the block size}

      LMediumBlockSize := LMediumBlockHeader and DropMediumAndLargeFlagsMask;

      {Is the block in use?}

      if LMediumBlockHeader and IsFreeBlockFlag = 0 then

      begin

        if (LMediumBlockHeader and IsSmallBlockPoolInUseFlag) <> 0 then

        begin

          {Get the block type index}

          LBlockTypeIndex := (UIntPtr(PSmallBlockPoolHeader(LPMediumBlock).BlockType) - UIntPtr(@SmallBlockTypes[0])) div SizeOf(TSmallBlockType);

          {Get the usage in the block}

          LSmallBlockUsage := PSmallBlockPoolHeader(LPMediumBlock).BlocksInUse

            * SmallBlockTypes[LBlockTypeIndex].BlockSize;

          {Get the total overhead for all the small blocks}

          LSmallBlockOverhead := PSmallBlockPoolHeader(LPMediumBlock).BlocksInUse

              * (BlockHeaderSize{$ifdef FullDebugMode} + FullDebugBlockOverhead{$endif});

          {Add to the totals}

          Inc(Result.FreeSmall, LMediumBlockSize - LSmallBlockUsage - BlockHeaderSize);

          Inc(Result.Overhead, LSmallBlockOverhead + BlockHeaderSize);

          Inc(Result.TotalAllocated, LSmallBlockUsage - LSmallBlockOverhead);

        end

        else

        begin

{$ifdef FullDebugMode}

          Dec(LMediumBlockSize, FullDebugBlockOverhead);

          Inc(Result.Overhead, FullDebugBlockOverhead);

{$endif}

          {Add to the result}

          Inc(Result.TotalAllocated, LMediumBlockSize - BlockHeaderSize);

          Inc(Result.Overhead, BlockHeaderSize);

        end;

      end

      else

      begin

        {The medium block is free}

        Inc(Result.FreeBig, LMediumBlockSize);

      end;

      {Next medium block}

      LPMediumBlock := NextMediumBlock(LPMediumBlock);

    end;

    {Get the next medium block pool}

    LPMediumBlockPoolHeader := LPMediumBlockPoolHeader.NextMediumBlockPoolHeader;

  end;

  {Add the sequential feed unused space}

  Inc(Result.Unused, MediumSequentialFeedBytesLeft);

  {Unlock the medium blocks}

  MediumBlocksLocked := False;

  {Unlock all the small block types}

  for LInd := 0 to NumSmallBlockTypes - 1 do

    SmallBlockTypes[LInd].BlockTypeLocked := False;

  {Step through all the large blocks}

  LockLargeBlocks;

  LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader;

  while LPLargeBlock <> @LargeBlocksCircularList do

  begin

    LLargeBlockSize := LPLargeBlock.BlockSizeAndFlags and DropMediumAndLargeFlagsMask;

    Inc(Result.TotalAddrSpace, LLargeBlockSize);

    Inc(Result.TotalCommitted, LLargeBlockSize);

    Inc(Result.TotalAllocated, LPLargeBlock.UserAllocatedSize

      {$ifdef FullDebugMode} - FullDebugBlockOverhead{$endif});

    Inc(Result.Overhead, LLargeBlockSize - LPLargeBlock.UserAllocatedSize

      {$ifdef FullDebugMode} + FullDebugBlockOverhead{$endif});

    {Get the next large block}

    LPLargeBlock := LPLargeBlock.NextLargeBlockHeader;

  end;

  LargeBlocksLocked := False;

  {Set the total number of free bytes}

  Result.TotalFree := Result.FreeSmall + Result.FreeBig + Result.Unused;

end;



{Frees all allocated memory. Does not support segmented large blocks (yet).}

procedure FreeAllMemory;

var

  LPMediumBlockPoolHeader, LPNextMediumBlockPoolHeader: PMediumBlockPoolHeader;

  LPMediumFreeBlock: PMediumFreeBlock;

  LPLargeBlock, LPNextLargeBlock: PLargeBlockHeader;

  LInd: Integer;

begin

  {Free all block pools}

  LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader;

  while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do

  begin

    {Get the next medium block pool so long}

    LPNextMediumBlockPoolHeader := LPMediumBlockPoolHeader.NextMediumBlockPoolHeader;

{$ifdef ClearMediumBlockPoolsBeforeReturningToOS}

    FillChar(LPMediumBlockPoolHeader^, MediumBlockPoolSize, 0);

{$else}

    {$ifdef ClearSmallAndMediumBlocksInFreeMem}

    FillChar(LPMediumBlockPoolHeader^, MediumBlockPoolSize, 0);

    {$endif}

{$endif}

    {Free this pool}

    VirtualFree(LPMediumBlockPoolHeader, 0, MEM_RELEASE);

    {Next pool}

    LPMediumBlockPoolHeader := LPNextMediumBlockPoolHeader;

  end;

  {Clear all small block types}

  for LInd := 0 to High(SmallBlockTypes) do

  begin

    SmallBlockTypes[Lind].PreviousPartiallyFreePool := @SmallBlockTypes[Lind];

    SmallBlockTypes[Lind].NextPartiallyFreePool := @SmallBlockTypes[Lind];

    SmallBlockTypes[Lind].NextSequentialFeedBlockAddress := Pointer(1);

    SmallBlockTypes[Lind].MaxSequentialFeedBlockAddress := nil;

  end;

  {Clear all medium block pools}

  MediumBlockPoolsCircularList.PreviousMediumBlockPoolHeader := @MediumBlockPoolsCircularList;

  MediumBlockPoolsCircularList.NextMediumBlockPoolHeader := @MediumBlockPoolsCircularList;

  {All medium bins are empty}

  for LInd := 0 to High(MediumBlockBins) do

  begin

    LPMediumFreeBlock := @MediumBlockBins[LInd];

    LPMediumFreeBlock.PreviousFreeBlock := LPMediumFreeBlock;

    LPMediumFreeBlock.NextFreeBlock := LPMediumFreeBlock;

  end;

  MediumBlockBinGroupBitmap := 0;

  FillChar(MediumBlockBinBitmaps, SizeOf(MediumBlockBinBitmaps), 0);

  MediumSequentialFeedBytesLeft := 0;

  {Free all large blocks}

  LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader;

  while LPLargeBlock <> @LargeBlocksCircularList do

  begin

    {Get the next large block}

    LPNextLargeBlock := LPLargeBlock.NextLargeBlockHeader;

{$ifdef ClearLargeBlocksBeforeReturningToOS}

    FillChar(LPLargeBlock^,

      LPLargeBlock.BlockSizeAndFlags and DropMediumAndLargeFlagsMask, 0);

{$endif}

    {Free this large block}

    VirtualFree(LPLargeBlock, 0, MEM_RELEASE);

    {Next large block}

    LPLargeBlock := LPNextLargeBlock;

  end;

  {There are no large blocks allocated}

  LargeBlocksCircularList.PreviousLargeBlockHeader := @LargeBlocksCircularList;

  LargeBlocksCircularList.NextLargeBlockHeader := @LargeBlocksCircularList;

end;



{----------------------------Memory Manager Setup-----------------------------}



{Checks that no other memory manager has been installed after the RTL MM and

 that there are currently no live pointers allocated through the RTL MM.}

function CheckCanInstallMemoryManager: Boolean;

{$ifndef NoMessageBoxes}

var

  LErrorMessageTitle: array[0..1023] of AnsiChar;

{$endif}

begin

  {Default to error}

  Result := False;

{$ifdef FullDebugMode}

  {$ifdef LoadDebugDLLDynamically}

    {$ifdef DoNotInstallIfDLLMissing}

  {Should FastMM be installed only if the FastMM_FullDebugMode.dll file is

   available?}

  if FullDebugModeDLL = 0 then

    Exit;

    {$endif}

  {$endif}

{$endif}

  {Is FastMM already installed?}

  if FastMMIsInstalled then

  begin

{$ifdef UseOutputDebugString}

    OutputDebugStringA(AlreadyInstalledMsg);

{$endif}

{$ifndef NoMessageBoxes}

    AppendStringToModuleName(AlreadyInstalledTitle, LErrorMessageTitle);

    ShowMessageBox(AlreadyInstalledMsg, LErrorMessageTitle);

{$endif}

    Exit;

  end;

  {Has another MM been set, or has the Embarcadero MM been used? If so, this

   file is not the first unit in the uses clause of the project's .dpr file.}

  if IsMemoryManagerSet then

  begin

    {When using runtime packages, another library may already have installed

     FastMM: Silently ignore the installation request.}

{$ifndef UseRuntimePackages}

    {Another memory manager has been set.}

  {$ifdef UseOutputDebugString}

    OutputDebugStringA(OtherMMInstalledMsg);

  {$endif}

  {$ifndef NoMessageBoxes}

    AppendStringToModuleName(OtherMMInstalledTitle, LErrorMessageTitle);

    ShowMessageBox(OtherMMInstalledMsg, LErrorMessageTitle);

  {$endif}

{$endif}

    Exit;

  end;

{$ifndef POSIX}

  if GetHeapStatus.TotalAllocated <> 0 then

  begin

    {Memory has been already been allocated with the RTL MM}

{$ifdef UseOutputDebugString}

    OutputDebugStringA(MemoryAllocatedMsg);

{$endif}

  {$ifndef NoMessageBoxes}

    AppendStringToModuleName(MemoryAllocatedTitle, LErrorMessageTitle);

    ShowMessageBox(MemoryAllocatedMsg, LErrorMessageTitle);

  {$endif}

    Exit;

  end;

{$endif}

  {All OK}

  Result := True;

end;



{Initializes the lookup tables for the memory manager}

procedure InitializeMemoryManager;

const

  {The size of the Inc(VMTIndex) code in TFreedObject.GetVirtualMethodIndex}

  VMTIndexIncCodeSize = 6;

var

  LInd, LSizeInd, LMinimumPoolSize, LOptimalPoolSize, LGroupNumber,

    LBlocksPerPool, LPreviousBlockSize: Cardinal;

  LPMediumFreeBlock: PMediumFreeBlock;

begin

{$ifdef FullDebugMode}

  {$ifdef LoadDebugDLLDynamically}

  {Attempt to load the FullDebugMode DLL dynamically.}

  FullDebugModeDLL := LoadLibrary(FullDebugModeLibraryName);

  if FullDebugModeDLL <> 0 then

  begin

    GetStackTrace := GetProcAddress(FullDebugModeDLL,

      {$ifdef RawStackTraces}'GetRawStackTrace'{$else}'GetFrameBasedStackTrace'{$endif});

    LogStackTrace := GetProcAddress(FullDebugModeDLL, 'LogStackTrace');

  end;

  {$endif}

{$endif}

{$ifdef EnableMMX}

  {$ifndef ForceMMX}

  UseMMX := MMX_Supported;

  {$endif}

{$endif}

  {Initialize the memory manager}

  {-------------Set up the small block types-------------}

  LPreviousBlockSize := 0;

  for LInd := 0 to High(SmallBlockTypes) do

  begin

    {Set the move procedure}

{$ifdef UseCustomFixedSizeMoveRoutines}

    {The upsize move procedure may move chunks in 16 bytes even with 8-byte

    alignment, since the new size will always be at least 8 bytes bigger than

    the old size.}

    if not Assigned(SmallBlockTypes[LInd].UpsizeMoveProcedure) then

  {$ifdef UseCustomVariableSizeMoveRoutines}

      SmallBlockTypes[LInd].UpsizeMoveProcedure := MoveX16LP;

  {$else}

      SmallBlockTypes[LInd].UpsizeMoveProcedure := @System.Move;

  {$endif}

{$endif}

    {Set the first "available pool" to the block type itself, so that the

     allocation routines know that there are currently no pools with free

     blocks of this size.}

    SmallBlockTypes[LInd].PreviousPartiallyFreePool := @SmallBlockTypes[LInd];

    SmallBlockTypes[LInd].NextPartiallyFreePool := @SmallBlockTypes[LInd];

    {Set the block size to block type index translation table}

    for LSizeInd := (LPreviousBlockSize div SmallBlockGranularity) to ((SmallBlockTypes[LInd].BlockSize - 1) div SmallBlockGranularity) do

      AllocSize2SmallBlockTypeIndX4[LSizeInd] := LInd * 4;

    {Cannot sequential feed yet: Ensure that the next address is greater than

     the maximum address}

    SmallBlockTypes[LInd].MaxSequentialFeedBlockAddress := Pointer(0);

    SmallBlockTypes[LInd].NextSequentialFeedBlockAddress := Pointer(1);

    {Get the mask to use for finding a medium block suitable for a block pool}

    LMinimumPoolSize :=

      ((SmallBlockTypes[LInd].BlockSize * MinimumSmallBlocksPerPool

        + SmallBlockPoolHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset)

      and -MediumBlockGranularity) + MediumBlockSizeOffset;

    if LMinimumPoolSize < MinimumMediumBlockSize then

      LMinimumPoolSize := MinimumMediumBlockSize;

    {Get the closest group number for the minimum pool size}

    LGroupNumber := (LMinimumPoolSize - MinimumMediumBlockSize + MediumBlockBinsPerGroup * MediumBlockGranularity div 2)

      div (MediumBlockBinsPerGroup * MediumBlockGranularity);

    {Too large?}

    if LGroupNumber > 7 then

      LGroupNumber := 7;

    {Set the bitmap}

    SmallBlockTypes[LInd].AllowedGroupsForBlockPoolBitmap := Byte(-(1 shl LGroupNumber));

    {Set the minimum pool size}

    SmallBlockTypes[LInd].MinimumBlockPoolSize := MinimumMediumBlockSize + LGroupNumber * (MediumBlockBinsPerGroup * MediumBlockGranularity);

    {Get the optimal block pool size}

    LOptimalPoolSize := ((SmallBlockTypes[LInd].BlockSize * TargetSmallBlocksPerPool

        + SmallBlockPoolHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset)

      and -MediumBlockGranularity) + MediumBlockSizeOffset;

    {Limit the optimal pool size to within range}

    if LOptimalPoolSize < OptimalSmallBlockPoolSizeLowerLimit then

      LOptimalPoolSize := OptimalSmallBlockPoolSizeLowerLimit;

    if LOptimalPoolSize > OptimalSmallBlockPoolSizeUpperLimit then

      LOptimalPoolSize := OptimalSmallBlockPoolSizeUpperLimit;

    {How many blocks will fit in the adjusted optimal size?}

    LBlocksPerPool := (LOptimalPoolSize - SmallBlockPoolHeaderSize) div SmallBlockTypes[LInd].BlockSize;

    {Recalculate the optimal pool size to minimize wastage due to a partial

     last block.}

    SmallBlockTypes[LInd].OptimalBlockPoolSize :=

      ((LBlocksPerPool * SmallBlockTypes[LInd].BlockSize + SmallBlockPoolHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset) and -MediumBlockGranularity) + MediumBlockSizeOffset;

{$ifdef CheckHeapForCorruption}

    {Debug checks}

    if (SmallBlockTypes[LInd].OptimalBlockPoolSize < MinimumMediumBlockSize)

      or (SmallBlockTypes[LInd].BlockSize div SmallBlockGranularity * SmallBlockGranularity <> SmallBlockTypes[LInd].BlockSize) then

    begin

  {$ifdef BCB6OrDelphi7AndUp}

      System.Error(reInvalidPtr);

  {$else}

      System.RunError(reInvalidPtr);

  {$endif}

    end;

{$endif}

    {Set the previous small block size}

    LPreviousBlockSize := SmallBlockTypes[LInd].BlockSize;

  end;

  {-------------------Set up the medium blocks-------------------}

{$ifdef CheckHeapForCorruption}

  {Check that there are no gaps between where the small blocks end and the

   medium blocks start}

  if (((MaximumSmallBlockSize - 3) + (MediumBlockGranularity - 1 + BlockHeaderSize - MediumBlockSizeOffset))

    and -MediumBlockGranularity) + MediumBlockSizeOffset < MinimumMediumBlockSize then

  begin

  {$ifdef BCB6OrDelphi7AndUp}

    System.Error(reInvalidPtr);

  {$else}

    System.RunError(reInvalidPtr);

  {$endif}

  end;

{$endif}

  {There are currently no medium block pools}

  MediumBlockPoolsCircularList.PreviousMediumBlockPoolHeader := @MediumBlockPoolsCircularList;

  MediumBlockPoolsCircularList.NextMediumBlockPoolHeader := @MediumBlockPoolsCircularList;

  {All medium bins are empty}

  for LInd := 0 to High(MediumBlockBins) do

  begin

    LPMediumFreeBlock := @MediumBlockBins[LInd];

    LPMediumFreeBlock.PreviousFreeBlock := LPMediumFreeBlock;

    LPMediumFreeBlock.NextFreeBlock := LPMediumFreeBlock;

  end;

  {------------------Set up the large blocks---------------------}

  LargeBlocksCircularList.PreviousLargeBlockHeader := @LargeBlocksCircularList;

  LargeBlocksCircularList.NextLargeBlockHeader := @LargeBlocksCircularList;

  {------------------Set up the debugging structures---------------------}

{$ifdef FullDebugMode}

  {Set up the fake VMT}

  {Copy the basic info from the TFreedObject class}

  System.Move(Pointer(PByte(TFreedObject) + vmtSelfPtr + SizeOf(Pointer))^,

    FreedObjectVMT.VMTData[vmtSelfPtr + SizeOf(Pointer)], vmtParent - vmtSelfPtr);

  PNativeUInt(@FreedObjectVMT.VMTData[vmtSelfPtr])^ := NativeUInt(@FreedObjectVMT.VMTMethods[0]);

  {Set up the virtual method table}

  for LInd := 0 to MaxFakeVMTEntries - 1 do

  begin

    PNativeUInt(@FreedObjectVMT.VMTMethods[Low(FreedObjectVMT.VMTMethods) + Integer(LInd * SizeOf(Pointer))])^ :=

      NativeUInt(@TFreedObject.GetVirtualMethodIndex) + LInd * VMTIndexIncCodeSize;

  {$ifdef CatchUseOfFreedInterfaces}

    VMTBadInterface[LInd] := @TFreedObject.InterfaceError;

  {$endif}

  end;

  {Set up the default log file name}

  SetDefaultMMLogFileName;

{$endif}

end;



{Installs the memory manager (InitializeMemoryManager should be called first)}

procedure InstallMemoryManager;

{$ifdef MMSharingEnabled}

var

  i, LCurrentProcessID: Cardinal;

  LPMapAddress: PPointer;

  LChar: AnsiChar;

{$endif}

begin

  if not FastMMIsInstalled then

  begin

{$ifdef FullDebugMode}

  {$ifdef 32Bit}

    {Try to reserve the 64K block covering address $80808080}

    ReservedBlock := VirtualAlloc(Pointer(DebugReservedAddress), 65536, MEM_RESERVE, PAGE_NOACCESS);

  {$endif}

{$endif}

{$ifdef MMSharingEnabled}

    {Build a string identifying the current process}

    LCurrentProcessID := GetCurrentProcessId;

    for i := 0 to 7 do

    begin

      LChar := HexTable[((LCurrentProcessID shr (i * 4)) and $F)];

      MappingObjectName[(High(MappingObjectName) - 1) - i] := LChar;

  {$ifdef EnableBackwardCompatibleMMSharing}

      UniqueProcessIDString[8 - i] := LChar;

      UniqueProcessIDStringBE[8 - i] := LChar;

  {$endif}

    end;

{$endif}

{$ifdef AttemptToUseSharedMM}

    {Is the replacement memory manager already installed for this process?}

{$ifdef EnableBackwardCompatibleMMSharing}

    MMWindow := FindWindowA('STATIC', PAnsiChar(@UniqueProcessIDString[1]));

    MMWindowBE := FindWindowA('STATIC', PAnsiChar(@UniqueProcessIDStringBE[1]));

{$endif}

    MappingObjectHandle := OpenFileMappingA(FILE_MAP_READ, False, MappingObjectName);

    {Is no MM being shared?}

{$ifdef EnableBackwardCompatibleMMSharing}

    if (MMWindow or MMWindowBE or MappingObjectHandle) = 0 then

{$else}

    if MappingObjectHandle = 0 then

{$endif}

    begin

{$endif}

{$ifdef ShareMM}

      {Share the MM with other DLLs? - if this DLL is unloaded, then

       dependent DLLs will cause a crash.}

  {$ifndef ShareMMIfLibrary}

      if not IsLibrary then

  {$endif}

      begin

  {$ifdef EnableBackwardCompatibleMMSharing}

        {No memory manager installed yet - create the invisible window}

        MMWindow := CreateWindowA('STATIC', PAnsiChar(@UniqueProcessIDString[1]),

          WS_POPUP, 0, 0, 0, 0, 0, 0, hInstance, nil);

        MMWindowBE := CreateWindowA('STATIC', PAnsiChar(@UniqueProcessIDStringBE[1]),

          WS_POPUP, 0, 0, 0, 0, 0, 0, hInstance, nil);

        {The window data is a pointer to this memory manager}

        if MMWindow <> 0 then

          SetWindowLongA(MMWindow, GWL_USERDATA, NativeInt(@NewMemoryManager));

        if MMWindowBE <> 0 then

          SetWindowLongA(MMWindowBE, GWL_USERDATA, NativeInt(@NewMemoryManager));

  {$endif}

        {Create the memory mapped file}

        MappingObjectHandle := CreateFileMappingA(INVALID_HANDLE_VALUE, nil,

          PAGE_READWRITE, 0, SizeOf(Pointer), MappingObjectName);

        {Map a view of the memory}

        LPMapAddress := MapViewOfFile(MappingObjectHandle, FILE_MAP_WRITE, 0, 0, 0);

        {Set a pointer to the new memory manager}

        LPMapAddress^ := @NewMemoryManager;

        {Unmap the file}

        UnmapViewOfFile(LPMapAddress);

      end;

{$endif}

      {We will be using this memory manager}

{$ifndef FullDebugMode}

      NewMemoryManager.GetMem := FastGetMem;

      NewMemoryManager.FreeMem := FastFreeMem;

      NewMemoryManager.ReallocMem := FastReallocMem;

{$else}

      NewMemoryManager.GetMem := DebugGetMem;

      NewMemoryManager.FreeMem := DebugFreeMem;

      NewMemoryManager.ReallocMem := DebugReallocMem;

{$endif}

{$ifdef BDS2006AndUp}

  {$ifndef FullDebugMode}

      NewMemoryManager.AllocMem := FastAllocMem;

  {$else}

      NewMemoryManager.AllocMem := DebugAllocMem;

  {$endif}

  {$ifdef EnableMemoryLeakReporting}

      NewMemoryManager.RegisterExpectedMemoryLeak := RegisterExpectedMemoryLeak;

      NewMemoryManager.UnRegisterExpectedMemoryLeak := UnRegisterExpectedMemoryLeak;

  {$else}

      NewMemoryManager.RegisterExpectedMemoryLeak := NoOpRegisterExpectedMemoryLeak;

      NewMemoryManager.UnRegisterExpectedMemoryLeak := NoOpUnRegisterExpectedMemoryLeak;

  {$endif}

{$endif}

      {Owns the memory manager}

      IsMemoryManagerOwner := True;

{$ifdef AttemptToUseSharedMM}

    end

    else

    begin

      {Get the address of the shared memory manager}

  {$ifndef BDS2006AndUp}

    {$ifdef EnableBackwardCompatibleMMSharing}

      if MappingObjectHandle <> 0 then

      begin

    {$endif}

        {Map a view of the memory}

        LPMapAddress := MapViewOfFile(MappingObjectHandle, FILE_MAP_READ, 0, 0, 0);

        {Set the new memory manager}

        NewMemoryManager := PMemoryManager(LPMapAddress^)^;

        {Unmap the file}

        UnmapViewOfFile(LPMapAddress);

    {$ifdef EnableBackwardCompatibleMMSharing}

      end

      else

      begin

        if MMWindow <> 0 then

        begin

          NewMemoryManager := PMemoryManager(GetWindowLong(MMWindow, GWL_USERDATA))^;

        end

        else

        begin

          NewMemoryManager := PMemoryManager(GetWindowLong(MMWindowBE, GWL_USERDATA))^;

        end;

      end;

    {$endif}

  {$else}

    {$ifdef EnableBackwardCompatibleMMSharing}

      if MappingObjectHandle <> 0 then

      begin

    {$endif}

        {Map a view of the memory}

        LPMapAddress := MapViewOfFile(MappingObjectHandle, FILE_MAP_READ, 0, 0, 0);

        {Set the new memory manager}

        NewMemoryManager := PMemoryManagerEx(LPMapAddress^)^;

        {Unmap the file}

        UnmapViewOfFile(LPMapAddress);

    {$ifdef EnableBackwardCompatibleMMSharing}

      end

      else

      begin

        if MMWindow <> 0 then

        begin

          NewMemoryManager := PMemoryManagerEx(GetWindowLong(MMWindow, GWL_USERDATA))^;

        end

        else

        begin

          NewMemoryManager := PMemoryManagerEx(GetWindowLong(MMWindowBE, GWL_USERDATA))^;

        end;

      end;

    {$endif}

  {$endif}

      {Close the file mapping handle}

      CloseHandle(MappingObjectHandle);

      MappingObjectHandle := 0;

      {The memory manager is not owned by this module}

      IsMemoryManagerOwner := False;

    end;

{$endif}

    {Save the old memory manager}

    GetMemoryManager(OldMemoryManager);

    {Replace the memory manager with either this one or the shared one.}

    SetMemoryManager(NewMemoryManager);

    {FastMM is now installed}

    FastMMIsInstalled := True;

{$ifdef UseOutputDebugString}

    if IsMemoryManagerOwner then

      OutputDebugStringA(FastMMInstallMsg)

    else

      OutputDebugStringA(FastMMInstallSharedMsg);

{$endif}

  end;

end;



procedure UninstallMemoryManager;

begin

  {Is this the owner of the shared MM window?}

  if IsMemoryManagerOwner then

  begin

{$ifdef ShareMM}

  {$ifdef EnableBackwardCompatibleMMSharing}

    {Destroy the window}

    if MMWindow <> 0 then

    begin

      DestroyWindow(MMWindow);

      MMWindow := 0;

    end;

    if MMWindowBE <> 0 then

    begin

      DestroyWindow(MMWindowBE);

      MMWindowBE := 0;

    end;

  {$endif}

    {Destroy the memory mapped file handle}

    if MappingObjectHandle <> 0 then

    begin

      CloseHandle(MappingObjectHandle);

      MappingObjectHandle := 0;

    end;

{$endif}

{$ifdef FullDebugMode}

    {Release the reserved block}

    if ReservedBlock <> nil then

    begin

      VirtualFree(ReservedBlock, 0, MEM_RELEASE);

      ReservedBlock := nil;

    end;

{$endif}

  end;

{$ifndef DetectMMOperationsAfterUninstall}

  {Restore the old memory manager}

  SetMemoryManager(OldMemoryManager);

{$else}

  {Set the invalid memory manager: no more MM operations allowed}

  SetMemoryManager(InvalidMemoryManager);

{$endif}

  {Memory manager has been uninstalled}

  FastMMIsInstalled := False;

{$ifdef UseOutputDebugString}

  if IsMemoryManagerOwner then

    OutputDebugStringA(FastMMUninstallMsg)

  else

    OutputDebugStringA(FastMMUninstallSharedMsg);

{$endif}

end;



procedure FinalizeMemoryManager;

begin

  {Restore the old memory manager if FastMM has been installed}

  if FastMMIsInstalled then

  begin

{$ifndef NeverUninstall}

    {Uninstall FastMM}

    UninstallMemoryManager;

{$endif}

    {Do we own the memory manager, or are we just sharing it?}

    if IsMemoryManagerOwner then

    begin

{$ifdef CheckUseOfFreedBlocksOnShutdown}

      CheckBlocksOnShutdown(

  {$ifdef EnableMemoryLeakReporting}

        True

    {$ifdef RequireIDEPresenceForLeakReporting}

        and DelphiIsRunning

    {$endif}

    {$ifdef RequireDebuggerPresenceForLeakReporting}

        and ((DebugHook <> 0)

        {$ifdef PatchBCBTerminate}

        or (Assigned(pCppDebugHook) and (pCppDebugHook^ <> 0))

        {$endif PatchBCBTerminate}

        )

    {$endif}

    {$ifdef ManualLeakReportingControl}

        and ReportMemoryLeaksOnShutdown

    {$endif}

  {$else}

        False

  {$endif}

      );

{$else}

  {$ifdef EnableMemoryLeakReporting}

      if True

    {$ifdef RequireIDEPresenceForLeakReporting}

        and DelphiIsRunning

    {$endif}

    {$ifdef RequireDebuggerPresenceForLeakReporting}

        and ((DebugHook <> 0)

        {$ifdef PatchBCBTerminate}

        or (Assigned(pCppDebugHook) and (pCppDebugHook^ <> 0))

        {$endif PatchBCBTerminate}

        )

    {$endif}

    {$ifdef ManualLeakReportingControl}

        and ReportMemoryLeaksOnShutdown

    {$endif}

      then

        CheckBlocksOnShutdown(True);

  {$endif}

{$endif}

{$ifdef EnableMemoryLeakReporting}

      {Free the expected memory leaks list}

      if ExpectedMemoryLeaks <> nil then

      begin

        VirtualFree(ExpectedMemoryLeaks, 0, MEM_RELEASE);

        ExpectedMemoryLeaks := nil;

      end;

{$endif}

{$ifndef NeverUninstall}

      {Clean up: Free all memory. If this is a .DLL that owns its own MM, then

       it is necessary to prevent the main application from running out of

       address space.}

      FreeAllMemory;

{$endif}

    end;

  end;

end;



procedure RunInitializationCode;

begin

  {Only run this code once during startup.}

  if InitializationCodeHasRun then

    Exit;

  InitializationCodeHasRun := True;

{$ifndef BCB}

  {$ifdef InstallOnlyIfRunningInIDE}

  if (DebugHook <> 0) and DelphiIsRunning then

  {$endif}

  begin

    {Initialize all the lookup tables, etc. for the memory manager}

    InitializeMemoryManager;

    {Has another MM been set, or has the Embarcadero MM been used? If so, this

     file is not the first unit in the uses clause of the project's .dpr

     file.}

    if CheckCanInstallMemoryManager then

    begin

    {$ifdef ClearLogFileOnStartup}

      DeleteEventLog;

    {$endif}

      InstallMemoryManager;

    end;

  end;

{$endif}

end;



initialization

  RunInitializationCode;



finalization

{$ifndef PatchBCBTerminate}

  FinalizeMemoryManager;

{$endif}



end.