Skip to content
Permalink
Branch: master
Find file Copy path
Find file Copy path
4 contributors

Users who have contributed to this file

@gabr42 @jeroenuw @pleriche @ajax16384
13104 lines (12745 sloc) 469 KB
(*
Fast Memory Manager 4.992
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:
https://github.com/pleriche/FastMM4
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 several bugfixes and enhancements.
- 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
Version 4.992 (21 October 2016)
- OS X full debug mode added by Sebastian Zierer
- Included the average block size in the memory state log file. (Thanks to
Hallvard Vassbotn)
- Support added for Free Pascal's OS X and Linux targets, both i386 and
x86-64. (Thanks to Zoë Peterson - some fixes by Arnaud Bouchez)
- Added the LogLockContention option which may be used to track down areas
in the application that lead to frequent lock contentions in the memory
manager. (Primoz Gabrijelcic)
- Support for release stacks added by Primoz Gabrijelcic. Define
"UseReleaseStack" to use this new feature: If a block cannot be released
immediately during a FreeMem call the block will added to a list of blocks
that will be freed later, either in the background cleanup thread or during
the next call to FreeMem.
Version 4.??? (unreleased)
- Added some "address space slack" under FullDebugMode. This reserves a
block of address space on startup (currently 5MB) that is released just
before the first time an EOutOfMemory exception is raised, allowing some
GetMem calls following the initial EOutOfMemory to succeed. This allows
the application to perform any error logging and other shutdown operations
successfully that would have failed it the address space was actually
completely exhausted. (Under FullDebugMode address space is never released
back to the operating system so once the address space has been exhausted
there is very little room to manoeuvre.)
*)
unit FastMM4;
interface
{$Include FastMM4Options.inc}
{$RANGECHECKS OFF}
{$BOOLEVAL OFF}
{$OVERFLOWCHECKS OFF}
{$OPTIMIZATION ON}
{$TYPEDADDRESS OFF}
{$LONGSTRINGS ON}
{Compiler version defines}
{$ifndef fpc}
{$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}
{$else}
{$mode delphi}
{$ifdef CPUX64}
{$asmmode intel}
{$define 64bit}
{$define fpc64bit}
{$undef 32bit}
{$else}
{$define 32bit}
{$undef 64bit}
{$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}
{Lock contention logging requires ~ASMVersion.}
{$ifdef LogLockContention}
{$undef ASMVersion}
{$endif}
{Release stack requires ~ASMVersion (for now).}
{$ifdef UseReleaseStack}
{$undef ASMVersion}
{$ifdef FullDebugMode}
{$message error 'UseReleaseStack is not compatible with FullDebugMode'}
{$endif}
{$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}
{$ifdef 64Bit}
{$define PIC} // Linux 64bit ASM is PIC
{$endif}
{$ifndef FPC}
{$define KYLIX}
{$endif}
{$endif}
{$ifdef DARWIN}
{$define POSIX}
{$define PIC}
{$endif}
{Some features not currently supported under Kylix / OS X}
{$ifdef POSIX}
{$ifndef MACOS}
{$undef FullDebugMode}
{$undef LogErrorsToFile}
{$undef LogMemoryLeakDetailToFile}
{$endif}
{$undef ShareMM}
{$undef AttemptToUseSharedMM}
{$undef RequireIDEPresenceForLeakReporting}
{$undef UseOutputDebugString}
{$ifdef PIC}
{BASM version does not support position independent code}
{$undef ASMVersion}
{$endif}
{$ifndef FPC}
{$define MACOS_OR_KYLIX}
{$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}
{Stack tracer is needed for LogLockContention and for FullDebugMode.}
{$undef _StackTracer}
{$undef _EventLog}
{$ifdef FullDebugMode}{$define _StackTracer}{$define _EventLog}{$endif}
{$ifdef LogLockContention}{$define _StackTracer}{$define _EventLog}{$endif}
{$ifdef UseReleaseStack}{$ifdef DebugReleaseStack}{$define _EventLog}{$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}
{$ifndef fpc}
PByte = PAnsiChar;
NativeInt = Integer;
NativeUInt = Cardinal;
PNativeUInt = ^Cardinal;
IntPtr = Integer;
UIntPtr = Cardinal;
{$else}
NativeUInt = PtrUInt;
PNativeUInt = ^PtrUInt;
{$endif}
{$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}{$ifdef fpc}NativeUInt{$else}Integer{$endif}{$endif}): Pointer;
function FastFreeMem(APointer: Pointer): {$ifdef fpc}NativeUInt{$else}Integer{$endif};
function FastReallocMem({$ifdef fpc}var {$endif}APointer: Pointer; ANewSize: {$ifdef XE2AndUp}NativeInt{$else}{$ifdef fpc}NativeUInt{$else}Integer{$endif}{$endif}): Pointer;
function FastAllocMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}{$ifdef fpc}NativeUInt{$else}Cardinal{$endif}{$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;
{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}
{$ifdef _EventLog}
{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);
{$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 manager 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 UseReleaseStack}
{$ifdef DebugReleaseStack}
procedure LogReleaseStackUsage;
{$endif}
{$endif}
{$ifdef _StackTracer}
{------------- FullDebugMode/LogLockContention constants---------------}
const
{The stack trace depth. (Must be an *uneven* number to ensure that the
Align16Bytes option works in FullDebugMode.)}
StackTraceDepth = 11;
type
PStackTrace = ^TStackTrace;
TStackTrace = array[0..StackTraceDepth - 1] of NativeUInt;
{$endif}
{$ifdef FullDebugMode}
{-------------FullDebugMode constants---------------}
const
{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); // Default value $80808080
{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); // Default value $80800000
{$else}
DebugFillPattern = $8080808080808080;
{$endif}
{The number of bytes of address space that cannot be allocated under FullDebugMode. This block is reserved on
startup and freed the first time the system runs out of address space. This allows some subsequent memory allocation
requests to succeed in order to allow the application to allocate some memory for error handling, etc. in response to
the first EOutOfMemory exception.}
FullDebugModeAddressSpaceSlack = 5 * 1024 * 1024;
{-------------------------FullDebugMode structures--------------------}
type
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 _EventLog}
{$ifdef Delphi4or5}
ShlObj,
{$else}
SHFolder,
{$endif}
{$endif}
{$else}
{$ifdef MACOS}
Posix.Stdlib, Posix.Unistd, Posix.Fcntl, Posix.PThread, FastMM_OSXUtil,
{$ELSE}
{$ifdef fpc}
BaseUnix,
{$else}
Libc,
{$endif}
{$endif}
{$endif}
{$ifdef LogLockContention}
FastMM4DataCollector,
{$endif}
{$ifdef UseReleaseStack}
FastMM4LockFreeStack,
{$endif}
FastMM4Messages;
{$ifdef fpc}
const
clib = 'c';
function valloc(__size:size_t):pointer;cdecl;external clib name 'valloc';
procedure free(__ptr:pointer);cdecl;external clib name 'free';
function usleep(__useconds:dword):longint;cdecl;external clib name 'usleep';
{$endif}
{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): {$ifdef fpc}NativeUInt{$else}Integer{$endif}; forward;
function InvalidGetMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}{$ifdef fpc}NativeUInt{$else}Integer{$endif}{$endif}): Pointer; forward;
function InvalidReallocMem({$ifdef fpc}var {$endif}APointer: Pointer; ANewSize: {$ifdef XE2AndUp}NativeInt{$else}{$ifdef fpc}NativeUInt{$else}Integer{$endif}{$endif}): Pointer; forward;
function InvalidAllocMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}{$ifdef fpc}NativeUint{$else}Cardinal{$endif}{$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.}
{$endif}
{$ifdef UseReleaseStack}
ReleaseStackSize = 16;
NumStacksPerBlock = 64; //should be power of 2
{$endif}
{$ifdef _StackTracer}
{$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}
{$ifdef UseReleaseStack}
ReleaseStack: array [0..NumStacksPerBlock - 1] of TLFStack;
{$endif}
{$ifdef LogLockContention}
BlockCollector: TStaticCollector;
{$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}
{---------------------EventLog-------------------}
{$ifdef _EventLog}
{The current log file name}
MMLogFileName: array[0..1023] of AnsiChar;
{$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 64K block of reserved memory used to trap invalid memory accesses using
fields in a freed object.}
ReservedBlock: Pointer;
{Points to a block of size FullDebugModeAddressSpaceSlack that is freed the first time the system runs out of memory.
Memory is never release under FullDebugMode, so this allows the application to continue to function for a short while
after the first EOutOfMemory exception.}
AddressSpaceSlackPtr: 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}
{---------------------Lock contention logging--------------------}
{$ifdef LogLockContention}
MediumBlockCollector: TStaticCollector;
LargeBlockCollector: TStaticCollector;
{$endif}
{---------------------Release stack------------------------}
{$ifdef UseReleaseStack}
MediumReleaseStack: array [0..NumStacksPerBlock - 1] of TLFStack;
LargeReleaseStack: array [0..NumStacksPerBlock - 1] of TLFStack;
ReleaseStackCleanupThread: THandle = 0;
ReleaseStackCleanupThreadTerminate: THandle = 0;
{$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; {$ifdef fpc64bit}assembler; nostackframe;{$endif}
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}
{$ifndef unix}
.noframe
mov rax, rcx
lock cmpxchg [r8], dl
{$else}
mov rax, rdi
lock cmpxchg [rdx], sil
{$endif}
{$endif}
end;
{$ifndef ASMVersion}
{Gets the first set bit in the 32-bit number, returning the bit index}
function FindFirstSetBit(ACardinal: Cardinal): Cardinal; {$ifdef fpc64bit} assembler; nostackframe; {$endif}
asm
{$ifdef 64Bit}
{$ifndef unix}
.noframe
mov rax, rcx
{$else}
mov rax, rdi
{$endif}
{$endif}
bsf eax, eax
end;
{$endif}
{$ifdef MACOS_OR_KYLIX}
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, PAnsiChar(CUnknown), Result + 1);
end;
end;
const
INVALID_HANDLE_VALUE = THandle(-1);
function FileCreate(const FileName: string): THandle;
begin
Result := THandle({$ifdef MACOS}__open{$else}open{$endif}(
PAnsiChar(UTF8String(FileName)), O_RDWR or O_CREAT or O_TRUNC or O_EXCL, FileAccessRights));
end;
{$endif}
{$ifdef FPC}
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
Result := Length(CUnknown);
StrLCopy(Buffer, PAnsiChar(CUnknown), Result + 1);
end;
const
INVALID_HANDLE_VALUE = THandle(-1);
FileAcc = (S_IRUSR or S_IWUSR or S_IRGRP or S_IWGRP or S_IROTH or S_IWOTH);
function FileCreate(const FileName: string): THandle;
begin
Result := THandle(fpopen(PAnsiChar(UTF8String(FileName)), O_RDWR or O_CREAT or O_TRUNC or O_EXCL, FileAcc));
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); {$ifdef fpc64bit} assembler; nostackframe; {$endif}
asm
{$ifdef 32Bit}
mov eax, [eax]
mov [edx], eax
{$else}
{$ifndef unix}
.noframe
mov eax, [rcx]
mov [rdx], eax
{$else}
mov eax, [rdi]
mov [rsi], eax
{$endif}
{$endif}
end;
{$ifdef 64Bit}
procedure Move8(const ASource; var ADest; ACount: NativeInt); {$ifdef fpc64bit} assembler; nostackframe; {$endif}
asm
{$ifndef unix}
.noframe
mov rax, [rcx]
mov [rdx], rax
{$else}
mov rax, [rdi]
mov [rsi], rax
{$endif}
end;
{$endif}
procedure Move12(const ASource; var ADest; ACount: NativeInt); {$ifdef fpc64bit} assembler; nostackframe; {$endif}
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}
{$ifndef unix}
.noframe
mov rax, [rcx]
mov ecx, [rcx + 8]
mov [rdx], rax
mov [rdx + 8], ecx
{$else}
mov rax, [rdi]
mov edi, [rdi + 8]
mov [rsi], rax
mov [rsi + 8], edi
{$endif}
{$endif}
end;
procedure Move20(const ASource; var ADest; ACount: NativeInt); {$ifdef fpc64bit} assembler; nostackframe; {$endif}
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}
{$ifndef unix}
.noframe
movdqa xmm0, [rcx]
mov ecx, [rcx + 16]
movdqa [rdx], xmm0
mov [rdx + 16], ecx
{$else}
movdqa xmm0, [rdi]
mov edi, [rdi + 16]
movdqa [rsi], xmm0
mov [rsi + 16], edi
{$endif}
{$endif}
end;
{$ifdef 64Bit}
procedure Move24(const ASource; var ADest; ACount: NativeInt); {$ifdef fpc64bit} assembler; nostackframe; {$endif}
asm
{$ifndef unix}
.noframe
movdqa xmm0, [rcx]
mov r8, [rcx + 16]
movdqa [rdx], xmm0
mov [rdx + 16], r8
{$else}
movdqa xmm0, [rdi]
mov rdx, [rdi + 16]
movdqa [rsi], xmm0
mov [rsi + 16], rdx
{$endif}
end;
{$endif}
procedure Move28(const ASource; var ADest; ACount: NativeInt); {$ifdef fpc64bit} assembler; nostackframe; {$endif}
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}
{$ifndef unix}
.noframe
movdqa xmm0, [rcx]
mov r8, [rcx + 16]
mov ecx, [rcx + 24]
movdqa [rdx], xmm0
mov [rdx + 16], r8
mov [rdx + 24], ecx
{$else}
movdqa xmm0, [rdi]
mov rdx, [rdi + 16]
mov edi, [rdi + 24]
movdqa [rsi], xmm0
mov [rsi + 16], rdx
mov [rsi + 24], edi
{$endif}
{$endif}
end;
procedure Move36(const ASource; var ADest; ACount: NativeInt); {$ifdef fpc64bit} assembler; nostackframe; {$endif}
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}
{$ifndef unix}
.noframe
movdqa xmm0, [rcx]
movdqa xmm1, [rcx + 16]
mov ecx, [rcx + 32]
movdqa [rdx], xmm0
movdqa [rdx + 16], xmm1
mov [rdx + 32], ecx
{$else}
movdqa xmm0, [rdi]
movdqa xmm1, [rdi + 16]
mov edi, [rdi + 32]
movdqa [rsi], xmm0
movdqa [rsi + 16], xmm1
mov [rsi + 32], edi
{$endif}
{$endif}
end;
{$ifdef 64Bit}
procedure Move40(const ASource; var ADest; ACount: NativeInt); {$ifdef fpc64bit} assembler; nostackframe; {$endif}
asm
{$ifndef unix}
.noframe
movdqa xmm0, [rcx]
movdqa xmm1, [rcx + 16]
mov r8, [rcx + 32]
movdqa [rdx], xmm0
movdqa [rdx + 16], xmm1
mov [rdx + 32], r8
{$else}
movdqa xmm0, [rdi]
movdqa xmm1, [rdi + 16]
mov rdx, [rdi + 32]
movdqa [rsi], xmm0
movdqa [rsi + 16], xmm1
mov [rsi + 32], rdx
{$endif}
end;
{$endif}
procedure Move44(const ASource; var ADest; ACount: NativeInt); {$ifdef fpc64bit} assembler; nostackframe; {$endif}
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}
{$ifndef unix}
.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
{$else}
movdqa xmm0, [rdi]
movdqa xmm1, [rdi + 16]
mov rdx, [rdi + 32]
mov edi, [rdi + 40]
movdqa [rsi], xmm0
movdqa [rsi + 16], xmm1
mov [rsi + 32], rdx
mov [rsi + 40], edi
{$endif}
{$endif}
end;
procedure Move52(const ASource; var ADest; ACount: NativeInt); {$ifdef fpc64bit} assembler; nostackframe; {$endif}
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}
{$ifndef unix}
.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
{$else}
movdqa xmm0, [rdi]
movdqa xmm1, [rdi + 16]
movdqa xmm2, [rdi + 32]
mov edi, [rdi + 48]
movdqa [rsi], xmm0
movdqa [rsi + 16], xmm1
movdqa [rsi + 32], xmm2
mov [rsi + 48], edi
{$endif}
{$endif}
end;
{$ifdef 64Bit}
procedure Move56(const ASource; var ADest; ACount: NativeInt); {$ifdef fpc64bit} assembler; nostackframe; {$endif}
asm
{$ifndef unix}
.noframe
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
{$else}
movdqa xmm0, [rdi]
movdqa xmm1, [rdi + 16]
movdqa xmm2, [rdi + 32]
mov rdx, [rdi + 48]
movdqa [rsi], xmm0
movdqa [rsi + 16], xmm1
movdqa [rsi + 32], xmm2
mov [rsi + 48], rdx
{$endif}
end;
{$endif}
procedure Move60(const ASource; var ADest; ACount: NativeInt); {$ifdef fpc64bit} assembler; nostackframe; {$endif}
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}
{$ifndef unix}
.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
{$else}
movdqa xmm0, [rdi]
movdqa xmm1, [rdi + 16]
movdqa xmm2, [rdi + 32]
mov rdx, [rdi + 48]
mov edi, [rdi + 56]
movdqa [rsi], xmm0
movdqa [rsi + 16], xmm1
movdqa [rsi + 32], xmm2
mov [rsi + 48], rdx
mov [rsi + 56], edi
{$endif}
{$endif}
end;
procedure Move68(const ASource; var ADest; ACount: NativeInt); {$ifdef fpc64bit} assembler; nostackframe; {$endif}
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}
{$ifndef unix}
.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
{$else}
movdqa xmm0, [rdi]
movdqa xmm1, [rdi + 16]
movdqa xmm2, [rdi + 32]
movdqa xmm3, [rdi + 48]
mov edi, [rdi + 64]
movdqa [rsi], xmm0
movdqa [rsi + 16], xmm1
movdqa [rsi + 32], xmm2
movdqa [rsi + 48], xmm3
mov [rsi + 64], edi
{$endif}
{$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); {$ifdef fpc64bit} assembler; nostackframe; {$endif}
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}
{$ifndef unix}
.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
{$else}
{Make the counter negative based: The last 8 bytes are moved separately}
sub rdx, 8
add rdi, rdx
add rsi, rdx
neg rdx
jns @MoveLast12
@MoveLoop:
{Move a 16 byte block}
movdqa xmm0, [rdi + rdx]
movdqa [rsi + rdx], xmm0
{Are there another 16 bytes to move?}
add rdx, 16
js @MoveLoop
@MoveLast12:
{Do the last 8 bytes}
mov rcx, [rdi + rdx]
mov [rsi + rdx], rcx
{$endif}
{$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); {$ifdef fpc64bit} assembler; nostackframe; {$endif}
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}
{$ifndef unix}
.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
{$else}
{Make the counter negative based}
add rdi, rdx
add rsi, rdx
neg rdx
@MoveLoop:
{Move an 8 byte block}
mov rcx, [rdi + rdx]
mov [rsi + rdx], rcx
{Are there another 8 bytes to move?}
add rdx, 8
js @MoveLoop
{$Endif}
{$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
{$ifndef fpc}
__write(STDERR_FILENO, AMessageText, StrLen(AMessageText));
{$else}
FpWrite(StdErrorHandle, AMessageText, StrLen(AMessageText));
{$endif}
end;
{$IFNDEF MACOS}
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;
{$ENDIF}
function WriteFile(hFile: THandle; const Buffer; nNumberOfBytesToWrite: Cardinal;
var lpNumberOfBytesWritten: Cardinal; lpOverlapped: Pointer): Boolean; stdcall;
begin
{$ifndef fpc}
lpNumberOfBytesWritten := __write(hFile, {$ifdef MACOS}@Buffer{$else}Buffer{$endif},
nNumberOfBytesToWrite);
{$else}
lpNumberOfBytesWritten := fpwrite(hFile, Buffer, nNumberOfBytesToWrite);
{$endif}
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 WIN32}
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); {$ifdef fpc64bit} assembler; nostackframe; {$endif}
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}
{$ifndef unix}
.noframe
{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:
{$else}
{On Entry:
rdi = AAddress
rsi = AByteCount
rdx = AFillValue}
add rdi, rsi
neg rsi
jns @Done
@FillLoop:
mov [rdi + rsi], rdx
add rsi, 8
js @FillLoop
@Done:
{$endif}
{$endif}
end;
{$endif}
{$ifdef _StackTracer}
{------------------------Stack tracer---------------------------}
{$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}
{$ifdef UseReleaseStack }
function GetStackSlot: DWORD;
begin
// http://burtleburtle.net/bob/hash/integer.html
Result := GetCurrentThreadID;
Result := (Result xor 61) xor (Result shr 16);
Result := Result + (Result shl 3);
Result := Result xor (Result shr 4);
Result := Result * $27d4eb2d;
Result := Result xor (Result shr 15);
Result := Result and (NumStacksPerBlock - 1);
end;
{$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;
{$ifdef EnableMemoryLeakReportingUsesQualifiedClassName}
type
PClassData = ^TClassData;
TClassData = record
ClassType: TClass;
ParentInfo: Pointer;
PropCount: SmallInt;
UnitName: ShortString;
end;
{$endif EnableMemoryLeakReportingUsesQualifiedClassName}
{Appends the name of the class to the destination buffer and returns the new
destination position}
function AppendClassNameToBuffer(AClass: TClass; ADestination: PAnsiChar): PAnsiChar;
var
{$ifdef EnableMemoryLeakReportingUsesQualifiedClassName}
FirstUnitNameChar: PAnsiChar;
LClassInfo: Pointer;
UnitName: PShortString;
{$endif EnableMemoryLeakReportingUsesQualifiedClassName}
LPClassName: PShortString;
begin
{Get a pointer to the class name}
if AClass <> nil then
begin
Result := ADestination;
{$ifdef EnableMemoryLeakReportingUsesQualifiedClassName}
// based on TObject.UnitScope
LClassInfo := AClass.ClassInfo;
if LClassInfo <> nil then // prepend the UnitName
begin
UnitName := @PClassData(PByte(LClassInfo) + 2 + PByte(PByte(LClassInfo) + 1)^).UnitName;
FirstUnitNameChar := @UnitName^[1];
if FirstUnitNameChar^ <> '@' then
Result := AppendStringToBuffer(FirstUnitNameChar, Result, Length(UnitName^))
else // Pos does no memory allocations, so it is safe to use
begin // Skip the '@', then copy until the ':' - never seen this happen in Delphi, but might be a C++ thing
Result := AppendStringToBuffer(@UnitName^[2], Result, Pos(ShortString(':'), UnitName^) - 2)
;
end;
// dot between unit name and class name:
Result := AppendStringToBuffer('.', Result, Length('.'));
end;
{$endif EnableMemoryLeakReportingUsesQualifiedClassName}
LPClassName := PShortString(PPointer(PByte(AClass) + vmtClassName)^);
{Append the class name}
Result := AppendStringToBuffer(@LPClassName^[1], Result, 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