(*
Fast Memory Manager 4.64
Description:
A fast replacement memory manager for Borland Delphi Win32 applications that
scales well under multi-threaded usage, is not prone to memory fragmentation,
and supports shared memory without the use of external .DLL files.
Homepage:
http://fastmm.sourceforge.net
Advantages:
- Fast
- Low overhead. FastMM is designed for an average of 5% and maximum of 10%
overhead per block.
- Supports up to 3GB of user mode address space under Windows 32-bit and 4GB
under Windows 64-bit. Add the "$SetPEFlags $20" option (in curly braces)
to your .dpr to enable this.
- Highly aligned memory blocks. Can be configured for either 8-byte or 16-byte
alignment.
- Good scaling under multi-threaded applications
- Intelligent reallocations. Avoids slow memory move operations through
not performing unneccesary downsizes and by having a minimum percentage
block size growth factor when an in-place block upsize is not possible.
- Resistant to address space fragmentation
- No external DLL required when sharing memory between the application and
external libraries (provided both use this memory manager)
- Optionally reports memory leaks on program shutdown. (This check can be set
to be performed only if Delphi is currently running on the machine, so end
users won't be bothered by the error message.)
- Supports Delphi 4 (or later), C++ Builder 5 (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 7
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
Borland 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.
- Dennis Christensen for his tireless efforts with the Fastcode project:
helping to develop, optimize and debug the growing Fastcode library.
- Pierre Y. for his suggestions regarding the extension of the memory leak
checking options.
- Anders Isaksson and Greg for finding and identifying the "DelphiIsRunning"
bug under Delphi 5.
- Francois Malan for finding the bug that caused compilation to fail when
both the "AssumeMultiThreaded" and "CheckHeapForCorruption" options were set.
- 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.
- Hanspeter Widmer for his suggestion to have an option to display install and
uninstall debug messages and moving options to a separate file.
- 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.
- 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.
- JRG ("The Delphi Guy") for the Spanish translation.
- Justus Janssen for Delphi 4 support.
- Vadim Lopushansky and Charles Vinal for reporting the Delphi 5 compile 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.
- 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.)
- 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 MoveX16L4 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.)
*)
unit FastMM4;
interface
{$Include FastMM4Options.inc}
{$RANGECHECKS OFF}
{$BOOLEVAL OFF}
{$OVERFLOWCHECKS OFF}
{$OPTIMIZATION ON}
{$TYPEDADDRESS OFF}
{Some features not currently supported under Kylix}
{$ifdef Linux}
{$undef LogErrorsToFile}
{$undef LogMemoryLeakDetailToFile}
{$undef ShareMM}
{$undef AttemptToUseSharedMM}
{$undef RequireIDEPresenceForLeakReporting}
{$undef UseOutputDebugString}
{$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}
{$endif}
{Only the pascal version supports extended heap corruption checking.}
{$ifdef CheckHeapForCorruption}
{$undef ASMVersion}
{$endif}
{$ifdef UseRuntimePackages}
{$define AssumeMultiThreaded}
{$endif}
{Delphi versions}
{$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}
{Cannot uninstall safely under BCB}
{$define NeverUninstall}
{Disable memory leak reporting}
{$undef EnableMemoryLeakReporting}
{for BCB5, use the Delphi 5 codepath}
{$ifdef ver130}
{$define Delphi4or5}
{$endif}
{$endif}
{$ifdef ver180}
{$define BDS2006}
{$endif}
{$ifndef Delphi4or5}
{$ifndef BCB}
{$define Delphi6AndUp}
{$endif}
{$ifndef Delphi6}
{$define BCB6OrDelphi7AndUp}
{$ifndef BCB}
{$define Delphi7AndUp}
{$endif}
{$ifndef BCB}
{$ifndef Delphi7}
{$ifndef Delphi2005}
{$define BDS2006AndUp}
{$endif}
{$endif}
{$endif}
{$endif}
{$endif}
{$ifdef Delphi6AndUp}
{$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}
{-------------------------Public constants-----------------------------}
const
{The number of small block types}
{$ifdef Align16Bytes}
NumSmallBlockTypes = 46;
{$else}
NumSmallBlockTypes = 55;
{$endif}
{----------------------------Public types------------------------------}
type
TSmallBlockTypeState = packed 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: Cardinal;
{The total address space reserved for this block type (both allocated and
free blocks)}
ReservedAddressSpace: Cardinal;
end;
TSmallBlockTypeStates = array[0..NumSmallBlockTypes - 1] of TSmallBlockTypeState;
TMemoryManagerState = packed record
{Small block type states}
SmallBlockTypeStates: TSmallBlockTypeStates;
{Medium block stats}
AllocatedMediumBlockCount: Cardinal;
TotalAllocatedMediumBlockSize: Cardinal;
ReservedMediumBlockAddressSpace: Cardinal;
{Large block stats}
AllocatedLargeBlockCount: Cardinal;
TotalAllocatedLargeBlockSize: Cardinal;
ReservedLargeBlockAddressSpace: Cardinal;
end;
{Memory map}
TChunkStatus = (csUnallocated, csAllocated, csReserved,
csSysAllocated, csSysReserved);
TMemoryMap = array[0..65535] of TChunkStatus;
{$ifdef EnableMemoryLeakReporting}
{List of registered leaks}
TRegisteredMemoryLeak = packed record
LeakAddress: Pointer;
LeakedClass: TClass;
LeakSize: Integer;
LeakCount: Integer;
end;
TRegisteredMemoryLeaks = array of TRegisteredMemoryLeak;
{$endif}
{--------------------------Public variables----------------------------}
{$ifdef ManualLeakReportingControl}
{Variable is declared in system.pas in newer Delphi versions.}
{$ifndef BDS2006AndUp}
var
ReportMemoryLeaksOnShutdown: Boolean;
{$endif}
{$endif}
{-------------------------Public procedures----------------------------}
{Installation procedures must be exposed for the BCB helper unit FastMM4BCB.cpp}
{$ifdef BCB}
procedure InitializeMemoryManager;
function CheckCanInstallMemoryManager: boolean;
procedure InstallMemoryManager;
{$endif}
{$ifndef FullDebugMode}
{The standard memory manager functions}
function FastGetMem(ASize: Integer): Pointer;
function FastFreeMem(APointer: Pointer): Integer;
function FastReallocMem(APointer: Pointer; ANewSize: Integer): Pointer;
function FastAllocMem(ASize: Cardinal): Pointer;
{$else}
{The FullDebugMode memory manager functions}
function DebugGetMem(ASize: Integer): Pointer;
function DebugFreeMem(APointer: Pointer): Integer;
function DebugReallocMem(APointer: Pointer; ANewSize: Integer): Pointer;
function DebugAllocMem(ASize: Cardinal): Pointer;
{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: PChar = nil);
{Returns the current "allocation group". Whenever a GetMem request is serviced
in FullDebugMode, the current "allocation group" is stored in the block header.
This may help with debugging. Note that if a block is subsequently reallocated
that it keeps its original "allocation group" and "allocation number" (all
allocations are also numbered sequentially).}
function GetCurrentAllocationGroup: Cardinal;
{Allocation groups work in a stack like fashion. Group numbers are pushed onto
and popped off the stack. Note that the stack size is limited, so every push
should have a matching pop.}
procedure PushAllocationGroup(ANewCurrentAllocationGroup: Cardinal);
procedure PopAllocationGroup;
{Logs detail about currently allocated memory blocks for the specified range of
allocation groups. if ALastAllocationGroupToLog is less than
AFirstAllocationGroupToLog or it is zero, then all allocation groups are
logged. This routine also checks the memory pool for consistency at the same
time.}
procedure LogAllocatedBlocksToFile(AFirstAllocationGroupToLog, ALastAllocationGroupToLog: Cardinal);
{$endif}
{Releases all allocated memory (use with extreme care)}
procedure FreeAllMemory;
{Returns summarised information about the state of the memory manager. (For
backward compatibility.)}
function FastGetHeapStatus: THeapStatus;
{Returns statistics about the current state of the memory manager}
procedure GetMemoryManagerState(var AMemoryManagerState: TMemoryManagerState);
{$ifndef LINUX}
{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: Integer; ACount: Integer = 1): boolean; overload;
{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: Integer; ACount: Integer = 1): boolean; overload;
{Returns a list of all expected memory leaks}
function GetRegisteredMemoryLeaks: TRegisteredMemoryLeaks;
{$endif}
implementation
uses
{$ifndef Linux}
Windows,
{$else}
Libc,
{$endif}
FastMM4Messages;
{Fixed size move procedures}
procedure Move12(const ASource; var ADest; ACount: Integer); forward;
procedure Move20(const ASource; var ADest; ACount: Integer); forward;
procedure Move28(const ASource; var ADest; ACount: Integer); forward;
procedure Move36(const ASource; var ADest; ACount: Integer); forward;
procedure Move44(const ASource; var ADest; ACount: Integer); forward;
procedure Move52(const ASource; var ADest; ACount: Integer); forward;
procedure Move60(const ASource; var ADest; ACount: Integer); forward;
procedure Move68(const ASource; var ADest; ACount: Integer); forward;
{$ifdef DetectMMOperationsAfterUninstall}
{Invalid handlers to catch MM operations after uninstall}
function InvalidFreeMem(APointer: Pointer): Integer; forward;
function InvalidGetMem(ASize: Integer): Pointer; forward;
function InvalidReallocMem(APointer: Pointer; ANewSize: Integer): Pointer; forward;
function InvalidAllocMem(ASize: Cardinal): 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 (MoveX16L4). 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;
{-------------FullDebugMode constants---------------}
{$ifdef FullDebugMode}
{The stack trace depth}
StackTraceDepth = 9;
{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;
DebugFillDWord = $01010101 * Cardinal(DebugFillByte);
{The address that is reserved so that accesses to the address of the fill
pattern will result in an A/V}
DebugReservedAddress = $01010000 * Cardinal(DebugFillByte);
{$endif}
{-------------Other constants---------------}
{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 = 10;
{Hexadecimal characters}
HexTable: array[0..15] of char = '0123456789ABCDEF';
{Copyright message - not used anywhere in the code}
Copyright: string = 'FastMM4 � 2004, 2005, 2006 Pierre le Riche / Professional Software Development';
{-------------------------Private types----------------------------}
type
{$ifdef Delphi4or5}
{Delphi 5 Compatibility}
PCardinal = ^Cardinal;
PPointer = ^Pointer;
{$endif}
{Move procedure type}
TMoveProc = procedure(const ASource; var ADest; ACount: Integer);
{Registers structure (for GetCPUID)}
TRegisters = record
RegEAX, RegEBX, RegECX, RegEDX: 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)}
PSmallBlockType = ^TSmallBlockType;
TSmallBlockType = packed 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 first partially free pool for the given small block type (offset = +4
for typecast compatibility with TSmallBlockPoolHeader). This is a circular
buffer.}
NextPartiallyFreePool: PSmallBlockPoolHeader;
{The offset of the last block that was served sequentially (0ffset = +8 to
to be at the same offset as the "FirstFreeBlock" of TSmallBlockPoolHeader}
NextSequentialFeedBlockAddress: Pointer;
{The last block that can be served sequentially. Offset is at +12 to be
at the same address as the "BlocksInUse" field of TSmallBlockPoolHeader}
MaxSequentialFeedBlockAddress: Pointer;
{The pool that is current being used to serve blocks in sequential order}
CurrentSequentialFeedPool: PSmallBlockPoolHeader;
{The previous partially free pool for the small block type (offset = +20
for typecast compatibility with TSmallBlockPoolHeader)}
PreviousPartiallyFreePool: PSmallBlockPoolHeader;
{The minimum and optimal size of a small block pool for this block type}
MinimumBlockPoolSize: Word;
OptimalBlockPoolSize: Word;
{$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: Cardinal;
{$endif}
end;
{Small block pool (Size = 32 bytes)}
TSmallBlockPoolHeader = packed record
{BlockType}
BlockType: PSmallBlockType;
{The next pool that has free blocks of this size. Must be at offset +4
to be typecast compatible with TSmallBlockType}
NextPartiallyFreePool: PSmallBlockPoolHeader;
{Pointer to the first free block inside this pool. Must be at offset + 8
to be at the same offset as "NextSequentialFeedBlockAddress" of
TSmallBlockType}
FirstFreeBlock: Pointer;
{The number of blocks allocated in this pool. Must be at offset + 12
to be at the same offset as "MaxSequentialFeedBlockAddress" of
TSmallBlockType}
BlocksInUse: Cardinal;
{Reserved}
Reserved1: Cardinal;
{The previous pool that has free blocks of this size. Must be at offset +20
to be compatible with TSmallBlockType}
PreviousPartiallyFreePool: PSmallBlockPoolHeader;
{Reserved}
Reserved2: Cardinal;
{The pool pointer and flags of the first block}
FirstBlockPoolPointerAndFlags: Cardinal;
end;
{Small block layout:
Offset: -4 = Flags + address of the small block pool
Offset: BlockSize - 4 = 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}
PMediumBlockPoolHeader = ^TMediumBlockPoolHeader;
TMediumBlockPoolHeader = packed 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;
{Unused dword}
Reserved: Cardinal;
{The block size and flags of the first medium block in the block pool}
FirstMediumBlockSizeAndFlags: Cardinal;
end;
{Medium block layout:
Offset: -8 = Previous Block Size (only if the previous block is free)
Offset: -4 = This block size and flags
Offset: 0 = User data / Previous Free Block (if this block is free)
Offset: 4 = Next Free Block (if this block is free)
Offset: BlockSize - 8 = Size of this block (if this block is free)
Offset: BlockSize - 4 = Size of the next block and flags
{A medium block that is unused}
PMediumFreeBlock = ^TMediumFreeBlock;
TMediumFreeBlock = packed record
PreviousFreeBlock: PMediumFreeBlock;
NextFreeBlock: PMediumFreeBlock;
end;
{-------------------------Large block structures--------------------}
{Large block header record (size = 16)}
PLargeBlockHeader = ^TLargeBlockHeader;
TLargeBlockHeader = packed 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: Cardinal;
{The size of this block plus the flags}
BlockSizeAndFlags: Cardinal;
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 = packed record
{Linked list pointers}
PreviousLeak, NextLeak: PExpectedMemoryLeak;
{Information about the expected leak}
LeakAddress: Pointer;
LeakedClass: TClass;
LeakSize: Integer;
LeakCount: Integer;
end;
TExpectedMemoryLeaks = packed 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}
ExpectedLeaks: packed array[0..(ExpectedMemoryLeaksListSize - 20) div SizeOf(TExpectedMemoryLeak) - 1] of TExpectedMemoryLeak;
end;
PExpectedMemoryLeaks = ^TExpectedMemoryLeaks;
{$endif}
{-------------------------Full Debug Mode Structures--------------------}
{$ifdef FullDebugMode}
PStackTrace = ^TStackTrace;
TStackTrace = array[0..StackTraceDepth - 1] of Cardinal;
TBlockOperation = (boBlockCheck, boGetMem, boFreeMem, boReallocMem);
PFullDebugBlockHeader = ^TFullDebugBlockHeader;
TFullDebugBlockHeader = packed record
{Space used by the medium block manager for previous/next block management.
If a medium block is binned then these two dwords will be modified.}
Reserved1: Cardinal;
Reserved2: Cardinal;
{Is the block currently allocated?}
BlockInUse: LongBool;
{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 4GB it wraps
back to 0.}
AllocationNumber: Cardinal;
{The call stack when the block was allocated}
AllocationStackTrace: TStackTrace;
{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: Cardinal;
{The object class this block was used for the previous time it was
allocated. When a block is freed, the dword 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: Cardinal;
{The sum of all the dwords excluding reserved dwords.}
HeaderCheckSum: Cardinal;
end;
{The last four bytes of the actual allocated block is the inverse of the
header checksum}
{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;
{$endif}
{-------------------------Private constants----------------------------}
const
{$ifndef BCB6OrDelphi7AndUp}
reInvalidPtr = 2;
{$endif}
{The size of the block header in front of small and medium blocks}
BlockHeaderSize = 4;
{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. 4 bytes for the trailer and 4 bytes for the
trailing block size when then block is free}
FullDebugBlockOverhead = SizeOf(TFullDebugBlockHeader) + 2 * SizeOf(Pointer);
{$endif}
{-------------------------Private variables----------------------------}
var
{-----------------Small block management------------------}
{The small block types. Sizes include the leading 4-byte overhead. Sizes are
picked to limit maximum wastage to about 10% or 256 bytes (whichever is
less) where possible.}
SmallBlockTypes: packed array[0..NumSmallBlockTypes - 1] of TSmallBlockType =(
{8/16 byte jumps}
(BlockSize: 16 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: Move12{$endif}),
{$ifndef Align16Bytes}
(BlockSize: 24 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: Move20{$endif}),
{$endif}
(BlockSize: 32 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: Move28{$endif}),
{$ifndef Align16Bytes}
(BlockSize: 40 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: Move36{$endif}),
{$endif}
(BlockSize: 48 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: Move44{$endif}),
{$ifndef Align16Bytes}
(BlockSize: 56 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: Move52{$endif}),
{$endif}
(BlockSize: 64 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: Move60{$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: packed 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: packed 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: packed array[0..MediumBlockBinCount - 1] of TMediumFreeBlock;
{-----------------Large block management------------------}
{Are large blocks locked?}
LargeBlocksLocked: boolean;
{A dummy large block header: Maintains a list of all allocated large blocks
to enable memory leak detection on program shutdown.}
LargeBlocksCircularList: TLargeBlockHeader;
{-------------------------Expected Memory Leak Structures--------------------}
{$ifdef EnableMemoryLeakReporting}
{The expected memory leaks}
ExpectedMemoryLeaks: PExpectedMemoryLeaks;
ExpectedMemoryLeaksListLocked: Boolean;
{$endif}
{---------------------Full Debug Mode structures--------------------}
{$ifdef FullDebugMode}
{The allocation group stack}
AllocationGroupStack: array[0..AllocationGroupStackSize - 1] of Cardinal;
{The allocation group stack top (it is an index into AllocationGroupStack)}
AllocationGroupStackTop: Cardinal;
{The last allocation number used}
CurrentAllocationNumber: Cardinal;
{The current log file name}
MMLogFileName: array[0..1023] of char;
{The 64K block of reserved memory used to trap invalid memory accesses using
fields in a freed object.}
ReservedBlock: Pointer;
{The virtual method index count - used to get the virtual method index for a
virtual method call on a freed object.}
VMIndex: Integer;
{The fake VMT used to catch virtual method calls on freed objects.}
FreedObjectVMT: packed record
VMTData: array[vmtSelfPtr .. vmtParent + 3] of byte;
VMTMethods: array[4 + vmtParent .. MaxFakeVMTEntries * 4 + vmtParent + 3] of Byte;
end;
{$ifdef CatchUseOfFreedInterfaces}
VMTBadInterface: array[0..MaxFakeVMTEntries - 1] of Pointer;
{$endif}
{$endif}
{--------------Other info--------------}
{The memory manager that was replaced}
OldMemoryManager: {$ifndef BDS2006AndUp}TMemoryManager{$else}TMemoryManagerEx{$endif};
{The replacement memory manager}
NewMemoryManager: {$ifndef BDS2006AndUp}TMemoryManager{$else}TMemoryManagerEx{$endif};
{$ifdef DetectMMOperationsAfterUninstall}
{Invalid handlers to catch MM operations after uninstall}
InvalidMemoryManager: {$ifndef BDS2006AndUp}TMemoryManager{$else}TMemoryManagerEx{$endif} = (
GetMem: InvalidGetMem;
FreeMem: InvalidFreeMem;
ReallocMem: InvalidReallocMem
{$ifdef BDS2006AndUp};
AllocMem: InvalidAllocMem;
RegisterExpectedMemoryLeak: InvalidRegisterAndUnRegisterMemoryLeak;
UnRegisterExpectedMemoryLeak: InvalidRegisterAndUnRegisterMemoryLeak;
{$endif}
);
{$endif}
{A string uniquely identifying the current process (for sharing the memory
manager between DLLs and the main application)}
UniqueProcessIDString: String[20] = '????????_PID_FastMM'#0;
{$ifdef EnableSharingWithDefaultMM}
UniqueProcessIDStringBE: String[23] = '????????_PID_FastMM_BE'#0;
{$endif}
{$ifdef ShareMM}
{$ifndef Linux}
{The handle of the MM window}
MMWindow: HWND;
{$ifdef EnableSharingWithDefaultMM}
{The handle of the MM window (for default MM of Delphi 2006 compatibility)}
MMWindowBE: HWND;
{$endif}
{$endif}
{$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}
{----------------Utility Functions------------------}
{$ifdef EnableMMX}
{$ifndef ForceMMX}
{Returns true if the CPUID instruction is supported}
function CPUID_Supported: Boolean;
asm
pushfd
pop eax
mov edx, eax
xor eax, $200000
push eax
popfd
pushfd
pop eax
xor eax, edx
setnz al
end;
{Gets the CPUID}
function GetCPUID(AInfoRequired: Integer): TRegisters;
asm
push ebx
push esi
mov esi, edx
{cpuid instruction}
{$ifdef Delphi4or5}
db $0f, $a2
{$else}
cpuid
{$endif}
{Save registers}
mov TRegisters[esi].RegEAX, eax
mov TRegisters[esi].RegEBX, ebx
mov TRegisters[esi].RegECX, ecx
mov TRegisters[esi].RegEDX, edx
pop esi
pop ebx
end;
{Returns true if the CPU supports MMX}
function MMX_Supported: Boolean;
var
LReg: TRegisters;
begin
if CPUID_Supported then
begin
{Get the CPUID}
LReg := GetCPUID(1);
{Bit 23 must be set for MMX support}
Result := LReg.RegEDX and $800000 <> 0;
end
else
Result := False;
end;
{$endif}
{$endif}
{Compare [AAddress], CompareVal:
If Equal: [AAddress] := NewVal and result = CompareVal
If Unequal: Result := [AAddress]}
function LockCmpxchg(CompareVal, NewVal: byte; AAddress: PByte): Byte;
asm
{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}
end;
{$ifndef AsmVersion}
{Gets the first set bit and resets it, returning the bit index}
function FindFirstSetBit(ACardinal: Cardinal): Cardinal;
asm
{On entry:
eax = ACardinal}
bsf eax, eax
end;
{$endif}
{Copies the name of the module followed by the given string to the buffer,
returning the pointer following the buffer.}
function AppendStringToModuleName(AString, ABuffer: PChar): PChar;
var
LModuleNameLength: Cardinal;
LCopyStart: PChar;
begin
{Get the name of the application}
LModuleNameLength := GetModuleFileName(0, ABuffer, 512);
{Replace the last few characters}
if LModuleNameLength > 0 then
begin
{Find the last backslash}
LCopyStart := PChar(Cardinal(ABuffer) + LModuleNameLength - 1);
LModuleNameLength := 0;
while (Cardinal(LCopyStart) >= Cardinal(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 Move12(const ASource; var ADest; ACount: Integer);
asm
mov ecx, [eax]
mov [edx], ecx
mov ecx, [eax + 4]
mov eax, [eax + 8]
mov [edx + 4], ecx
mov [edx + 8], eax
end;
procedure Move20(const ASource; var ADest; ACount: Integer);
asm
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
end;
procedure Move28(const ASource; var ADest; ACount: Integer);
asm
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
end;
procedure Move36(const ASource; var ADest; ACount: Integer);
asm
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]
end;
procedure Move44(const ASource; var ADest; ACount: Integer);
asm
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]
end;
procedure Move52(const ASource; var ADest; ACount: Integer);
asm
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]
end;
procedure Move60(const ASource; var ADest; ACount: Integer);
asm
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]
end;
procedure Move68(const ASource; var ADest; ACount: Integer);
asm
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]
end;
{Variable size move procedure: Assumes ACount is 4 less than a multiple of 16.
Always moves at least 12 bytes, irrespective of ACount.}
procedure MoveX16L4(const ASource; var ADest; ACount: Integer);
asm
{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}
end;
{Variable size move procedure: Assumes ACount is 4 less than a multiple of 8.
Always moves at least 12 bytes, irrespective of ACount.}
procedure MoveX8L4(const ASource; var ADest; ACount: Integer);
asm
{Make the counter negative based: The last 4 bytes are moved separately}
sub ecx, 4
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
{$ifndef ForceMMX}
ret
{$endif}
{$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
{$endif}
end;
{----------------Windows Emulation Functions for Kylix Support-----------------}
{$ifdef Linux}
const
{Messagebox constants}
MB_OK = 0;
MB_ICONERROR = $10;
MB_TASKMODAL = $2000;
{Virtual memory constants}
MEM_COMMIT = $1000;
MEM_RELEASE = $8000;
MEM_TOP_DOWN = $100000;
PAGE_READWRITE = 4;
procedure MessageBox(hWnd: Cardinal; AMessageText, AMessageTitle: PChar; uType: Cardinal); stdcall;
begin
writeln(AMessageText);
end;
function VirtualAlloc(lpvAddress: Pointer; dwSize, flAllocationType, flProtect: Cardinal): Pointer; stdcall;
begin
Result := valloc(dwSize);
end;
function VirtualFree(lpAddress: Pointer; dwSize, dwFreeType: Cardinal): LongBool; stdcall;
begin
free(lpAddress);
Result := True;
end;
procedure Sleep(dwMilliseconds: Cardinal); stdcall;
begin
{Convert to microseconds (more or less)}
usleep(dwMilliseconds shl 10);
end;
{$endif}
{-----------------Debugging Support Functions and Procedures------------------}
{$ifdef FullDebugMode}
{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: PCardinal;
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: PCardinal;
AMaxDepth: Cardinal; ABuffer: PChar): PChar; external FullDebugModeLibraryName
name 'LogStackTrace';
{$endif}
{$ifndef Linux}
function DelphiIsRunning: boolean;
begin
Result := FindWindow('TAppBuilder', nil) <> 0;
end;
{$endif}
{Converts a cardinal to string at the buffer location, returning the new
buffer position.}
function CardinalToStrBuf(ACardinal: Cardinal; ABuffer: PChar): PChar;
asm
{On entry: eax = ACardinal, 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;
{Converts a cardinal to a hexadecimal string at the buffer location, returning
the new buffer position.}
function CardinalToHexBuf(ACardinal: integer; ABuffer: PChar): PChar;
asm
{On entry:
eax = ACardinal
edx = ABuffer}
push ebx
push edi
{Save ACardinal 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;
{Appends the source text to the destination and returns the new destination
position}
function AppendStringToBuffer(const ASource, ADestination: PChar; ACount: Cardinal): PChar;
begin
System.Move(ASource^, ADestination^, ACount);
Result := Pointer(Cardinal(ADestination) + ACount);
end;
{Returns the class for a memory block. Returns nil if it is not a valid class}
function GetObjectClass(APointer: Pointer): TClass;
{$ifndef Linux}
var
LMemInfo: TMemoryBasicInformation;
function InternalIsValidClass(APossibleClass: Pointer; ADepth: Integer = 0): Boolean;
var
LParentClass: Pointer;
begin
{Do we need to recheck the VM?}
if (Cardinal(LMemInfo.BaseAddress) > (Cardinal(APossibleClass) + Cardinal(vmtSelfPtr)))
or ((Cardinal(LMemInfo.BaseAddress) + LMemInfo.RegionSize) < (Cardinal(APossibleClass) + Cardinal(vmtParent + 3))) then
begin
{Get the VM status for the pointer}
VirtualQuery(Pointer(Cardinal(APossibleClass) + Cardinal(vmtSelfPtr)), LMemInfo,
SizeOf(LMemInfo));
end;
{Get the result, while checking for recursion}
Result := (ADepth < 1000)
{The required info must fit inside the region}
and ((Cardinal(LMemInfo.BaseAddress) + LMemInfo.RegionSize) > (Cardinal(APossibleClass) + Cardinal(vmtParent + 3)))
{Memory must be committed}
and (LMemInfo.State = MEM_COMMIT)
{Memory must be readable}
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)
{All class fields must fit inside the block}
{The self pointer must be valid}
and (PPointer(Cardinal(APossibleClass) + Cardinal(vmtSelfPtr))^ = APossibleClass);
{Check the parent class}
if Result then
begin
LParentClass := PPointer(Cardinal(APossibleClass) + Cardinal(vmtParent))^;
{The parent must also be a valid class}
Result := (LParentClass = nil) or
InternalIsValidClass(Pointer(Cardinal(LParentClass) - Cardinal(vmtSelfPtr)), ADepth + 1)
end;
end;
begin
{Get the class pointer from the (suspected) object}
Result := TClass(PCardinal(APointer)^);
{No VM info yet}
LMemInfo.RegionSize := 0;
{Check the block}
if (Cardinal(Result) < 65536)
or (not InternalIsValidClass(Result, 0)) then
begin
Result := nil;
end;
end;
{$else}
begin
{Not currently supported under Linux}
Result := nil;
end;
{$endif}
{Fills a block of memory with the given dword. Always fills a multiple of 4 bytes}
procedure FillDWord(var AAddress; AByteCount: integer; ADWordFillValue: Cardinal);
asm
{On Entry: eax = AAddress
edx = AByteCount
ecx = ADWordFillValue}
add eax, edx
neg edx
jns @Done
@FillLoop:
mov [eax + edx], ecx
add edx, 4
js @FillLoop
@Done:
end;
{Gets the available size inside a block}
function GetAvailableSpaceInBlock(APointer: Pointer): Cardinal;
var
LBlockHeader: Cardinal;
LPSmallBlockPool: PSmallBlockPoolHeader;
begin
LBlockHeader := PCardinal(Cardinal(APointer) - 4)^;
if LBlockHeader and (IsMediumBlockFlag or IsLargeBlockFlag) = 0 then
begin
LPSmallBlockPool := PSmallBlockPoolHeader(LBlockHeader and DropSmallFlagsMask);
Result := LPSmallBlockPool.BlockType.BlockSize - BlockHeaderSize;
end
else
begin
Result := (LBlockHeader and DropMediumAndLargeFlagsMask) - BlockHeaderSize;
if (LBlockHeader and IsMediumBlockFlag) = 0 then
Dec(Result, LargeBlockHeaderSize);
end;
end;
{-----------------Small Block Management------------------}
{Locks all small block types}
procedure LockAllSmallBlockTypes;
var
LInd: Cardinal;
begin
{Lock the medium blocks}
{$ifndef AssumeMultiThreaded}
if IsMultiThread then
{$endif}
begin
for LInd := 0 to NumSmallBlockTypes - 1 do
begin
while LockCmpxchg(0, 1, @SmallBlockTypes[LInd].BlockTypeLocked) <> 0 do
begin
Sleep(InitialSleepTime);
if LockCmpxchg(0, 1, @SmallBlockTypes[LInd].BlockTypeLocked) = 0 then
break;
Sleep(AdditionalSleepTime);
end;
end;
end;
end;
{Gets the first and last block pointer for a small block pool}
procedure GetFirstAndLastSmallBlockInPool(APSmallBlockPool: PSmallBlockPoolHeader;
var AFirstPtr, ALastPtr: Pointer);
var
LBlockSize: Cardinal;
begin
{Get the pointer to the first block}
AFirstPtr := Pointer(Cardinal(APSmallBlockPool) + SmallBlockPoolHeaderSize);
{Get a pointer to the last block}
if (APSmallBlockPool.BlockType.CurrentSequentialFeedPool <> APSmallBlockPool)
or (Cardinal(APSmallBlockPool.BlockType.NextSequentialFeedBlockAddress) > Cardinal(APSmallBlockPool.BlockType.MaxSequentialFeedBlockAddress)) then
begin
{Not the sequential feed - point to the end of the block}
LBlockSize := PCardinal(Cardinal(APSmallBlockPool) - 4)^ and DropMediumAndLargeFlagsMask;
ALastPtr := Pointer(Cardinal(APSmallBlockPool) + LBlockSize - APSmallBlockPool.BlockType.BlockSize);
end
else
begin
{The sequential feed pool - point to before the next sequential feed block}
ALastPtr := Pointer(Cardinal(APSmallBlockPool.BlockType.NextSequentialFeedBlockAddress) - 1);
end;
end;
{-----------------Medium Block Management------------------}
{Advances to the next medium block. Returns nil if the end of the medium block
pool has been reached}
function NextMediumBlock(APMediumBlock: Pointer): Pointer;
var
LBlockSize: Cardinal;
begin
{Get the size of this block}
LBlockSize := PCardinal(Cardinal(APMediumBlock) - 4)^ and DropMediumAndLargeFlagsMask;
{Advance the pointer}
Result := Pointer(Cardinal(APMediumBlock) + LBlockSize);
{Is the next block the end of medium pool marker?}
LBlockSize := PCardinal(Cardinal(Result) - 4)^ and DropMediumAndLargeFlagsMask;
if LBlockSize = 0 then
Result := nil;
end;
{Gets the first medium block in the medium block pool}
function GetFirstMediumBlockInPool(APMediumBlockPoolHeader: PMediumBlockPoolHeader): Pointer;
begin
if (MediumSequentialFeedBytesLeft = 0)
or (Cardinal(LastSequentiallyFedMediumBlock) < Cardinal(APMediumBlockPoolHeader))
or (Cardinal(LastSequentiallyFedMediumBlock) > Cardinal(APMediumBlockPoolHeader) + MediumBlockPoolSize) then
begin
Result := Pointer(Cardinal(APMediumBlockPoolHeader) + MediumBlockPoolHeaderSize);
end
else
begin
{Is the sequential feed pool empty?}
if MediumSequentialFeedBytesLeft <> MediumBlockPoolSize - MediumBlockPoolHeaderSize then
Result := LastSequentiallyFedMediumBlock
else
Result := nil;
end;
end;
{Locks the medium blocks}
procedure LockMediumBlocks;
begin
{Lock the medium blocks}
{$ifndef AssumeMultiThreaded}
if IsMultiThread then
{$endif}
begin
while LockCmpxchg(0, 1, @MediumBlocksLocked) <> 0 do
begin
Sleep(InitialSleepTime);
if LockCmpxchg(0, 1, @MediumBlocksLocked) = 0 then
break;
Sleep(AdditionalSleepTime);
end;
end;
end;
{$ifndef AsmVersion}
{Removes a medium block from the circular linked list of free blocks.
Does not change any header flags. Medium blocks should be locked
before calling this procedure.}
procedure RemoveMediumFreeBlock(APMediumFreeBlock: PMediumFreeBlock);
var
LPreviousFreeBlock, LNextFreeBlock: PMediumFreeBlock;
LBinNumber, LBinGroupNumber: Cardinal;
begin
{Get the current previous and next blocks}
LNextFreeBlock := APMediumFreeBlock.NextFreeBlock;
LPreviousFreeBlock := APMediumFreeBlock.PreviousFreeBlock;
{Remove this block from the linked list}
LPreviousFreeBlock.NextFreeBlock := LNextFreeBlock;
LNextFreeBlock.PreviousFreeBlock := LPreviousFreeBlock;
{Is this bin now empty? If the previous and next free block pointers are
equal, they must point to the bin.}
if LPreviousFreeBlock = LNextFreeBlock then
begin
{Get the bin number for this block size}
LBinNumber := (Cardinal(LNextFreeBlock) - Cardinal(@MediumBlockBins)) div SizeOf(TMediumFreeBlock);
LBinGroupNumber := LBinNumber div 32;
{Flag this bin as empty}
MediumBlockBinBitmaps[LBinGroupNumber] := MediumBlockBinBitmaps[LBinGroupNumber]
and (not (1 shl (LBinNumber and 31)));
{Is the group now entirely empty?}
if MediumBlockBinBitmaps[LBinGroupNumber] = 0 then
begin
{Flag this group as empty}
MediumBlockBinGroupBitmap := MediumBlockBinGroupBitmap
and (not (1 shl LBinGroupNumber));
end;
end;
end;
{$else}
{Removes a medium block from the circular linked list of free blocks.
Does not change any header flags. Medium blocks should be locked
before calling this procedure.}
procedure RemoveMediumFreeBlock(APMediumFreeBlock: PMediumFreeBlock);
asm
{On entry: eax = APMediumFreeBlock}
{Get the current previous and next blocks}
mov ecx, TMediumFreeBlock[eax].NextFreeBlock
mov edx, TMediumFreeBlock[eax].PreviousFreeBlock
{Is this bin now empty? If the previous and next free block pointers are
equal, they must point to the bin.}
cmp ecx, edx
{Remove this block from the linked list}
mov TMediumFreeBlock[ecx].PreviousFreeBlock, edx
mov TMediumFreeBlock[edx].NextFreeBlock, ecx
{Is this bin now empty? If the previous and next free block pointers are
equal, they must point to the bin.}
je @BinIsNowEmpty
@Done:
ret
{Align branch target}
nop
@BinIsNowEmpty:
{Get the bin number for this block size in ecx}
sub ecx, offset MediumBlockBins
mov edx, ecx
shr ecx, 3
{Get the group number in edx}
movzx edx, dh
{Flag this bin as empty}
mov eax, -2
rol eax, cl
and dword ptr [MediumBlockBinBitmaps + edx * 4], eax
jnz @Done
{Flag this group as empty}
mov eax, -2
mov ecx, edx
rol eax, cl
and MediumBlockBinGroupBitmap, eax
end;
{$endif}
{$ifndef AsmVersion}
{Inserts a medium block into the appropriate medium block bin.}
procedure InsertMediumBlockIntoBin(APMediumFreeBlock: PMediumFreeBlock; AMediumBlockSize: Cardinal);
var
LBinNumber, LBinGroupNumber: Cardinal;
LPBin, LPFirstFreeBlock: PMediumFreeBlock;
begin
{Get the bin number for this block size. Get the bin that holds blocks of at
least this size.}
LBinNumber := (AMediumBlockSize - MinimumMediumBlockSize) div MediumBlockGranularity;
if LBinNumber >= MediumBlockBinCount then
LBinNumber := MediumBlockBinCount - 1;
{Get the bin}
LPBin := @MediumBlockBins[LBinNumber];
{Bins are LIFO, se we insert this block as the first free block in the bin}
LPFirstFreeBlock := LPBin.NextFreeBlock;
APMediumFreeBlock.PreviousFreeBlock := LPBin;
APMediumFreeBlock.NextFreeBlock := LPFirstFreeBlock;
LPFirstFreeBlock.PreviousFreeBlock := APMediumFreeBlock;
LPBin.NextFreeBlock := APMediumFreeBlock;
{Was this bin empty?}
if LPFirstFreeBlock = LPBin then
begin
{Get the group number}
LBinGroupNumber := LBinNumber div 32;
{Flag this bin as used}
MediumBlockBinBitmaps[LBinGroupNumber] := MediumBlockBinBitmaps[LBinGroupNumber]
or (1 shl (LBinNumber and 31));
{Flag the group as used}
MediumBlockBinGroupBitmap := MediumBlockBinGroupBitmap
or (1 shl LBinGroupNumber);
end;
end;
{$else}
{Inserts a medium block into the appropriate medium block bin.}
procedure InsertMediumBlockIntoBin(APMediumFreeBlock: PMediumFreeBlock; AMediumBlockSize: Cardinal);
asm
{On entry: eax = APMediumFreeBlock, edx = AMediumBlockSize}
{Get the bin number for this block size. Get the bin that holds blocks of at
least this size.}
sub edx, MinimumMediumBlockSize
shr edx, 8
{Validate the bin number}
sub edx, MediumBlockBinCount - 1
sbb ecx, ecx
and edx, ecx
add edx, MediumBlockBinCount - 1
{Get the bin in ecx}
lea ecx, [MediumBlockBins + edx * 8]
{Bins are LIFO, se we insert this block as the first free block in the bin}
mov edx, TMediumFreeBlock[ecx].NextFreeBlock
{Was this bin empty?}
cmp edx, ecx
mov TMediumFreeBlock[eax].PreviousFreeBlock, ecx
mov TMediumFreeBlock[eax].NextFreeBlock, edx
mov TMediumFreeBlock[edx].PreviousFreeBlock, eax
mov TMediumFreeBlock[ecx].NextFreeBlock, eax
{Was this bin empty?}
je @BinWasEmpty
ret
{Align branch target}
nop
nop
@BinWasEmpty:
{Get the bin number in ecx}
sub ecx, offset MediumBlockBins
mov edx, ecx
shr ecx, 3
{Get the group number in edx}
movzx edx, dh
{Flag this bin as not empty}
mov eax, 1
shl eax, cl
or dword ptr [MediumBlockBinBitmaps + edx * 4], eax
{Flag the group as not empty}
mov eax, 1
mov ecx, edx
shl eax, cl
or MediumBlockBinGroupBitmap, eax
end;
{$endif}
{$ifndef AsmVersion}
{Bins what remains in the current sequential feed medium block pool. Medium
blocks must be locked.}
procedure BinMediumSequentialFeedRemainder;
var
LSequentialFeedFreeSize, LNextBlockSizeAndFlags: Cardinal;
LPRemainderBlock, LNextMediumBlock: Pointer;
begin
LSequentialFeedFreeSize := MediumSequentialFeedBytesLeft;
if LSequentialFeedFreeSize > 0 then
begin
{Get the block after the open space}
LNextMediumBlock := LastSequentiallyFedMediumBlock;
LNextBlockSizeAndFlags := PCardinal(Cardinal(LNextMediumBlock) - BlockHeaderSize)^;
{Point to the remainder}
LPRemainderBlock := Pointer(Cardinal(LNextMediumBlock) - LSequentialFeedFreeSize);
{$ifndef FullDebugMode}
{Can the next block be combined with the remainder?}
if (LNextBlockSizeAndFlags and IsFreeBlockFlag) <> 0 then
begin
{Increase the size of this block}
Inc(LSequentialFeedFreeSize, LNextBlockSizeAndFlags and DropMediumAndLargeFlagsMask);
{Remove the next block as well}
if (LNextBlockSizeAndFlags and DropMediumAndLargeFlagsMask) >= MinimumMediumBlockSize then
RemoveMediumFreeBlock(LNextMediumBlock);
end
else
begin
{$endif}
{Set the "previous block is free" flag of the next block}
PCardinal(Cardinal(LNextMediumBlock) - BlockHeaderSize)^ := LNextBlockSizeAndFlags or PreviousMediumBlockIsFreeFlag;
{$ifndef FullDebugMode}
end;
{$endif}
{Store the size of the block as well as the flags}
PCardinal(Cardinal(LPRemainderBlock) - BlockHeaderSize)^ := LSequentialFeedFreeSize or IsMediumBlockFlag or IsFreeBlockFlag;
{Store the trailing size marker}
PCardinal(Cardinal(LPRemainderBlock) + LSequentialFeedFreeSize - 8)^ := LSequentialFeedFreeSize;
{$ifdef FullDebugMode}
{In full debug mode the sequential feed remainder will never be too small to
fit a full debug header.}
{Clear the user area of the block}
FillDWord(Pointer(Cardinal(LPRemainderBlock) + SizeOf(TFullDebugBlockHeader) + 4)^,
LSequentialFeedFreeSize - FullDebugBlockOverhead - 4,
{$ifndef CatchUseOfFreedInterfaces}DebugFillDWord{$else}Cardinal(@VMTBadInterface){$endif});
{We need to set a valid debug header and footer in the remainder}
PFullDebugBlockHeader(LPRemainderBlock).HeaderCheckSum := Cardinal(LPRemainderBlock);
PCardinal(Cardinal(LPRemainderBlock) + SizeOf(TFullDebugBlockHeader))^ := not Cardinal(LPRemainderBlock);
{$endif}
{Bin this medium block}
if LSequentialFeedFreeSize >= MinimumMediumBlockSize then
InsertMediumBlockIntoBin(LPRemainderBlock, LSequentialFeedFreeSize);
end;
end;
{$else}
{Bins what remains in the current sequential feed medium block pool. Medium
blocks must be locked.}
procedure BinMediumSequentialFeedRemainder;
asm
cmp MediumSequentialFeedBytesLeft, 0
jne @MustBinMedium
{Nothing to bin}
ret
{Align branch target}
nop
nop
@MustBinMedium:
{Get a pointer to the last sequentially allocated medium block}
mov eax, LastSequentiallyFedMediumBlock
{Is the block that was last fed sequentially free?}
test byte ptr [eax - 4], IsFreeBlockFlag
jnz @LastBlockFedIsFree
{Set the "previous block is free" flag in the last block fed}
or dword ptr [eax - 4], PreviousMediumBlockIsFreeFlag
{Get the remainder in edx}
mov edx, MediumSequentialFeedBytesLeft
{Point eax to the start of the remainder}
sub eax, edx
@BinTheRemainder:
{Status: eax = start of remainder, edx = size of remainder}
{Store the size of the block as well as the flags}
lea ecx, [edx + IsMediumBlockFlag + IsFreeBlockFlag]
mov [eax - 4], ecx
{Store the trailing size marker}
mov [eax + edx - 8], edx
{Bin this medium block}
cmp edx, MinimumMediumBlockSize
jnb InsertMediumBlockIntoBin
ret
{Align branch target}
nop
nop
@LastBlockFedIsFree:
{Drop the flags}
mov edx, DropMediumAndLargeFlagsMask
and edx, [eax - 4]
{Free the last block fed}
cmp edx, MinimumMediumBlockSize
jb @DontRemoveLastFed
{Last fed block is free - remove it from its size bin}
call RemoveMediumFreeBlock
{Re-read eax and edx}
mov eax, LastSequentiallyFedMediumBlock
mov edx, DropMediumAndLargeFlagsMask
and edx, [eax - 4]
@DontRemoveLastFed:
{Get the number of bytes left in ecx}
mov ecx, MediumSequentialFeedBytesLeft
{Point eax to the start of the remainder}
sub eax, ecx
{edx = total size of the remainder}
add edx, ecx
jmp @BinTheRemainder
end;
{$endif}
{Allocates a new sequential feed medium block pool and immediately splits off a
block of the requested size. The block size must be a multiple of 16 and
medium blocks must be locked.}
function AllocNewSequentialFeedMediumPool(AFirstBlockSize: Cardinal): Pointer;
var
LOldFirstMediumBlockPool: PMediumBlockPoolHeader;
LNewPool: Pointer;
begin
{Bin the current sequential feed remainder}
BinMediumSequentialFeedRemainder;
{Allocate a new sequential feed block pool}
LNewPool := VirtualAlloc(nil, MediumBlockPoolSize, MEM_COMMIT, PAGE_READWRITE);
if LNewPool <> nil then
begin
{Insert this block pool into the list of block pools}
LOldFirstMediumBlockPool := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader;
PMediumBlockPoolHeader(LNewPool).PreviousMediumBlockPoolHeader := @MediumBlockPoolsCircularList;
MediumBlockPoolsCircularList.NextMediumBlockPoolHeader := LNewPool;
PMediumBlockPoolHeader(LNewPool).NextMediumBlockPoolHeader := LOldFirstMediumBlockPool;
LOldFirstMediumBlockPool.PreviousMediumBlockPoolHeader := LNewPool;
{Store the sequential feed pool trailer}
PCardinal(Cardinal(LNewPool) + MediumBlockPoolSize - BlockHeaderSize)^ := IsMediumBlockFlag;
{Get the number of bytes still available}
MediumSequentialFeedBytesLeft := (MediumBlockPoolSize - MediumBlockPoolHeaderSize) - AFirstBlockSize;
{Get the result}
Result := Pointer(Cardinal(LNewPool) + MediumBlockPoolSize - AFirstBlockSize);
LastSequentiallyFedMediumBlock := Result;
{Store the block header}
PCardinal(Cardinal(Result) - BlockHeaderSize)^ := AFirstBlockSize or IsMediumBlockFlag;
end
else
begin
{Out of memory}
MediumSequentialFeedBytesLeft := 0;
Result := nil;
end;
end;
{Frees a medium block pool. Medium blocks must be locked on entry.}
procedure FreeMediumBlockPool(AMediumBlockPool: PMediumBlockPoolHeader);
var
LPPreviousMediumBlockPoolHeader, LPNextMediumBlockPoolHeader: PMediumBlockPoolHeader;
begin
{Remove this medium block pool from the linked list}
LPPreviousMediumBlockPoolHeader := AMediumBlockPool.PreviousMediumBlockPoolHeader;
LPNextMediumBlockPoolHeader := AMediumBlockPool.NextMediumBlockPoolHeader;
LPPreviousMediumBlockPoolHeader.NextMediumBlockPoolHeader := LPNextMediumBlockPoolHeader;
LPNextMediumBlockPoolHeader.PreviousMediumBlockPoolHeader := LPPreviousMediumBlockPoolHeader;
{Free the medium block pool}
VirtualFree(AMediumBlockPool, 0, MEM_RELEASE);
end;
{-----------------Large Block Management------------------}
{Locks the large blocks}
procedure LockLargeBlocks;
begin
{Lock the large blocks}
{$ifndef AssumeMultiThreaded}
if IsMultiThread then
{$endif}
begin
while LockCmpxchg(0, 1, @LargeBlocksLocked) <> 0 do
begin
Sleep(InitialSleepTime);
if LockCmpxchg(0, 1, @LargeBlocksLocked) = 0 then
break;
Sleep(AdditionalSleepTime);
end;
end;
end;
{Allocates a Large block of at least ASize (actual size may be larger to
allow for alignment etc.). ASize must be the actual user requested size. This
procedure will pad it to the appropriate page boundary and also add the space
required by the header.}
function AllocateLargeBlock(ASize: Cardinal): Pointer;
var
LLargeUsedBlockSize: Cardinal;
LOldFirstLargeBlock: PLargeBlockHeader;
begin
{Pad the block size to include the header and granularity. We also add a
4-byte overhead so a huge block size is a multiple of 16 bytes less 4 (so we
can use a single move function for reallocating all block types)}
LLargeUsedBlockSize := (ASize + LargeBlockHeaderSize + LargeBlockGranularity - 1 + BlockHeaderSize)
and -LargeBlockGranularity;
{Get the Large block}
Result := VirtualAlloc(nil, LLargeUsedBlockSize, MEM_COMMIT or MEM_TOP_DOWN,
PAGE_READWRITE);
{Set the Large block fields}
if Result <> nil then
begin
{Set the large block size and flags}
PLargeBlockHeader(Result).UserAllocatedSize := ASize;
PLargeBlockHeader(Result).BlockSizeAndFlags := LLargeUsedBlockSize or IsLargeBlockFlag;
{Insert the large block into the linked list of large blocks}
LockLargeBlocks;
LOldFirstLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader;
PLargeBlockHeader(Result).PreviousLargeBlockHeader := @LargeBlocksCircularList;
LargeBlocksCircularList.NextLargeBlockHeader := Result;
PLargeBlockHeader(Result).NextLargeBlockHeader := LOldFirstLargeBlock;
LOldFirstLargeBlock.PreviousLargeBlockHeader := Result;
LargeBlocksLocked := False;
{Add the size of the header}
Inc(Cardinal(Result), LargeBlockHeaderSize);
{$ifdef FullDebugMode}
{Clear the user area of the block}
FillDWord(Pointer(Cardinal(Result) + SizeOf(TFullDebugBlockHeader) + 4)^,
LLargeUsedBlockSize - LargeBlockHeaderSize - FullDebugBlockOverhead - 4,
{$ifndef CatchUseOfFreedInterfaces}DebugFillDWord{$else}Cardinal(@VMTBadInterface){$endif});
{Set the debug header and footer}
PFullDebugBlockHeader(Result).HeaderCheckSum := Cardinal(Result);
PCardinal(Cardinal(Result) + SizeOf(TFullDebugBlockHeader))^ := not Cardinal(Result);
{$endif}
end;
end;
{Frees a large block, returning 0 on success, -1 otherwise}
function FreeLargeBlock(APointer: Pointer): Integer;
var
LPreviousLargeBlockHeader, LNextLargeBlockHeader: PLargeBlockHeader;
{$ifndef Linux}
LRemainingSize: Cardinal;
LCurrentSegment: Pointer;
LMemInfo: TMemoryBasicInformation;
{$endif}
begin
{Point to the start of the large block}
APointer := Pointer(Cardinal(APointer) - LargeBlockHeaderSize);
{Get the previous and next large blocks}
LockLargeBlocks;
LPreviousLargeBlockHeader := PLargeBlockHeader(APointer).PreviousLargeBlockHeader;
LNextLargeBlockHeader := PLargeBlockHeader(APointer).NextLargeBlockHeader;
{$ifndef Linux}
{Is the large block segmented?}
if PLargeBlockHeader(APointer).BlockSizeAndFlags and LargeBlockIsSegmented = 0 then
begin
{$endif}
{Single segment large block: Try to free it}
if VirtualFree(APointer, 0, MEM_RELEASE) then
Result := 0
else
Result := -1;
{$ifndef Linux}
end
else
begin
{The large block is segmented - free all segments}
LCurrentSegment := APointer;
LRemainingSize := PLargeBlockHeader(APointer).BlockSizeAndFlags and DropMediumAndLargeFlagsMask;
Result := 0;
while True do
begin
{Free the current segment}
if not VirtualFree(LCurrentSegment, 0, MEM_RELEASE) then
begin
Result := -1;
break;
end;
{Get the size of the segment that was freed}
VirtualQuery(LCurrentSegment, LMemInfo, SizeOf(LMemInfo));
{Done?}
if LMemInfo.RegionSize >= LRemainingSize then
Break;
{Decrement the remaining size}
Dec(LRemainingSize, LMemInfo.RegionSize);
Inc(Cardinal(LCurrentSegment), LMemInfo.RegionSize);
end;
end;
{$endif}
{Success?}
if Result = 0 then
begin
{Remove the large block from the linked list}
LNextLargeBlockHeader.PreviousLargeBlockHeader := LPreviousLargeBlockHeader;
LPreviousLargeBlockHeader.NextLargeBlockHeader := LNextLargeBlockHeader;
end;
{Unlock the large blocks}
LargeBlocksLocked := False;
end;
{$ifndef FullDebugMode}
{Reallocates a large block to at least the requested size. Returns the new
pointer, or nil on error}
function ReallocateLargeBlock(APointer: Pointer; ANewSize: Cardinal): Pointer;
var
LOldAvailableSize, LBlockHeader, LOldUserSize, LMinimumUpsize,
LNewAllocSize: Cardinal;
{$ifndef Linux}
LNewSegmentSize: Cardinal;
LNextSegmentPointer: Pointer;
LMemInfo: TMemoryBasicInformation;
{$endif}
begin
{Get the block header}
LBlockHeader := PCardinal(Cardinal(APointer) - BlockHeaderSize)^;
{Large block - size is (16 + 4) less than the allocated size}
LOldAvailableSize := (LBlockHeader and DropMediumAndLargeFlagsMask) - (LargeBlockHeaderSize + BlockHeaderSize);
{Is it an upsize or a downsize?}
if Cardinal(ANewSize) > LOldAvailableSize then
begin
{This pointer is being reallocated to a larger block and therefore it is
logical to assume that it may be enlarged again. Since reallocations are
expensive, there is a minimum upsize percentage to avoid unnecessary
future move operations.}
{Add 25% for large block upsizes}
LMinimumUpsize := Cardinal(LOldAvailableSize)
+ (Cardinal(LOldAvailableSize) shr 2);
if Cardinal(ANewSize) < LMinimumUpsize then
LNewAllocSize := LMinimumUpsize
else
LNewAllocSize := ANewSize;
{$ifndef Linux}
{Can another large block segment be allocated directly after this segment,
thus negating the need to move the data?}
LNextSegmentPointer := Pointer(Cardinal(APointer) - LargeBlockHeaderSize + (LBlockHeader and DropMediumAndLargeFlagsMask));
VirtualQuery(LNextSegmentPointer, LMemInfo, SizeOf(LMemInfo));
if (LMemInfo.State = MEM_FREE) then
begin
{Round the region size to the previous 64K}
LMemInfo.RegionSize := LMemInfo.RegionSize and -LargeBlockGranularity;
{Enough space to grow in place?}
if (LMemInfo.RegionSize > (ANewSize - LOldAvailableSize)) then
begin
{There is enough space after the block to extend it - determine by how
much}
LNewSegmentSize := (LNewAllocSize - LOldAvailableSize + LargeBlockGranularity - 1) and -LargeBlockGranularity;
if LNewSegmentSize > LMemInfo.RegionSize then
LNewSegmentSize := LMemInfo.RegionSize;
if (VirtualAlloc(LNextSegmentPointer, LNewSegmentSize, MEM_RESERVE, PAGE_READWRITE) <> nil)
and (VirtualAlloc(LNextSegmentPointer, LNewSegmentSize, MEM_COMMIT, PAGE_READWRITE) <> nil) then
begin
{Update the requested size}
PLargeBlockHeader(Cardinal(APointer) - LargeBlockHeaderSize).UserAllocatedSize := ANewSize;
PLargeBlockHeader(Cardinal(APointer) - LargeBlockHeaderSize).BlockSizeAndFlags :=
(PLargeBlockHeader(Cardinal(APointer) - LargeBlockHeaderSize).BlockSizeAndFlags + LNewSegmentSize)
or LargeBlockIsSegmented;
{Success}
Result := APointer;
exit;
end;
end;
end;
{$endif}
{Could not resize in place: Allocate the new block}
Result := FastGetMem(LNewAllocSize);
if Result <> nil then
begin
{If its a large block - store the actual user requested size (it may
not be if the block that is being reallocated from was previously
downsized)}
if LNewAllocSize > (MaximumMediumBlockSize - BlockHeaderSize) then
PLargeBlockHeader(Cardinal(Result) - LargeBlockHeaderSize).UserAllocatedSize := ANewSize;
{The user allocated size is stored for large blocks}
LOldUserSize := PLargeBlockHeader(Cardinal(APointer) - LargeBlockHeaderSize).UserAllocatedSize;
{The number of bytes to move is the old user size.}
{$ifdef UseCustomVariableSizeMoveRoutines}
MoveX16L4(APointer^, Result^, LOldUserSize);
{$else}
System.Move(APointer^, Result^, LOldUserSize);
{$endif}
{Free the old block}
FastFreeMem(APointer);
end;
end
else
begin
{It's a downsize: do we need to reallocate? Only if the new size is less
than half the old size}
if Cardinal(ANewSize) >= (LOldAvailableSize shr 1) then
begin
{No need to reallocate}
Result := APointer;
{Update the requested size}
PLargeBlockHeader(Cardinal(APointer) - LargeBlockHeaderSize).UserAllocatedSize := ANewSize;
end
else
begin
{The block is less than half the old size, and the current size is
greater than the minimum block size allowing a downsize: reallocate}
Result := FastGetMem(ANewSize);
if Result <> nil then
begin
{Still a large block? -> Set the user size}
if ANewSize > (MaximumMediumBlockSize - BlockHeaderSize) then
PLargeBlockHeader(Cardinal(APointer) - LargeBlockHeaderSize).UserAllocatedSize := ANewSize;
{Move the data across}
{$ifdef UseCustomVariableSizeMoveRoutines}
{$ifdef Align16Bytes}
MoveX16L4(APointer^, Result^, ANewSize);
{$else}
MoveX8L4(APointer^, Result^, ANewSize);
{$endif}
{$else}
System.Move(APointer^, Result^, ANewSize);
{$endif}
{Free the old block}
FastFreeMem(APointer);
end;
end;
end;
end;
{$endif}
{---------------------Replacement Memory Manager Interface---------------------}
{$ifndef ASMVersion}
{Replacement for SysGetMem (pascal version)}
function FastGetMem(ASize: Integer): Pointer;
var
LMediumBlock{$ifndef FullDebugMode}, LNextFreeBlock, LSecondSplit{$endif}: PMediumFreeBlock;
LNextMediumBlockHeader: PCardinal;
LBlockSize, LAvailableBlockSize{$ifndef FullDebugMode}, LSecondSplitSize{$endif}: Cardinal;
LPSmallBlockType: PSmallBlockType;
LPSmallBlockPool, LPNewFirstPool: PSmallBlockPoolHeader;
LBinNumber: Cardinal;
LNewFirstFreeBlock: Pointer;
LPMediumBin: PMediumFreeBlock;
LSequentialFeedFreeSize: Cardinal;
{$ifndef FullDebugMode}LBinGroupsMasked, {$endif}LBinGroupMasked, LBinGroupNumber: Cardinal;
begin
{Is it a small block? -> Take the header size into account when
determining the required block size}
if Cardinal(ASize) <= (MaximumSmallBlockSize - BlockHeaderSize) then
begin
{-------------------------Allocate a small block---------------------------}
{Get the block type from the size}
LPSmallBlockType := PSmallBlockType(AllocSize2SmallBlockTypeIndX4[
(Cardinal(ASize) + (BlockHeaderSize - 1)) div SmallBlockGranularity] * 8
+ Cardinal(@SmallBlockTypes));
{Lock the block type}
{$ifndef AssumeMultiThreaded}
if IsMultiThread then
{$endif}
begin
while True do
begin
{Try to lock the small block type}
if LockCmpxchg(0, 1, @LPSmallBlockType.BlockTypeLocked) = 0 then
break;
{Try the next block type}
Inc(Cardinal(LPSmallBlockType), SizeOf(TSmallBlockType));
if LockCmpxchg(0, 1, @LPSmallBlockType.BlockTypeLocked) = 0 then
break;
{Try up to two sizes past the requested size}
Inc(Cardinal(LPSmallBlockType), SizeOf(TSmallBlockType));
if LockCmpxchg(0, 1, @LPSmallBlockType.BlockTypeLocked) = 0 then
break;
{All three sizes locked - given up and sleep}
Dec(Cardinal(LPSmallBlockType), 2 * SizeOf(TSmallBlockType));
{Both this block type and the next is in use: sleep}
Sleep(InitialSleepTime);
{Try the lock again}
if LockCmpxchg(0, 1, @LPSmallBlockType.BlockTypeLocked) = 0 then
break;
{Sleep longer}
Sleep(AdditionalSleepTime);
end;
end;
{Get the first pool with free blocks}
LPSmallBlockPool := LPSmallBlockType.NextPartiallyFreePool;
{Is the pool valid?}
if Cardinal(LPSmallBlockPool) <> Cardinal(LPSmallBlockType) then
begin
{Get the first free offset}
Result := LPSmallBlockPool.FirstFreeBlock;
{Get the new first free block}
LNewFirstFreeBlock := PPointer(Cardinal(Result) - 4)^;
{$ifdef CheckHeapForCorruption}
{The block should be free}
if (Cardinal(LNewFirstFreeBlock) and ExtractSmallFlagsMask) <> IsFreeBlockFlag then
{$ifdef BCB6OrDelphi7AndUp}
System.Error(reInvalidPtr);
{$else}
System.RunError(reInvalidPtr);
{$endif}
{$endif}
LNewFirstFreeBlock := Pointer(Cardinal(LNewFirstFreeBlock) and DropSmallFlagsMask);
{Increment the number of used blocks}
Inc(LPSmallBlockPool.BlocksInUse);
{Set the new first free block}
LPSmallBlockPool.FirstFreeBlock := LNewFirstFreeBlock;
{Is the pool now full?}
if LNewFirstFreeBlock = nil then
begin
{Pool is full - remove it from the partially free list}
LPNewFirstPool := LPSmallBlockPool.NextPartiallyFreePool;
LPSmallBlockType.NextPartiallyFreePool := LPNewFirstPool;
LPNewFirstPool.PreviousPartiallyFreePool := PSmallBlockPoolHeader(LPSmallBlockType);
end;
end
else
begin
{Try to feed a small block sequentially}
Result := LPSmallBlockType.NextSequentialFeedBlockAddress;
{Can another block fit?}
if Cardinal(Result) <= Cardinal(LPSmallBlockType.MaxSequentialFeedBlockAddress) then
begin
{Get the sequential feed block pool}
LPSmallBlockPool := LPSmallBlockType.CurrentSequentialFeedPool;
{Increment the number of used blocks in the sequential feed pool}
Inc(LPSmallBlockPool.BlocksInUse);
{Store the next sequential feed block address}
LPSmallBlockType.NextSequentialFeedBlockAddress := Pointer(Cardinal(Result) + LPSmallBlockType.BlockSize);
end
else
begin
{Need to allocate a pool: Lock the medium blocks}
LockMediumBlocks;
{$ifndef FullDebugMode}
{Are there any available blocks of a suitable size?}
LBinGroupsMasked := MediumBlockBinGroupBitmap and ($ffffff00 or LPSmallBlockType.AllowedGroupsForBlockPoolBitmap);
if LBinGroupsMasked <> 0 then
begin
{Get the bin group with free blocks}
LBinGroupNumber := FindFirstSetBit(LBinGroupsMasked);
{Get the bin in the group with free blocks}
LBinNumber := FindFirstSetBit(MediumBlockBinBitmaps[LBinGroupNumber])
+ LBinGroupNumber * 32;
LPMediumBin := @MediumBlockBins[LBinNumber];
{Get the first block in the bin}
LMediumBlock := LPMediumBin.NextFreeBlock;
{Remove the first block from the linked list (LIFO)}
LNextFreeBlock := LMediumBlock.NextFreeBlock;
LPMediumBin.NextFreeBlock := LNextFreeBlock;
LNextFreeBlock.PreviousFreeBlock := LPMediumBin;
{Is this bin now empty?}
if LNextFreeBlock = LPMediumBin then
begin
{Flag this bin as empty}
MediumBlockBinBitmaps[LBinGroupNumber] := MediumBlockBinBitmaps[LBinGroupNumber]
and (not (1 shl (LBinNumber and 31)));
{Is the group now entirely empty?}
if MediumBlockBinBitmaps[LBinGroupNumber] = 0 then
begin
{Flag this group as empty}
MediumBlockBinGroupBitmap := MediumBlockBinGroupBitmap
and (not (1 shl LBinGroupNumber));
end;
end;
{Get the size of the available medium block}
LBlockSize := PCardinal(Cardinal(LMediumBlock) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask;
{$ifdef CheckHeapForCorruption}
{Check that this block is actually free and the next and previous blocks
are both in use.}
if ((PCardinal(Cardinal(LMediumBlock) - BlockHeaderSize)^ and ExtractMediumAndLargeFlagsMask) <> (IsMediumBlockFlag or IsFreeBlockFlag))
or ((PCardinal(Cardinal(LMediumBlock) + (PCardinal(Cardinal(LMediumBlock) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask) - BlockHeaderSize)^ and IsFreeBlockFlag) <> 0)
then
begin
{$ifdef BCB6OrDelphi7AndUp}
System.Error(reInvalidPtr);
{$else}
System.RunError(reInvalidPtr);
{$endif}
end;
{$endif}
{Should the block be split?}
if LBlockSize >= MaximumSmallBlockPoolSize then
begin
{Get the size of the second split}
LSecondSplitSize := LBlockSize - LPSmallBlockType.OptimalBlockPoolSize;
{Adjust the block size}
LBlockSize := LPSmallBlockType.OptimalBlockPoolSize;
{Split the block in two}
LSecondSplit := PMediumFreeBlock(Cardinal(LMediumBlock) + LBlockSize);
PCardinal(Cardinal(LSecondSplit) - BlockHeaderSize)^ := LSecondSplitSize or (IsMediumBlockFlag or IsFreeBlockFlag);
{Store the size of the second split as the second last dword}
PCardinal(Cardinal(LSecondSplit) + LSecondSplitSize - 8)^ := LSecondSplitSize;
{Put the remainder in a bin (it will be big enough)}
InsertMediumBlockIntoBin(LSecondSplit, LSecondSplitSize);
end
else
begin
{Mark this block as used in the block following it}
LNextMediumBlockHeader := PCardinal(Cardinal(LMediumBlock) + LBlockSize - BlockHeaderSize);
LNextMediumBlockHeader^ := LNextMediumBlockHeader^ and (not PreviousMediumBlockIsFreeFlag);
end;
end
else
begin
{$endif}
{Check the sequential feed medium block pool for space}
LSequentialFeedFreeSize := MediumSequentialFeedBytesLeft;
if LSequentialFeedFreeSize >= LPSmallBlockType.MinimumBlockPoolSize then
begin
{Enough sequential feed space: Will the remainder be usable?}
if LSequentialFeedFreeSize >= (LPSmallBlockType.OptimalBlockPoolSize + MinimumMediumBlockSize) then
begin
LBlockSize := LPSmallBlockType.OptimalBlockPoolSize;
end
else
LBlockSize := LSequentialFeedFreeSize;
{Get the block}
LMediumBlock := Pointer(Cardinal(LastSequentiallyFedMediumBlock) - LBlockSize);
{Update the sequential feed parameters}
LastSequentiallyFedMediumBlock := LMediumBlock;
MediumSequentialFeedBytesLeft := LSequentialFeedFreeSize - LBlockSize;
end
else
begin
{Need to allocate a new sequential feed medium block pool: use the
optimal size for this small block pool}
LBlockSize := LPSmallBlockType.OptimalBlockPoolSize;
{Allocate the medium block pool}
LMediumBlock := AllocNewSequentialFeedMediumPool(LBlockSize);
if LMediumBlock = nil then
begin
{Out of memory}
{Unlock the medium blocks}
MediumBlocksLocked := False;
{Unlock the block type}
LPSmallBlockType.BlockTypeLocked := False;
{Failed}
Result := nil;
{done}
exit;
end;
end;
{$ifndef FullDebugMode}
end;
{$endif}
{Mark this block as in use}
{Set the size and flags for this block}
PCardinal(Cardinal(LMediumBlock) - BlockHeaderSize)^ := LBlockSize or IsMediumBlockFlag or IsSmallBlockPoolInUseFlag;
{Unlock medium blocks}
MediumBlocksLocked := False;
{Set up the block pool}
LPSmallBlockPool := PSmallBlockPoolHeader(LMediumBlock);
LPSmallBlockPool.BlockType := LPSmallBlockType;
LPSmallBlockPool.FirstFreeBlock := nil;
LPSmallBlockPool.BlocksInUse := 1;
{Set it up for sequential block serving}
LPSmallBlockType.CurrentSequentialFeedPool := LPSmallBlockPool;
Result := Pointer(Cardinal(LPSmallBlockPool) + SmallBlockPoolHeaderSize);
LPSmallBlockType.NextSequentialFeedBlockAddress := Pointer(Cardinal(Result) + LPSmallBlockType.BlockSize);
LPSmallBlockType.MaxSequentialFeedBlockAddress := Pointer(Cardinal(LPSmallBlockPool) + LBlockSize - LPSmallBlockType.BlockSize);
end;
{$ifdef FullDebugMode}
{Clear the user area of the block}
FillDWord(Pointer(Cardinal(Result) + (SizeOf(TFullDebugBlockHeader) + 4))^,
LPSmallBlockType.BlockSize - FullDebugBlockOverhead - 4,
{$ifndef CatchUseOfFreedInterfaces}DebugFillDWord{$else}Cardinal(@VMTBadInterface){$endif});
{Block was fed sequentially - we need to set a valid debug header}
PFullDebugBlockHeader(Result).HeaderCheckSum := Cardinal(Result);
PCardinal(Cardinal(Result) + SizeOf(TFullDebugBlockHeader))^ := not Cardinal(Result);
{$endif}
end;
{Unlock the block type}
LPSmallBlockType.BlockTypeLocked := False;
{Set the block header}
PCardinal(Cardinal(Result) - BlockHeaderSize)^ := Cardinal(LPSmallBlockPool);
end
else
begin
{Medium block or Large block?}
if Cardinal(ASize) <= (MaximumMediumBlockSize - BlockHeaderSize) then
begin
{------------------------Allocate a medium block--------------------------}
{Get the block size and bin number for this block size. Block sizes are
rounded up to the next bin size.}
LBlockSize := ((Cardinal(ASize) + (MediumBlockGranularity - 1 + BlockHeaderSize - MediumBlockSizeOffset))
and -MediumBlockGranularity) + MediumBlockSizeOffset;
{Get the bin number}
LBinNumber := (LBlockSize - MinimumMediumBlockSize) div MediumBlockGranularity;
{Lock the medium blocks}
LockMediumBlocks;
{Calculate the bin group}
LBinGroupNumber := LBinNumber div 32;
{Is there a suitable block inside this group?}
LBinGroupMasked := MediumBlockBinBitmaps[LBinGroupNumber] and -(1 shl (LBinNumber and 31));
if LBinGroupMasked <> 0 then
begin
{Get the actual bin number}
LBinNumber := FindFirstSetBit(LBinGroupMasked) + LBinGroupNumber * 32;
end
else
begin
{$ifndef FullDebugMode}
{Try all groups greater than this group}
LBinGroupsMasked := MediumBlockBinGroupBitmap and -(2 shl LBinGroupNumber);
if LBinGroupsMasked <> 0 then
begin
{There is a suitable group with space: get the bin number}
LBinGroupNumber := FindFirstSetBit(LBinGroupsMasked);
{Get the bin in the group with free blocks}
LBinNumber := FindFirstSetBit(MediumBlockBinBitmaps[LBinGroupNumber])
+ LBinGroupNumber * 32;
end
else
begin
{$endif}
{There are no bins with a suitable block: Sequentially feed the required block}
LSequentialFeedFreeSize := MediumSequentialFeedBytesLeft;
if LSequentialFeedFreeSize >= LBlockSize then
begin
{$ifdef FullDebugMode}
{In full debug mode a medium block must have enough bytes to fit
all the debug info, so we must make sure there are no tiny medium
blocks at the start of the pool.}
if LSequentialFeedFreeSize - LBlockSize < (FullDebugBlockOverhead + BlockHeaderSize) then
LBlockSize := LSequentialFeedFreeSize;
{$endif}
{Block can be fed sequentially}
Result := Pointer(Cardinal(LastSequentiallyFedMediumBlock) - LBlockSize);
{Store the last sequentially fed block}
LastSequentiallyFedMediumBlock := Result;
{Store the remaining bytes}
MediumSequentialFeedBytesLeft := LSequentialFeedFreeSize - LBlockSize;
{Set the flags for the block}
PCardinal(Cardinal(Result) - BlockHeaderSize)^ := LBlockSize or IsMediumBlockFlag;
end
else
begin
{Need to allocate a new sequential feed block}
Result := AllocNewSequentialFeedMediumPool(LBlockSize);
end;
{$ifdef FullDebugMode}
{Block was fed sequentially - we need to set a valid debug header}
if Result <> nil then
begin
PFullDebugBlockHeader(Result).HeaderCheckSum := Cardinal(Result);
PCardinal(Cardinal(Result) + SizeOf(TFullDebugBlockHeader))^ := not Cardinal(Result);
{Clear the user area of the block}
FillDWord(Pointer(Cardinal(Result) + SizeOf(TFullDebugBlockHeader) + 4)^,
LBlockSize - FullDebugBlockOverhead - 4,
{$ifndef CatchUseOfFreedInterfaces}DebugFillDWord{$else}Cardinal(@VMTBadInterface){$endif});
end;
{$endif}
{Done}
MediumBlocksLocked := False;
exit;
{$ifndef FullDebugMode}
end;
{$endif}
end;
{If we get here we have a valid LBinGroupNumber and LBinNumber:
Use the first block in the bin, splitting it if necessary}
{Get a pointer to the bin}
LPMediumBin := @MediumBlockBins[LBinNumber];
{Get the result}
Result := LPMediumBin.NextFreeBlock;
{$ifdef CheckHeapForCorruption}
{Check that this block is actually free and the next and previous blocks
are both in use (except in full debug mode).}
if ((PCardinal(Cardinal(Result) - BlockHeaderSize)^ and {$ifndef FullDebugMode}ExtractMediumAndLargeFlagsMask{$else}(IsMediumBlockFlag or IsFreeBlockFlag){$endif}) <> (IsFreeBlockFlag or IsMediumBlockFlag))
{$ifndef FullDebugMode}
or ((PCardinal(Cardinal(Result) + (PCardinal(Cardinal(Result) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask) - BlockHeaderSize)^ and (ExtractMediumAndLargeFlagsMask - IsSmallBlockPoolInUseFlag)) <> (IsMediumBlockFlag or PreviousMediumBlockIsFreeFlag))
{$endif}
then
begin
{$ifdef BCB6OrDelphi7AndUp}
System.Error(reInvalidPtr);
{$else}
System.RunError(reInvalidPtr);
{$endif}
end;
{$endif}
{Remove the block from the bin containing it}
RemoveMediumFreeBlock(Result);
{Get the block size}
LAvailableBlockSize := PCardinal(Cardinal(Result) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask;
{$ifndef FullDebugMode}
{Is it an exact fit or not?}
LSecondSplitSize := LAvailableBlockSize - LBlockSize;
if LSecondSplitSize <> 0 then
begin
{Split the block in two}
LSecondSplit := PMediumFreeBlock(Cardinal(Result) + LBlockSize);
{Set the size of the second split}
PCardinal(Cardinal(LSecondSplit) - BlockHeaderSize)^ := LSecondSplitSize or (IsMediumBlockFlag or IsFreeBlockFlag);
{Store the size of the second split as the second last dword}
PCardinal(Cardinal(LSecondSplit) + LSecondSplitSize - 8)^ := LSecondSplitSize;
{Put the remainder in a bin if it is big enough}
if LSecondSplitSize >= MinimumMediumBlockSize then
InsertMediumBlockIntoBin(LSecondSplit, LSecondSplitSize);
end
else
begin
{$else}
{In full debug mode blocks are never split or coalesced}
LBlockSize := LAvailableBlockSize;
{$endif}
{Mark this block as used in the block following it}
LNextMediumBlockHeader := Pointer(Cardinal(Result) + LBlockSize - BlockHeaderSize);
{$ifndef FullDebugMode}
{$ifdef CheckHeapForCorruption}
{The next block must be in use}
if (LNextMediumBlockHeader^ and (ExtractMediumAndLargeFlagsMask - IsSmallBlockPoolInUseFlag)) <> (IsMediumBlockFlag or PreviousMediumBlockIsFreeFlag) then
{$ifdef BCB6OrDelphi7AndUp}
System.Error(reInvalidPtr);
{$else}
System.RunError(reInvalidPtr);
{$endif}
{$endif}
{$endif}
LNextMediumBlockHeader^ :=
LNextMediumBlockHeader^ and (not PreviousMediumBlockIsFreeFlag);
{$ifndef FullDebugMode}
end;
{Set the size and flags for this block}
PCardinal(Cardinal(Result) - BlockHeaderSize)^ := LBlockSize or IsMediumBlockFlag;
{$else}
{In full debug mode blocks are never split or coalesced}
Dec(PCardinal(Cardinal(Result) - BlockHeaderSize)^, IsFreeBlockFlag);
{$endif}
{Unlock the medium blocks}
MediumBlocksLocked := False;
end
else
begin
{Allocate a Large block}
if ASize > 0 then
Result := AllocateLargeBlock(ASize)
else
Result := nil;
end;
end;
end;
{$else}
{Replacement for SysGetMem (asm version)}
function FastGetMem(ASize: Integer): Pointer;
asm
{On entry:
eax = ASize}
{Since most allocations are for small blocks, determine the small block type
index so long}
lea edx, [eax + BlockHeaderSize - 1]
{$ifdef Align16Bytes}
shr edx, 4
{$else}
shr edx, 3
{$endif}
{Is it a small block?}
cmp eax, (MaximumSmallBlockSize - BlockHeaderSize)
{Save ebx}
push ebx
{Get the IsMultiThread variable so long}
{$ifndef AssumeMultiThreaded}
mov cl, IsMultiThread
{$endif}
{Is it a small block?}
ja @NotASmallBlock
{Do we need to lock the block type?}
{$ifndef AssumeMultiThreaded}
test cl, cl
{$endif}
{Get the small block type in ebx}
movzx eax, byte ptr [AllocSize2SmallBlockTypeIndX4 + edx]
lea ebx, [SmallBlockTypes + eax * 8]
{Do we need to lock the block type?}
{$ifndef AssumeMultiThreaded}
jnz @LockBlockTypeLoop
{$else}
jmp @LockBlockTypeLoop
{Align branch target}
nop
nop
{$endif}
@GotLockOnSmallBlockType:
{Find the next free block: Get the first pool with free blocks in edx}
mov edx, TSmallBlockType[ebx].NextPartiallyFreePool
{Get the first free block (or the next sequential feed address if edx = ebx)}
mov eax, TSmallBlockPoolHeader[edx].FirstFreeBlock
{Get the drop flags mask in ecx so long}
mov ecx, DropSmallFlagsMask
{Is there a pool with free blocks?}
cmp edx, ebx
je @TrySmallSequentialFeed
{Increment the number of used blocks}
add TSmallBlockPoolHeader[edx].BlocksInUse, 1
{Get the new first free block}
and ecx, [eax - 4]
{Set the new first free block}
mov TSmallBlockPoolHeader[edx].FirstFreeBlock, ecx
{Set the block header}
mov [eax - 4], edx
{Is the chunk now full?}
jz @RemoveSmallPool
{Unlock the block type}
mov TSmallBlockType[ebx].BlockTypeLocked, False
{Restore ebx}
pop ebx
{All done}
ret
{Align branch target}
{$ifndef AssumeMultiThreaded}
nop
nop
{$endif}
nop
@TrySmallSequentialFeed:
{Try to feed a small block sequentially: Get the sequential feed block pool}
mov edx, TSmallBlockType[ebx].CurrentSequentialFeedPool
{Get the next sequential feed address so long}
movzx ecx, TSmallBlockType[ebx].BlockSize
add ecx, eax
{Can another block fit?}
cmp eax, TSmallBlockType[ebx].MaxSequentialFeedBlockAddress
{Can another block fit?}
ja @AllocateSmallBlockPool
{Increment the number of used blocks in the sequential feed pool}
add TSmallBlockPoolHeader[edx].BlocksInUse, 1
{Store the next sequential feed block address}
mov TSmallBlockType[ebx].NextSequentialFeedBlockAddress, ecx
{Unlock the block type}
mov TSmallBlockType[ebx].BlockTypeLocked, False
{Set the block header}
mov [eax - 4], edx
{Restore ebx}
pop ebx
{All done}
ret
{Align branch target}
nop
nop
nop
@RemoveSmallPool:
{Pool is full - remove it from the partially free list}
mov ecx, TSmallBlockPoolHeader[edx].NextPartiallyFreePool
mov TSmallBlockPoolHeader[ecx].PreviousPartiallyFreePool, ebx
mov TSmallBlockType[ebx].NextPartiallyFreePool, ecx
{Unlock the block type}
mov TSmallBlockType[ebx].BlockTypeLocked, False
{Restore ebx}
pop ebx
{All done}
ret
{Align branch target}
nop
nop
@LockBlockTypeLoop:
mov eax, $100
{Attempt to grab the block type}
lock cmpxchg TSmallBlockType([ebx]).BlockTypeLocked, ah
je @GotLockOnSmallBlockType
{Try the next size}
add ebx, Type(TSmallBlockType)
mov eax, $100
lock cmpxchg TSmallBlockType([ebx]).BlockTypeLocked, ah
je @GotLockOnSmallBlockType
{Try the next size (up to two sizes larger)}
add ebx, Type(TSmallBlockType)
mov eax, $100
lock cmpxchg TSmallBlockType([ebx]).BlockTypeLocked, ah
je @GotLockOnSmallBlockType
{Block type and two sizes larger are all locked - give up and sleep}
sub ebx, 2 * Type(TSmallBlockType)
{Couldn't grab the block type - sleep and try again}
push InitialSleepTime
call Sleep
{Try again}
mov eax, $100
{Attempt to grab the block type}
lock cmpxchg TSmallBlockType([ebx]).BlockTypeLocked, ah
je @GotLockOnSmallBlockType
{Couldn't grab the block type - sleep and try again}
push AdditionalSleepTime
call Sleep
{Try again}
jmp @LockBlockTypeLoop
{Align branch target}
nop
nop
nop
@AllocateSmallBlockPool:
{save additional registers}
push esi
push edi
{Do we need to lock the medium blocks?}
{$ifndef AssumeMultiThreaded}
cmp IsMultiThread, False
je @MediumBlocksLockedForPool
{$endif}
@LockMediumBlocksForPool:
mov eax, $100
{Attempt to lock the medium blocks}
lock cmpxchg MediumBlocksLocked, ah
je @MediumBlocksLockedForPool
{Couldn't lock the medium blocks - sleep and try again}
push InitialSleepTime
call Sleep
{Try again}
mov eax, $100
{Attempt to grab the block type}
lock cmpxchg MediumBlocksLocked, ah
je @MediumBlocksLockedForPool
{Couldn't lock the medium blocks - sleep and try again}
push AdditionalSleepTime
call Sleep
{Try again}
jmp @LockMediumBlocksForPool
{Align branch target}
{$ifndef AssumeMultiThreaded}
nop
nop
nop
{$endif}
@MediumBlocksLockedForPool:
{Are there any available blocks of a suitable size?}
movsx esi, TSmallBlockType[ebx].AllowedGroupsForBlockPoolBitmap
and esi, MediumBlockBinGroupBitmap
jz @NoSuitableMediumBlocks
{Get the bin group number with free blocks in eax}
bsf eax, esi
{Get the bin number in ecx}
lea esi, [eax * 8]
mov ecx, dword ptr [MediumBlockBinBitmaps + eax * 4]
bsf ecx, ecx
lea ecx, [ecx + esi * 4]
{Get a pointer to the bin in edi}
lea edi, [MediumBlockBins + ecx * 8]
{Get the free block in esi}
mov esi, TMediumFreeBlock[edi].NextFreeBlock
{Remove the first block from the linked list (LIFO)}
mov edx, TMediumFreeBlock[esi].NextFreeBlock
mov TMediumFreeBlock[edi].NextFreeBlock, edx
mov TMediumFreeBlock[edx].PreviousFreeBlock, edi
{Is this bin now empty?}
cmp edi, edx
jne @MediumBinNotEmpty
{eax = bin group number, ecx = bin number, edi = @bin, esi = free block, ebx = block type}
{Flag this bin as empty}
mov edx, -2
rol edx, cl
and dword ptr [MediumBlockBinBitmaps + eax * 4], edx
jnz @MediumBinNotEmpty
{Flag the group as empty}
btr MediumBlockBinGroupBitmap, eax
@MediumBinNotEmpty:
{esi = free block, ebx = block type}
{Get the size of the available medium block in edi}
mov edi, DropMediumAndLargeFlagsMask
and edi, [esi - 4]
cmp edi, MaximumSmallBlockPoolSize
jb @UseWholeBlock
{Split the block: get the size of the second part, new block size is the
optimal size}
mov edx, edi
movzx edi, TSmallBlockType[ebx].OptimalBlockPoolSize
sub edx, edi
{Split the block in two}
lea eax, [esi + edi]
lea ecx, [edx + IsMediumBlockFlag + IsFreeBlockFlag]
mov [eax - 4], ecx
{Store the size of the second split as the second last dword}
mov [eax + edx - 8], edx
{Put the remainder in a bin (it will be big enough)}
call InsertMediumBlockIntoBin
jmp @GotMediumBlock
{Align branch target}
@NoSuitableMediumBlocks:
{Check the sequential feed medium block pool for space}
movzx ecx, TSmallBlockType[ebx].MinimumBlockPoolSize
mov edi, MediumSequentialFeedBytesLeft
cmp edi, ecx
jb @AllocateNewSequentialFeed
{Get the address of the last block that was fed}
mov esi, LastSequentiallyFedMediumBlock
{Enough sequential feed space: Will the remainder be usable?}
movzx ecx, TSmallBlockType[ebx].OptimalBlockPoolSize
lea edx, [ecx + MinimumMediumBlockSize]
cmp edi, edx
jb @NotMuchSpace
mov edi, ecx
@NotMuchSpace:
sub esi, edi
{Update the sequential feed parameters}
sub MediumSequentialFeedBytesLeft, edi
mov LastSequentiallyFedMediumBlock, esi
{Get the block pointer}
jmp @GotMediumBlock
{Align branch target}
@AllocateNewSequentialFeed:
{Need to allocate a new sequential feed medium block pool: use the
optimal size for this small block pool}
movzx eax, TSmallBlockType[ebx].OptimalBlockPoolSize
mov edi, eax
{Allocate the medium block pool}
call AllocNewSequentialFeedMediumPool
mov esi, eax
test eax, eax
jnz @GotMediumBlock
mov MediumBlocksLocked, al
mov TSmallBlockType[ebx].BlockTypeLocked, al
pop edi
pop esi
pop ebx
ret
{Align branch target}
@UseWholeBlock:
{esi = free block, ebx = block type, edi = block size}
{Mark this block as used in the block following it}
and byte ptr [esi + edi - 4], not PreviousMediumBlockIsFreeFlag
@GotMediumBlock:
{esi = free block, ebx = block type, edi = block size}
{Set the size and flags for this block}
lea ecx, [edi + IsMediumBlockFlag + IsSmallBlockPoolInUseFlag]
mov [esi - 4], ecx
{Unlock medium blocks}
xor eax, eax
mov MediumBlocksLocked, al
{Set up the block pool}
mov TSmallBlockPoolHeader[esi].BlockType, ebx
mov TSmallBlockPoolHeader[esi].FirstFreeBlock, eax
mov TSmallBlockPoolHeader[esi].BlocksInUse, 1
{Set it up for sequential block serving}
mov TSmallBlockType[ebx].CurrentSequentialFeedPool, esi
{Return the pointer to the first block}
lea eax, [esi + SmallBlockPoolHeaderSize]
movzx ecx, TSmallBlockType[ebx].BlockSize
lea edx, [eax + ecx]
mov TSmallBlockType[ebx].NextSequentialFeedBlockAddress, edx
add edi, esi
sub edi, ecx
mov TSmallBlockType[ebx].MaxSequentialFeedBlockAddress, edi
{Unlock the small block type}
mov TSmallBlockType[ebx].BlockTypeLocked, False
{Set the small block header}
mov [eax - 4], esi
{Restore registers}
pop edi
pop esi
pop ebx
{Done}
ret
{-------------------Medium block allocation-------------------}
{Align branch target}
nop
@LockMediumBlocks:
mov eax, $100
{Attempt to lock the medium blocks}
lock cmpxchg MediumBlocksLocked, ah
je @MediumBlocksLocked
{Couldn't lock the medium blocks - sleep and try again}
push InitialSleepTime
call Sleep
{Try again}
mov eax, $100
{Attempt to lock the medium blocks}
lock cmpxchg MediumBlocksLocked, ah
je @MediumBlocksLocked
{Couldn't lock the medium blocks - sleep and try again}
push AdditionalSleepTime
call Sleep
{Try again}
jmp @LockMediumBlocks
{Align branch target}
nop
nop
@NotASmallBlock:
cmp eax, (MaximumMediumBlockSize - BlockHeaderSize)
ja @IsALargeBlockRequest
{Get the bin size for this block size. Block sizes are
rounded up to the next bin size.}
lea ebx, [eax + MediumBlockGranularity - 1 + BlockHeaderSize - MediumBlockSizeOffset]
and ebx, -MediumBlockGranularity
add ebx, MediumBlockSizeOffset
{Do we need to lock the medium blocks?}
{$ifndef AssumeMultiThreaded}
test cl, cl
jnz @LockMediumBlocks
{$else}
jmp @LockMediumBlocks
{Align branch target}
{$endif}
@MediumBlocksLocked:
{Get the bin number in ecx and the group number in edx}
lea edx, [ebx - MinimumMediumBlockSize]
mov ecx, edx
shr edx, 8 + 5
shr ecx, 8
{Is there a suitable block inside this group?}
mov eax, -1
shl eax, cl
and eax, dword ptr [MediumBlockBinBitmaps + edx * 4]
jz @GroupIsEmpty
{Get the actual bin number}
and ecx, -32
bsf eax, eax
or ecx, eax
jmp @GotBinAndGroup
{Align branch target}
{$ifndef AssumeMultiThreaded}
nop
nop
{$endif}
@GroupIsEmpty:
{Try all groups greater than this group}
mov eax, -2
mov ecx, edx
shl eax, cl
and eax, MediumBlockBinGroupBitmap
jz @TrySequentialFeedMedium
{There is a suitable group with space: get the bin number}
bsf edx, eax
{Get the bin in the group with free blocks}
mov eax, dword ptr [MediumBlockBinBitmaps + edx * 4]
bsf ecx, eax
mov eax, edx
shl eax, 5
or ecx, eax
jmp @GotBinAndGroup
{Align branch target}
nop
@TrySequentialFeedMedium:
mov ecx, MediumSequentialFeedBytesLeft
{Block can be fed sequentially?}
sub ecx, ebx
jc @AllocateNewSequentialFeedForMedium
{Get the block address}
mov eax, LastSequentiallyFedMediumBlock
sub eax, ebx
mov LastSequentiallyFedMediumBlock, eax
{Store the remaining bytes}
mov MediumSequentialFeedBytesLeft, ecx
{Set the flags for the block}
or ebx, IsMediumBlockFlag
mov [eax - 4], ebx
jmp @MediumBlockGetDone
{Align branch target}
@AllocateNewSequentialFeedForMedium:
mov eax, ebx
call AllocNewSequentialFeedMediumPool
@MediumBlockGetDone:
mov MediumBlocksLocked, False
pop ebx
ret
{Align branch target}
@GotBinAndGroup:
{ebx = block size, ecx = bin number, edx = group number}
push esi
push edi
{Get a pointer to the bin in edi}
lea edi, [MediumBlockBins + ecx * 8]
{Get the free block in esi}
mov esi, TMediumFreeBlock[edi].NextFreeBlock
{Remove the first block from the linked list (LIFO)}
mov eax, TMediumFreeBlock[esi].NextFreeBlock
mov TMediumFreeBlock[edi].NextFreeBlock, eax
mov TMediumFreeBlock[eax].PreviousFreeBlock, edi
{Is this bin now empty?}
cmp edi, eax
jne @MediumBinNotEmptyForMedium
{eax = bin group number, ecx = bin number, edi = @bin, esi = free block, ebx = block size}
{Flag this bin as empty}
mov eax, -2
rol eax, cl
and dword ptr [MediumBlockBinBitmaps + edx * 4], eax
jnz @MediumBinNotEmptyForMedium
{Flag the group as empty}
btr MediumBlockBinGroupBitmap, edx
@MediumBinNotEmptyForMedium:
{esi = free block, ebx = block size}
{Get the size of the available medium block in edi}
mov edi, DropMediumAndLargeFlagsMask
and edi, [esi - 4]
{Get the size of the second split in edx}
mov edx, edi
sub edx, ebx
jz @UseWholeBlockForMedium
{Split the block in two}
lea eax, [esi + ebx]
lea ecx, [edx + IsMediumBlockFlag + IsFreeBlockFlag]
mov [eax - 4], ecx
{Store the size of the second split as the second last dword}
mov [eax + edx - 8], edx
{Put the remainder in a bin}
cmp edx, MinimumMediumBlockSize
jb @GotMediumBlockForMedium
call InsertMediumBlockIntoBin
jmp @GotMediumBlockForMedium
{Align branch target}
nop
nop
nop
@UseWholeBlockForMedium:
{Mark this block as used in the block following it}
and byte ptr [esi + edi - 4], not PreviousMediumBlockIsFreeFlag
@GotMediumBlockForMedium:
{Set the size and flags for this block}
lea ecx, [ebx + IsMediumBlockFlag]
mov [esi - 4], ecx
{Unlock medium blocks}
mov MediumBlocksLocked, False
mov eax, esi
pop edi
pop esi
pop ebx
ret
{-------------------Large block allocation-------------------}
{Align branch target}
@IsALargeBlockRequest:
pop ebx
test eax, eax
jns AllocateLargeBlock
xor eax, eax
end;
{$endif}
{$ifndef ASMVersion}
{Replacement for SysFreeMem (pascal version)}
function FastFreeMem(APointer: Pointer): Integer;
var
LNextMediumBlock{$ifndef FullDebugMode}, LPreviousMediumBlock{$endif}: PMediumFreeBlock;
LNextMediumBlockSizeAndFlags: Cardinal;
LBlockSize{$ifndef FullDebugMode}, LPreviousMediumBlockSize{$endif}: Cardinal;
LPSmallBlockPool{$ifndef FullDebugMode}, LPPreviousPool, LPNextPool{$endif},
LPOldFirstPool: PSmallBlockPoolHeader;
LPSmallBlockType: PSmallBlockType;
LOldFirstFreeBlock: Pointer;
LBlockHeader: Cardinal;
{$ifndef FullDebugMode}
LPPreviousMediumBlockPoolHeader, LPNextMediumBlockPoolHeader: PMediumBlockPoolHeader;
{$endif}
begin
{Get the small block header: Is it actually a small block?}
LBlockHeader := PCardinal(Cardinal(APointer) - BlockHeaderSize)^;
{Is it a small block that is in use?}
if LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag or IsLargeBlockFlag) = 0 then
begin
{Get a pointer to the block pool}
LPSmallBlockPool := PSmallBlockPoolHeader(LBlockHeader);
{Get the block type}
LPSmallBlockType := LPSmallBlockPool.BlockType;
{Lock the block type}
{$ifndef AssumeMultiThreaded}
if IsMultiThread then
{$endif}
begin
while (LockCmpxchg(0, 1, @LPSmallBlockType.BlockTypeLocked) <> 0) do
begin
Sleep(InitialSleepTime);
if LockCmpxchg(0, 1, @LPSmallBlockType.BlockTypeLocked) = 0 then
break;
Sleep(AdditionalSleepTime);
end;
end;
{Get the old first free block}
LOldFirstFreeBlock := LPSmallBlockPool.FirstFreeBlock;
{Was the pool manager previously full?}
if LOldFirstFreeBlock = nil then
begin
{Insert this as the first partially free pool for the block size}
LPOldFirstPool := LPSmallBlockType.NextPartiallyFreePool;
LPSmallBlockPool.NextPartiallyFreePool := LPOldFirstPool;
LPOldFirstPool.PreviousPartiallyFreePool := LPSmallBlockPool;
LPSmallBlockPool.PreviousPartiallyFreePool := PSmallBlockPoolHeader(LPSmallBlockType);
LPSmallBlockType.NextPartiallyFreePool := LPSmallBlockPool;
end;
{Store the old first free block}
PCardinal(Cardinal(APointer) - BlockHeaderSize)^ := Cardinal(LOldFirstFreeBlock) or IsFreeBlockFlag;
{Store this as the new first free block}
LPSmallBlockPool.FirstFreeBlock := APointer;
{Decrement the number of allocated blocks}
Dec(LPSmallBlockPool.BlocksInUse);
{Small block pools are never freed in full debug mode. This increases the
likehood of success in catching objects still being used after being
destroyed.}
{$ifndef FullDebugMode}
{Is the entire pool now free? -> Free it.}
if LPSmallBlockPool.BlocksInUse = 0 then
begin
{Get the previous and next chunk managers}
LPPreviousPool := LPSmallBlockPool.PreviousPartiallyFreePool;
LPNextPool := LPSmallBlockPool.NextPartiallyFreePool;
{Remove this manager}
LPPreviousPool.NextPartiallyFreePool := LPNextPool;
LPNextPool.PreviousPartiallyFreePool := LPPreviousPool;
{Is this the sequential feed pool? If so, stop sequential feeding}
if (LPSmallBlockType.CurrentSequentialFeedPool = LPSmallBlockPool) then
LPSmallBlockType.MaxSequentialFeedBlockAddress := nil;
{Unlock this block type}
LPSmallBlockType.BlockTypeLocked := False;
{No longer a small block pool in use (the flag must be reset in the
pascal version, since IsSmallBlockPoolInUseFlag = IsLargeBlockFlag)}
PCardinal(Cardinal(LPSmallBlockPool) - 4)^ := PCardinal(Cardinal(LPSmallBlockPool) - 4)^ and (not IsSmallBlockPoolInUseFlag);
{Release this pool}
FastFreeMem(LPSmallBlockPool);
end
else
begin
{$endif}
{Unlock this block type}
LPSmallBlockType.BlockTypeLocked := False;
{$ifndef FullDebugMode}
end;
{$endif}
{No error}
Result := 0;
end
else
begin
{Is this a medium block or a large block?}
if LBlockHeader and (IsFreeBlockFlag or IsLargeBlockFlag) = 0 then
begin
{Get the medium block size}
LBlockSize := LBlockHeader and DropMediumAndLargeFlagsMask;
{Lock the medium blocks}
LockMediumBlocks;
{Can we combine this block with the next free block?}
LNextMediumBlock := PMediumFreeBlock(Cardinal(APointer) + LBlockSize);
LNextMediumBlockSizeAndFlags := PCardinal(Cardinal(LNextMediumBlock) - BlockHeaderSize)^;
{$ifndef FullDebugMode}
{$ifdef CheckHeapForCorruption}
{Check that this block was flagged as in use in the next block}
if (LNextMediumBlockSizeAndFlags and PreviousMediumBlockIsFreeFlag) <> 0 then
{$ifdef BCB6OrDelphi7AndUp}
System.Error(reInvalidPtr);
{$else}
System.RunError(reInvalidPtr);
{$endif}
{$endif}
if (LNextMediumBlockSizeAndFlags and IsFreeBlockFlag) <> 0 then
begin
{Increase the size of this block}
Inc(LBlockSize, LNextMediumBlockSizeAndFlags and DropMediumAndLargeFlagsMask);
{Remove the next block as well}
if LNextMediumBlockSizeAndFlags >= MinimumMediumBlockSize then
RemoveMediumFreeBlock(LNextMediumBlock);
end
else
begin
{$endif}
{Reset the "previous in use" flag of the next block}
PCardinal(Cardinal(LNextMediumBlock) - BlockHeaderSize)^ := LNextMediumBlockSizeAndFlags or PreviousMediumBlockIsFreeFlag;
{$ifndef FullDebugMode}
end;
{Can we combine this block with the previous free block? We need to
re-read the flags since it could have changed before we could lock the
medium blocks.}
if (PCardinal(Cardinal(APointer) - BlockHeaderSize)^ and PreviousMediumBlockIsFreeFlag) <> 0 then
begin
{Get the size of the free block just before this one}
LPreviousMediumBlockSize := PCardinal(Cardinal(APointer) - 8)^;
{Get the start of the previous block}
LPreviousMediumBlock := PMediumFreeBlock(Cardinal(APointer) - LPreviousMediumBlockSize);
{$ifdef CheckHeapForCorruption}
{Check that the previous block is actually free}
if (PCardinal(Cardinal(LPreviousMediumBlock) - BlockHeaderSize)^ and ExtractMediumAndLargeFlagsMask) <> (IsMediumBlockFlag or IsFreeBlockFlag) then
{$ifdef BCB6OrDelphi7AndUp}
System.Error(reInvalidPtr);
{$else}
System.RunError(reInvalidPtr);
{$endif}
{$endif}
{Set the new block size}
Inc(LBlockSize, LPreviousMediumBlockSize);
{This is the new current block}
APointer := LPreviousMediumBlock;
{Remove the previous block from the linked list}
if LPreviousMediumBlockSize >= MinimumMediumBlockSize then
RemoveMediumFreeBlock(LPreviousMediumBlock);
end;
{$ifdef CheckHeapForCorruption}
{Check that the previous block is currently flagged as in use}
if (PCardinal(Cardinal(APointer) - BlockHeaderSize)^ and PreviousMediumBlockIsFreeFlag) <> 0 then
{$ifdef BCB6OrDelphi7AndUp}
System.Error(reInvalidPtr);
{$else}
System.RunError(reInvalidPtr);
{$endif}
{$endif}
{Is the entire medium block pool free, and there are other free blocks
that can fit the largest possible medium block? -> free it. (Except in
full debug mode where medium pools are never freed.)}
if (LBlockSize <> (MediumBlockPoolSize - MediumBlockPoolHeaderSize)) then
begin
{Store the size of the block as well as the flags}
PCardinal(Cardinal(APointer) - BlockHeaderSize)^ := LBlockSize or (IsMediumBlockFlag or IsFreeBlockFlag);
{$else}
{Mark the block as free}
Inc(PCardinal(Cardinal(APointer) - BlockHeaderSize)^, IsFreeBlockFlag);
{$endif}
{Store the trailing size marker}
PCardinal(Cardinal(APointer) + LBlockSize - 8)^ := LBlockSize;
{Insert this block back into the bins: Size check not required here,
since medium blocks that are in use are not allowed to be
shrunk smaller than MinimumMediumBlockSize}
InsertMediumBlockIntoBin(APointer, LBlockSize);
{$ifndef FullDebugMode}
{$ifdef CheckHeapForCorruption}
{Check that this block is actually free and the next and previous blocks are both in use.}
if ((PCardinal(Cardinal(APointer) - BlockHeaderSize)^ and ExtractMediumAndLargeFlagsMask) <> (IsMediumBlockFlag or IsFreeBlockFlag))
or ((PCardinal(Cardinal(APointer) + (PCardinal(Cardinal(APointer) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask) - BlockHeaderSize)^ and IsFreeBlockFlag) <> 0) then
begin
{$ifdef BCB6OrDelphi7AndUp}
System.Error(reInvalidPtr);
{$else}
System.RunError(reInvalidPtr);
{$endif}
end;
{$endif}
{$endif}
{Unlock medium blocks}
MediumBlocksLocked := False;
{All OK}
Result := 0;
{$ifndef FullDebugMode}
end
else
begin
{Should this become the new sequential feed?}
if MediumSequentialFeedBytesLeft <> MediumBlockPoolSize - MediumBlockPoolHeaderSize then
begin
{Bin the current sequential feed}
BinMediumSequentialFeedRemainder;
{Set this medium pool up as the new sequential feed pool:
Store the sequential feed pool trailer}
PCardinal(Cardinal(APointer) + LBlockSize - BlockHeaderSize)^ := IsMediumBlockFlag;
{Store the number of bytes available in the sequential feed chunk}
MediumSequentialFeedBytesLeft := MediumBlockPoolSize - MediumBlockPoolHeaderSize;
{Set the last sequentially fed block}
LastSequentiallyFedMediumBlock := Pointer(Cardinal(APointer) + LBlockSize);
{Unlock medium blocks}
MediumBlocksLocked := False;
{Success}
Result := 0;
end
else
begin
{Remove this medium block pool from the linked list}
Dec(Cardinal(APointer), MediumBlockPoolHeaderSize);
LPPreviousMediumBlockPoolHeader := PMediumBlockPoolHeader(APointer).PreviousMediumBlockPoolHeader;
LPNextMediumBlockPoolHeader := PMediumBlockPoolHeader(APointer).NextMediumBlockPoolHeader;
LPPreviousMediumBlockPoolHeader.NextMediumBlockPoolHeader := LPNextMediumBlockPoolHeader;
LPNextMediumBlockPoolHeader.PreviousMediumBlockPoolHeader := LPPreviousMediumBlockPoolHeader;
{Unlock medium blocks}
MediumBlocksLocked := False;
{Free the medium block pool}
if VirtualFree(APointer, 0, MEM_RELEASE) then
Result := 0
else
Result := -1;
end;
end;
{$endif}
end
else
begin
{Validate: Is this actually a Large block, or is it an attempt to free an
already freed small block?}
if LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag) = 0 then
Result := FreeLargeBlock(APointer)
else
Result := -1;
end;
end;
end;
{$else}
{Replacement for SysFreeMem (pascal version)}
function FastFreeMem(APointer: Pointer): Integer;
asm
{Get the block header in edx}
mov edx, [eax - 4]
{Is it a small block in use?}
test dl, IsFreeBlockFlag + IsMediumBlockFlag + IsLargeBlockFlag
{Save the pointer in ecx}
mov ecx, eax
{Save ebx}
push ebx
{Get the IsMultiThread variable in bl}
{$ifndef AssumeMultiThreaded}
mov bl, IsMultiThread
{$endif}
{Is it a small block that is in use?}
jnz @NotSmallBlockInUse
{Do we need to lock the block type?}
{$ifndef AssumeMultiThreaded}
test bl, bl
{$endif}
{Get the small block type in ebx}
mov ebx, TSmallBlockPoolHeader[edx].BlockType
{Do we need to lock the block type?}
{$ifndef AssumeMultiThreaded}
jnz @LockBlockTypeLoop
{$else}
jmp @LockBlockTypeLoop
{Align branch target}
nop
{$endif}
@GotLockOnSmallBlockType:
{Current state: edx = @SmallBlockPoolHeader, ecx = APointer, ebx = @SmallBlockType}
{Decrement the number of blocks in use}
sub TSmallBlockPoolHeader[edx].BlocksInUse, 1
{Get the old first free block}
mov eax, TSmallBlockPoolHeader[edx].FirstFreeBlock
{Is the pool now empty?}
jz @PoolIsNowEmpty
{Was the pool full?}
test eax, eax
{Store this as the new first free block}
mov TSmallBlockPoolHeader[edx].FirstFreeBlock, ecx
{Store the previous first free block as the block header}
lea eax, [eax + IsFreeBlockFlag]
mov [ecx - 4], eax
{Insert the pool back into the linked list if it was full}
jz @SmallPoolWasFull
{All ok}
xor eax, eax
{Unlock the block type}
mov TSmallBlockType[ebx].BlockTypeLocked, al
{Restore registers}
pop ebx
{Done}
ret
{Align branch target}
{$ifndef AssumeMultiThreaded}
nop
{$endif}
@SmallPoolWasFull:
{Insert this as the first partially free pool for the block size}
mov ecx, TSmallBlockType[ebx].NextPartiallyFreePool
mov TSmallBlockPoolHeader[edx].PreviousPartiallyFreePool, ebx
mov TSmallBlockPoolHeader[edx].NextPartiallyFreePool, ecx
mov TSmallBlockPoolHeader[ecx].PreviousPartiallyFreePool, edx
mov TSmallBlockType[ebx].NextPartiallyFreePool, edx
{Unlock the block type}
mov TSmallBlockType[ebx].BlockTypeLocked, False
{All ok}
xor eax, eax
{Restore registers}
pop ebx
{Done}
ret
{Align branch target}
nop
nop
@PoolIsNowEmpty:
{Was this pool actually in the linked list of pools with space? If not, it
can only be the sequential feed pool (it is the only pool that may contain
only one block, i.e. other blocks have not been split off yet)}
test eax, eax
jz @IsSequentialFeedPool
{Pool is now empty: Remove it from the linked list and free it}
mov eax, TSmallBlockPoolHeader[edx].PreviousPartiallyFreePool
mov ecx, TSmallBlockPoolHeader[edx].NextPartiallyFreePool
{Remove this manager}
mov TSmallBlockPoolHeader[eax].NextPartiallyFreePool, ecx
mov TSmallBlockPoolHeader[ecx].PreviousPartiallyFreePool, eax
{Zero out eax}
xor eax, eax
{Is this the sequential feed pool? If so, stop sequential feeding}
cmp TSmallBlockType[ebx].CurrentSequentialFeedPool, edx
jne @NotSequentialFeedPool
@IsSequentialFeedPool:
mov TSmallBlockType[ebx].MaxSequentialFeedBlockAddress, eax
@NotSequentialFeedPool:
{Unlock the block type}
mov TSmallBlockType[ebx].BlockTypeLocked, al
{Release this pool}
mov eax, edx
mov edx, [edx - 4]
{$ifndef AssumeMultiThreaded}
mov bl, IsMultiThread
{$endif}
jmp @FreeMediumBlock
{Align branch target}
{$ifndef AssumeMultiThreaded}
nop
nop
{$endif}
nop
@LockBlockTypeLoop:
mov eax, $100
{Attempt to grab the block type}
lock cmpxchg TSmallBlockType([ebx]).BlockTypeLocked, ah
je @GotLockOnSmallBlockType
{Couldn't grab the block type - sleep and try again}
push ecx
push edx
push InitialSleepTime
call Sleep
pop edx
pop ecx
{Try again}
mov eax, $100
{Attempt to grab the block type}
lock cmpxchg TSmallBlockType([ebx]).BlockTypeLocked, ah
je @GotLockOnSmallBlockType
{Couldn't grab the block type - sleep and try again}
push ecx
push edx
push AdditionalSleepTime
call Sleep
pop edx
pop ecx
{Try again}
jmp @LockBlockTypeLoop
{Align branch target}
nop
nop
{---------------------Medium blocks------------------------------}
@LockMediumBlocks:
mov eax, $100
{Attempt to lock the medium blocks}
lock cmpxchg MediumBlocksLocked, ah
je @MediumBlocksLocked
{Couldn't lock the medium blocks - sleep and try again}
push InitialSleepTime
call Sleep
{Try again}
mov eax, $100
{Attempt to lock the medium blocks}
lock cmpxchg MediumBlocksLocked, ah
je @MediumBlocksLocked
{Couldn't lock the medium blocks - sleep and try again}
push AdditionalSleepTime
call Sleep
{Try again}
jmp @LockMediumBlocks
{Align branch target}
nop
nop
@NotSmallBlockInUse:
{Not a small block in use: is it a medium or large block?}
test dl, IsFreeBlockFlag + IsLargeBlockFlag
jnz @NotASmallOrMediumBlock
@FreeMediumBlock:
{Drop the flags}
and edx, DropMediumAndLargeFlagsMask
{Free the large block pointed to by eax, header in edx, bl = IsMultiThread}
{$ifndef AssumeMultiThreaded}
{Do we need to lock the medium blocks?}
test bl, bl
{$endif}
{Block size in ebx}
mov ebx, edx
{Save registers}
push esi
{Pointer in esi}
mov esi, eax
{Do we need to lock the medium blocks?}
{$ifndef AssumeMultiThreaded}
jnz @LockMediumBlocks
{$else}
jmp @LockMediumBlocks
{Align branch target}
nop
{$endif}
@MediumBlocksLocked:
{Can we combine this block with the next free block?}
test dword ptr [esi + ebx - 4], IsFreeBlockFlag
{Get the next block size and flags in ecx}
mov ecx, [esi + ebx - 4]
jnz @NextBlockIsFree
{Set the "PreviousIsFree" flag in the next block}
or ecx, PreviousMediumBlockIsFreeFlag
mov [esi + ebx - 4], ecx
@NextBlockChecked:
{Can we combine this block with the previous free block? We need to
re-read the flags since it could have changed before we could lock the
medium blocks.}
test byte ptr [esi - 4], PreviousMediumBlockIsFreeFlag
jnz @PreviousBlockIsFree
@PreviousBlockChecked:
{Is the entire medium block pool free, and there are other free blocks
that can fit the largest possible medium block -> free it.}
cmp ebx, (MediumBlockPoolSize - MediumBlockPoolHeaderSize)
je @EntireMediumPoolFree
@BinFreeMediumBlock:
{Store the size of the block as well as the flags}
lea eax, [ebx + IsMediumBlockFlag + IsFreeBlockFlag]
mov [esi - 4], eax
{Store the trailing size marker}
mov [esi + ebx - 8], ebx
{Insert this block back into the bins: Size check not required here,
since medium blocks that are in use are not allowed to be
shrunk smaller than MinimumMediumBlockSize}
mov eax, esi
mov edx, ebx
{Insert into bin}
call InsertMediumBlockIntoBin
{Unlock medium blocks}
mov MediumBlocksLocked, False;
{All OK}
xor eax, eax
{Restore registers}
pop esi
pop ebx
{Return}
ret
{Align branch target}
{$ifdef AssumeMultiThreaded}
nop
{$endif}
nop
@NextBlockIsFree:
{Get the next block address in eax}
lea eax, [esi + ebx]
{Increase the size of this block}
and ecx, DropMediumAndLargeFlagsMask
add ebx, ecx
{Was the block binned?}
cmp ecx, MinimumMediumBlockSize
jb @NextBlockChecked
call RemoveMediumFreeBlock
jmp @NextBlockChecked
{Align branch target}
nop
@PreviousBlockIsFree:
{Get the size of the free block just before this one}
mov ecx, [esi - 8]
{Include the previous block}
sub esi, ecx
{Set the new block size}
add ebx, ecx
{Remove the previous block from the linked list}
cmp ecx, MinimumMediumBlockSize
jb @PreviousBlockChecked
mov eax, esi
call RemoveMediumFreeBlock
jmp @PreviousBlockChecked
{Align branch target}
@EntireMediumPoolFree:
{Should we make this the new sequential feed medium block pool? If the
current sequential feed pool is not entirely free, we make this the new
sequential feed pool.}
cmp MediumSequentialFeedBytesLeft, MediumBlockPoolSize - MediumBlockPoolHeaderSize
jne @MakeEmptyMediumPoolSequentialFeed
{Point esi to the medium block pool header}
sub esi, MediumBlockPoolHeaderSize
{Remove this medium block pool from the linked list}
mov eax, TMediumBlockPoolHeader[esi].PreviousMediumBlockPoolHeader
mov edx, TMediumBlockPoolHeader[esi].NextMediumBlockPoolHeader
mov TMediumBlockPoolHeader[eax].NextMediumBlockPoolHeader, edx
mov TMediumBlockPoolHeader[edx].PreviousMediumBlockPoolHeader, eax
{Unlock medium blocks}
mov MediumBlocksLocked, False;
{Free the medium block pool}
push MEM_RELEASE
push 0
push esi
call VirtualFree
{VirtualFree returns >0 if all is ok}
cmp eax, 1
{Return 0 on all ok}
sbb eax, eax
{Restore registers}
pop esi
pop ebx
ret
{Align branch target}
nop
nop
nop
@MakeEmptyMediumPoolSequentialFeed:
{Get a pointer to the end-marker block}
lea ebx, [esi + MediumBlockPoolSize - MediumBlockPoolHeaderSize]
{Bin the current sequential feed pool}
call BinMediumSequentialFeedRemainder
{Set this medium pool up as the new sequential feed pool:
Store the sequential feed pool trailer}
mov dword ptr [ebx - BlockHeaderSize], IsMediumBlockFlag
{Store the number of bytes available in the sequential feed chunk}
mov MediumSequentialFeedBytesLeft, MediumBlockPoolSize - MediumBlockPoolHeaderSize
{Set the last sequentially fed block}
mov LastSequentiallyFedMediumBlock, ebx
{Unlock medium blocks}
mov MediumBlocksLocked, False;
{Success}
xor eax, eax
{Restore registers}
pop esi
pop ebx
ret
{Align branch target}
nop
nop
@NotASmallOrMediumBlock:
{Restore ebx}
pop ebx
{Is it in fact a large block?}
test dl, IsFreeBlockFlag + IsMediumBlockFlag
jz FreeLargeBlock
{Attempt to free an already free block}
mov eax, -1
end;
{$endif}
{$ifndef FullDebugMode}
{$ifndef ASMVersion}
{Replacement for SysReallocMem (pascal version)}
function FastReallocMem(APointer: Pointer; ANewSize: Integer): Pointer;
var
LBlockHeader, LBlockFlags, LOldAvailableSize, LNewAllocSize,
LNextBlockSizeAndFlags, LNextBlockSize, LNewAvailableSize, LMinimumUpsize,
LSecondSPlitSize, LNewBlockSize: Cardinal;
LPSmallBlockType: PSmallBlockType;
LPNextBlock, LPNextBlockHeader: Pointer;
{Upsizes a large block in-place. The following variables are assumed correct:
LBlockFlags, LOldAvailableSize, LPNextBlock, LNextBlockSizeAndFlags,
LNextBlockSize, LNewAvailableSize. Medium blocks must be locked on entry if
required.}
procedure MediumBlockInPlaceUpsize;
begin
{Remove the next block}
if LNextBlockSizeAndFlags >= MinimumMediumBlockSize then
RemoveMediumFreeBlock(LPNextBlock);
{Add 25% for medium block in-place upsizes}
LMinimumUpsize := LOldAvailableSize + (LOldAvailableSize shr 2);
if Cardinal(ANewSize) < LMinimumUpsize then
LNewAllocSize := LMinimumUpsize
else
LNewAllocSize := ANewSize;
{Round up to the nearest block size granularity}
LNewBlockSize := ((LNewAllocSize + (BlockHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset)) and -MediumBlockGranularity) + MediumBlockSizeOffset;
{Calculate the size of the second split}
LSecondSplitSize := LNewAvailableSize + BlockHeaderSize - LNewBlockSize;
{Does it fit?}
if Integer(LSecondSplitSize) <= 0 then
begin
{The block size is the full available size plus header}
LNewBlockSize := LNewAvailableSize + BlockHeaderSize;
{Grab the whole block: Mark it as used in the block following it}
LPNextBlockHeader := Pointer(Cardinal(APointer) + LNewAvailableSize);
PCardinal(LPNextBlockHeader)^ :=
PCardinal(LPNextBlockHeader)^ and (not PreviousMediumBlockIsFreeFlag);
end
else
begin
{Split the block in two}
LPNextBlock := PMediumFreeBlock(Cardinal(APointer) + LNewBlockSize);
{Set the size of the second split}
PCardinal(Cardinal(LPNextBlock) - BlockHeaderSize)^ := LSecondSplitSize or (IsMediumBlockFlag or IsFreeBlockFlag);
{Store the size of the second split as the second last dword}
PCardinal(Cardinal(LPNextBlock) + LSecondSplitSize - 8)^ := LSecondSplitSize;
{Put the remainder in a bin if it is big enough}
if LSecondSplitSize >= MinimumMediumBlockSize then
InsertMediumBlockIntoBin(LPNextBlock, LSecondSplitSize);
end;
{Set the size and flags for this block}
PCardinal(Cardinal(APointer) - BlockHeaderSize)^ := LNewBlockSize or LBlockFlags;
end;
{In-place downsize of a medium block. On entry ANewSize must be less than half
of LOldAvailableSize.}
procedure MediumBlockInPlaceDownsize;
begin
{Round up to the next medium block size}
LNewBlockSize := ((ANewSize + (BlockHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset)) and -MediumBlockGranularity) + MediumBlockSizeOffset;
{Get the size of the second split}
LSecondSplitSize := (LOldAvailableSize + BlockHeaderSize) - LNewBlockSize;
{Lock the medium blocks}
LockMediumBlocks;
{Set the new size}
PCardinal(Cardinal(APointer) - BlockHeaderSize)^ :=
(PCardinal(Cardinal(APointer) - BlockHeaderSize)^ and ExtractMediumAndLargeFlagsMask)
or LNewBlockSize;
{Is the next block in use?}
LPNextBlock := PCardinal(Cardinal(APointer) + LOldAvailableSize + BlockHeaderSize);
LNextBlockSizeAndFlags := PCardinal(Cardinal(LPNextBlock) - BlockHeaderSize)^;
if LNextBlockSizeAndFlags and IsFreeBlockFlag = 0 then
begin
{The next block is in use: flag its previous block as free}
PCardinal(Cardinal(LPNextBlock) - BlockHeaderSize)^ :=
LNextBlockSizeAndFlags or PreviousMediumBlockIsFreeFlag;
end
else
begin
{The next block is free: combine it}
LNextBlockSizeAndFlags := LNextBlockSizeAndFlags and DropMediumAndLargeFlagsMask;
Inc(LSecondSplitSize, LNextBlockSizeAndFlags);
if LNextBlockSizeAndFlags >= MinimumMediumBlockSize then
RemoveMediumFreeBlock(LPNextBlock);
end;
{Set the split}
LPNextBlock := PCardinal(Cardinal(APointer) + LNewBlockSize);
{Store the free part's header}
PCardinal(Cardinal(LPNextBlock) - BlockHeaderSize)^ := LSecondSplitSize or (IsMediumBlockFlag or IsFreeBlockFlag);
{Store the trailing size field}
PCardinal(Cardinal(LPNextBlock) + LSecondSplitSize - 8)^ := LSecondSplitSize;
{Bin this free block}
if LSecondSplitSize >= MinimumMediumBlockSize then
InsertMediumBlockIntoBin(LPNextBlock, LSecondSplitSize);
{Unlock the medium blocks}
MediumBlocksLocked := False;
end;
begin
{Get the block header: Is it actually a small block?}
LBlockHeader := PCardinal(Cardinal(APointer) - BlockHeaderSize)^;
{Is it a small block that is in use?}
if LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag or IsLargeBlockFlag) = 0 then
begin
{-----------------------------------Small block-------------------------------------}
{The block header is a pointer to the block pool: Get the block type}
LPSmallBlockType := PSmallBlockPoolHeader(LBlockHeader).BlockType;
{Get the available size inside blocks of this type.}
LOldAvailableSize := LPSmallBlockType.BlockSize - BlockHeaderSize;
{Is it an upsize or a downsize?}
if LOldAvailableSize >= Cardinal(ANewSize) then
begin
{It's a downsize. Do we need to allocate a smaller block? Only if the new
block size is less than a quarter of the available size less
SmallBlockDownsizeCheckAdder bytes}
if (Cardinal(ANewSize) * 4 + SmallBlockDownsizeCheckAdder) >= LOldAvailableSize then
begin
{In-place downsize - return the pointer}
Result := APointer;
exit;
end
else
begin
{Allocate a smaller block}
Result := FastGetMem(ANewSize);
{Allocated OK?}
if Result <> nil then
begin
{Move the data across}
{$ifdef UseCustomVariableSizeMoveRoutines}
{$ifdef Align16Bytes}
MoveX16L4(APointer^, Result^, ANewSize);
{$else}
MoveX8L4(APointer^, Result^, ANewSize);
{$endif}
{$else}
System.Move(APointer^, Result^, ANewSize);
{$endif}
{Free the old pointer}
FastFreeMem(APointer);
end;
end;
end
else
begin
{This pointer is being reallocated to a larger block and therefore it is
logical to assume that it may be enlarged again. Since reallocations are
expensive, there is a minimum upsize percentage to avoid unnecessary
future move operations.}
{Must grow with at least 100% + x bytes}
LNewAllocSize := LOldAvailableSize * 2 + SmallBlockUpsizeAdder;
{Still not large enough?}
if LNewAllocSize < Cardinal(ANewSize) then
LNewAllocSize := ANewSize;
{Allocate the new block}
Result := FastGetMem(LNewAllocSize);
{Allocated OK?}
if Result <> nil then
begin
{Do we need to store the requested size? Only large blocks store the
requested size.}
if LNewAllocSize > (MaximumMediumBlockSize - BlockHeaderSize) then
PLargeBlockHeader(Cardinal(Result) - LargeBlockHeaderSize).UserAllocatedSize := ANewSize;
{Move the data across}
{$ifdef UseCustomFixedSizeMoveRoutines}
LPSmallBlockType.UpsizeMoveProcedure(APointer^, Result^, LOldAvailableSize);
{$else}
System.Move(APointer^, Result^, LOldAvailableSize);
{$endif}
{Free the old pointer}
FastFreeMem(APointer);
end;
end;
end
else
begin
{Is this a medium block or a large block?}
if LBlockHeader and (IsFreeBlockFlag or IsLargeBlockFlag) = 0 then
begin
{-------------------------------Medium block--------------------------------------}
{What is the available size in the block being reallocated?}
LOldAvailableSize := (LBlockHeader and DropMediumAndLargeFlagsMask);
{Get a pointer to the next block}
LPNextBlock := PCardinal(Cardinal(APointer) + LOldAvailableSize);
{Subtract the block header size from the old available size}
Dec(LOldAvailableSize, BlockHeaderSize);
{Is it an upsize or a downsize?}
if Cardinal(ANewSize) > LOldAvailableSize then
begin
{Can we do an in-place upsize?}
LNextBlockSizeAndFlags := PCardinal(Cardinal(LPNextBlock) - BlockHeaderSize)^;
{Is the next block free?}
if LNextBlockSizeAndFlags and IsFreeBlockFlag <> 0 then
begin
LNextBlockSize := LNextBlockSizeAndFlags and DropMediumAndLargeFlagsMask;
{The available size including the next block}
LNewAvailableSize := LOldAvailableSize + LNextBlockSize;
{Can the block fit?}
if Cardinal(ANewSize) <= LNewAvailableSize then
begin
{The next block is free and there is enough space to grow this
block in place.}
{$ifndef AssumeMultiThreaded}
if IsMultiThread then
begin
{$endif}
{Multi-threaded application - lock medium blocks and re-read the
information on the blocks.}
LockMediumBlocks;
{Re-read the info for this block}
LBlockFlags := PCardinal(Cardinal(APointer) - BlockHeaderSize)^ and ExtractMediumAndLargeFlagsMask;
{Re-read the info for the next block}
LNextBlockSizeAndFlags := PCardinal(Cardinal(LPNextBlock) - BlockHeaderSize)^;
{Recalculate the next block size}
LNextBlockSize := LNextBlockSizeAndFlags and DropMediumAndLargeFlagsMask;
{The available size including the next block}
LNewAvailableSize := LOldAvailableSize + LNextBlockSize;
{Is the next block still free and the size still sufficient?}
if (LNextBlockSizeAndFlags and IsFreeBlockFlag <> 0)
and (Cardinal(ANewSize) <= LNewAvailableSize) then
begin
{Upsize the block in-place}
MediumBlockInPlaceUpsize;
{Unlock the medium blocks}
MediumBlocksLocked := False;
{Return the result}
Result := APointer;
{Done}
exit;
end;
{Couldn't use the block: Unlock the medium blocks}
MediumBlocksLocked := False;
{$ifndef AssumeMultiThreaded}
end
else
begin
{Extract the block flags}
LBlockFlags := ExtractMediumAndLargeFlagsMask and LBlockHeader;
{Upsize the block in-place}
MediumBlockInPlaceUpsize;
{Return the result}
Result := APointer;
{Done}
exit;
end;
{$endif}
end;
end;
{Couldn't upsize in place. Grab a new block and move the data across:
If we have to reallocate and move medium blocks, we grow by at
least 25%}
LMinimumUpsize := LOldAvailableSize + (LOldAvailableSize shr 2);
if Cardinal(ANewSize) < LMinimumUpsize then
LNewAllocSize := LMinimumUpsize
else
LNewAllocSize := ANewSize;
{Allocate the new block}
Result := FastGetMem(LNewAllocSize);
if Result <> nil then
begin
{If its a Large block - store the actual user requested size}
if LNewAllocSize > (MaximumMediumBlockSize - BlockHeaderSize) then
PLargeBlockHeader(Cardinal(Result) - LargeBlockHeaderSize).UserAllocatedSize := ANewSize;
{Move the data across}
{$ifdef UseCustomVariableSizeMoveRoutines}
MoveX16L4(APointer^, Result^, LOldAvailableSize);
{$else}
System.Move(APointer^, Result^, LOldAvailableSize);
{$endif}
{Free the old block}
FastFreeMem(APointer);
end;
end
else
begin
{Must be less than half the current size or we don't bother resizing.}
if Cardinal(ANewSize * 2) >= LOldAvailableSize then
begin
Result := APointer;
end
else
begin
{In-place downsize? Balance the cost of moving the data vs. the cost
of fragmenting the memory pool. Medium blocks in use may never be
smaller than MinimumMediumBlockSize.}
if ANewSize >= (MinimumMediumBlockSize - BlockHeaderSize) then
begin
MediumBlockInPlaceDownsize;
Result := APointer;
end
else
begin
{The requested size is less than the minimum medium block size. If
the requested size is less than the threshold value (currently a
quarter of the minimum medium block size), move the data to a small
block, otherwise shrink the medium block to the minimum allowable
medium block size.}
if Cardinal(ANewSize) >= MediumInPlaceDownsizeLimit then
begin
{The request is for a size smaller than the minimum medium block
size, but not small enough to justify moving data: Reduce the
block size to the minimum medium block size}
ANewSize := MinimumMediumBlockSize - BlockHeaderSize;
{Is it already at the minimum medium block size?}
if LOldAvailableSize > Cardinal(ANewSize) then
MediumBlockInPlaceDownsize;
Result := APointer;
end
else
begin
{Allocate the new block}
Result := FastGetMem(ANewSize);
if Result <> nil then
begin
{Move the data across}
{$ifdef UseCustomVariableSizeMoveRoutines}
{$ifdef Align16Bytes}
MoveX16L4(APointer^, Result^, ANewSize);
{$else}
MoveX8L4(APointer^, Result^, ANewSize);
{$endif}
{$else}
System.Move(APointer^, Result^, ANewSize);
{$endif}
{Free the old block}
FastFreeMem(APointer);
end;
end;
end;
end;
end;
end
else
begin
{Is this a valid large block?}
if LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag) = 0 then
begin
{-----------------------Large block------------------------------}
Result := ReallocateLargeBlock(APointer, ANewSize);
end
else
begin
{-----------------------Invalid block------------------------------}
{Bad pointer: probable attempt to reallocate a free memory block.}
Result := nil;
end;
end;
end;
end;
{$else}
{Replacement for SysReallocMem (asm version)}
function FastReallocMem(APointer: Pointer; ANewSize: Integer): Pointer;
asm
{On entry: eax = APointer; edx = ANewSize}
{Get the block header: Is it actually a small block?}
mov ecx, [eax - 4]
{Is it a small block?}
test cl, IsFreeBlockFlag + IsMediumBlockFlag + IsLargeBlockFlag
{Save ebx}
push ebx
{Save esi}
push esi
{Save the original pointer in esi}
mov esi, eax
{Is it a small block?}
jnz @NotASmallBlock
{-----------------------------------Small block-------------------------------------}
{Get the block type in ebx}
mov ebx, TSmallBlockPoolHeader[ecx].BlockType
{Get the available size inside blocks of this type.}
movzx ecx, TSmallBlockType[ebx].BlockSize
sub ecx, 4
{Is it an upsize or a downsize?}
cmp ecx, edx
jb @SmallUpsize
{It's a downsize. Do we need to allocate a smaller block? Only if the new
size is less than a quarter of the available size less
SmallBlockDownsizeCheckAdder bytes}
lea ebx, [edx * 4 + SmallBlockDownsizeCheckAdder]
cmp ebx, ecx
jb @NotSmallInPlaceDownsize
{In-place downsize - return the original pointer}
pop esi
pop ebx
ret
{Align branch target}
nop
@NotSmallInPlaceDownsize:
{Save the requested size}
mov ebx, edx
{Allocate a smaller block}
mov eax, edx
call FastGetMem
{Allocated OK?}
test eax, eax
jz @SmallDownsizeDone
{Move data across: count in ecx}
mov ecx, ebx
{Destination in edx}
mov edx, eax
{Save the result in ebx}
mov ebx, eax
{Original pointer in eax}
mov eax, esi
{Move the data across}
{$ifdef UseCustomVariableSizeMoveRoutines}
{$ifdef Align16Bytes}
call MoveX16L4
{$else}
call MoveX8L4
{$endif}
{$else}
call System.Move
{$endif}
{Free the original pointer}
mov eax, esi
call FastFreeMem
{Return the pointer}
mov eax, ebx
@SmallDownsizeDone:
pop esi
pop ebx
ret
{Align branch target}
nop
nop
@SmallUpsize:
{State: esi = APointer, edx = ANewSize, ecx = Current Block Size, ebx = Current Block Type}
{This pointer is being reallocated to a larger block and therefore it is
logical to assume that it may be enlarged again. Since reallocations are
expensive, there is a minimum upsize percentage to avoid unnecessary
future move operations.}
{Small blocks always grow with at least 100% + SmallBlockUpsizeAdder bytes}
lea ecx, [ecx + ecx + SmallBlockUpsizeAdder]
{save edi}
push edi
{Save the requested size in edi}
mov edi, edx
{New allocated size is the maximum of the requested size and the minimum
upsize}
xor eax, eax
sub ecx, edx
adc eax, -1
and eax, ecx
add eax, edx
{Allocate the new block}
call FastGetMem
{Allocated OK?}
test eax, eax
jz @SmallUpsizeDone
{Do we need to store the requested size? Only large blocks store the
requested size.}
cmp edi, MaximumMediumBlockSize - BlockHeaderSize
jbe @NotSmallUpsizeToLargeBlock
{Store the user requested size}
mov [eax - 8], edi
@NotSmallUpsizeToLargeBlock:
{Get the size to move across}
movzx ecx, TSmallBlockType[ebx].BlockSize
sub ecx, BlockHeaderSize
{Move to the new block}
mov edx, eax
{Save the result in edi}
mov edi, eax
{Move from the old block}
mov eax, esi
{Move the data across}
{$ifdef UseCustomFixedSizeMoveRoutines}
call TSmallBlockType[ebx].UpsizeMoveProcedure
{$else}
call System.Move
{$endif}
{Free the old pointer}
mov eax, esi
call FastFreeMem
{Done}
mov eax, edi
@SmallUpsizeDone:
pop edi
pop esi
pop ebx
ret
{Align branch target}
nop
@NotASmallBlock:
{Is this a medium block or a large block?}
test cl, IsFreeBlockFlag + IsLargeBlockFlag
jnz @PossibleLargeBlock
{-------------------------------Medium block--------------------------------------}
{Status: ecx = Current Block Size + Flags, eax/esi = APointer,
edx = Requested Size}
mov ebx, ecx
{Drop the flags from the header}
and ecx, DropMediumAndLargeFlagsMask
{Save edi}
push edi
{Get a pointer to the next block in edi}
lea edi, [eax + ecx]
{Subtract the block header size from the old available size}
sub ecx, BlockHeaderSize
{Get the complete flags in ebx}
and ebx, ExtractMediumAndLargeFlagsMask
{Is it an upsize or a downsize?}
cmp edx, ecx
{Save ebp}
push ebp
{Is it an upsize or a downsize?}
ja @MediumBlockUpsize
{Status: ecx = Current Block Size - 4, bl = Current Block Flags,
edi = @Next Block, eax/esi = APointer, edx = Requested Size}
{Must be less than half the current size or we don't bother resizing.}
lea ebp, [edx + edx]
cmp ebp, ecx
jb @MediumMustDownsize
@MediumNoResize:
{Restore registers}
pop ebp
pop edi
pop esi
pop ebx
{Return}
ret
{Align branch target}
nop
nop
nop
@MediumMustDownsize:
{In-place downsize? Balance the cost of moving the data vs. the cost of
fragmenting the memory pool. Medium blocks in use may never be smaller
than MinimumMediumBlockSize.}
cmp edx, MinimumMediumBlockSize - BlockHeaderSize
jae @MediumBlockInPlaceDownsize
{The requested size is less than the minimum medium block size. If the
requested size is less than the threshold value (currently a quarter of the
minimum medium block size), move the data to a small block, otherwise shrink
the medium block to the minimum allowable medium block size.}
cmp edx, MediumInPlaceDownsizeLimit
jb @MediumDownsizeRealloc
{The request is for a size smaller than the minimum medium block size, but
not small enough to justify moving data: Reduce the block size to the
minimum medium block size}
mov edx, MinimumMediumBlockSize - BlockHeaderSize
{Is it already at the minimum medium block size?}
cmp ecx, edx
jna @MediumNoResize
@MediumBlockInPlaceDownsize:
{Round up to the next medium block size}
lea ebp, [edx + BlockHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset]
and ebp, -MediumBlockGranularity;
add ebp, MediumBlockSizeOffset
{Get the size of the second split}
add ecx, BlockHeaderSize
sub ecx, ebp
{Lock the medium blocks}
{$ifndef AssumeMultiThreaded}
cmp IsMultiThread, False
je @DoMediumInPlaceDownsize
{$endif}
{We have to re-read the flags}
@DoMediumLockForDownsize:
{Lock the medium blocks}
mov eax, $100
{Attempt to lock the medium blocks}
lock cmpxchg MediumBlocksLocked, ah
je @MediumDownsizeRereadFlags
{Couldn't lock the medium blocks - sleep and try again}
push ecx
push InitialSleepTime
call Sleep
pop ecx
{Try again}
mov eax, $100
{Attempt to grab the block type}
lock cmpxchg MediumBlocksLocked, ah
je @MediumDownsizeRereadFlags
{Couldn't lock the medium blocks - sleep and try again}
push ecx
push AdditionalSleepTime
call Sleep
pop ecx
{Try again}
jmp @DoMediumLockForDownsize
{Align branch target}
{$ifdef AssumeMultiThreaded}
nop
{$endif}
@MediumDownsizeRereadFlags:
mov ebx, ExtractMediumAndLargeFlagsMask
and ebx, [esi - 4]
@DoMediumInPlaceDownsize:
{Set the new size}
or ebx, ebp
mov [esi - 4], ebx
{Get the second split size in ebx}
mov ebx, ecx
{Is the next block in use?}
mov edx, [edi - 4]
test dl, IsFreeBlockFlag
jnz @MediumDownsizeNextBlockFree
{The next block is in use: flag its previous block as free}
or edx, PreviousMediumBlockIsFreeFlag
mov [edi - 4], edx
jmp @MediumDownsizeDoSplit
{Align branch target}
nop
@MediumDownsizeNextBlockFree:
{The next block is free: combine it}
mov eax, edi
and edx, DropMediumAndLargeFlagsMask
add ebx, edx
add edi, edx
cmp edx, MinimumMediumBlockSize
jb @MediumDownsizeDoSplit
call RemoveMediumFreeBlock
@MediumDownsizeDoSplit:
{Store the trailing size field}
mov [edi - 8], ebx
{Store the free part's header}
lea eax, [ebx + IsMediumBlockFlag + IsFreeBlockFlag];
mov [esi + ebp - 4], eax
{Bin this free block}
cmp ebx, MinimumMediumBlockSize
jb @MediumBlockDownsizeDone
lea eax, [esi + ebp]
mov edx, ebx
call InsertMediumBlockIntoBin
@MediumBlockDownsizeDone:
{Unlock the medium blocks}
mov MediumBlocksLocked, False
{Result = old pointer}
mov eax, esi
{Restore registers}
pop ebp
pop edi
pop esi
pop ebx
{Return}
ret
{Align branch target}
@MediumDownsizeRealloc:
{Save the requested size}
mov edi, edx
mov eax, edx
{Allocate the new block}
call FastGetMem
test eax, eax
jz @MediumBlockDownsizeExit
{Save the result}
mov ebp, eax
mov edx, eax
mov eax, esi
mov ecx, edi
{Move the data across}
{$ifdef UseCustomVariableSizeMoveRoutines}
{$ifdef Align16Bytes}
call MoveX16L4
{$else}
call MoveX8L4
{$endif}
{$else}
call System.Move
{$endif}
mov eax, esi
call FastFreeMem
{Return the result}
mov eax, ebp
@MediumBlockDownsizeExit:
pop ebp
pop edi
pop esi
pop ebx
ret
{Align branch target}
@MediumBlockUpsize:
{Status: ecx = Current Block Size - 4, bl = Current Block Flags,
edi = @Next Block, eax/esi = APointer, edx = Requested Size}
{Can we do an in-place upsize?}
mov eax, [edi - 4]
test al, IsFreeBlockFlag
jz @CannotUpsizeMediumBlockInPlace
{Get the total available size including the next block}
and eax, DropMediumAndLargeFlagsMask
{ebp = total available size including the next block (excluding the header)}
lea ebp, [eax + ecx]
{Can the block fit?}
cmp edx, ebp
ja @CannotUpsizeMediumBlockInPlace
{The next block is free and there is enough space to grow this
block in place.}
{$ifndef AssumeMultiThreaded}
cmp IsMultiThread, False
je @DoMediumInPlaceUpsize
{$endif}
@DoMediumLockForUpsize:
{Lock the medium blocks}
mov eax, $100
{Attempt to lock the medium blocks}
lock cmpxchg MediumBlocksLocked, ah
je @RecheckMediumInPlaceUpsize
{Couldn't lock the medium blocks - sleep and try again}
push ecx
push edx
push InitialSleepTime
call Sleep
pop edx
pop ecx
{Try again}
mov eax, $100
{Attempt to grab the block type}
lock cmpxchg MediumBlocksLocked, ah
je @RecheckMediumInPlaceUpsize
{Couldn't lock the medium blocks - sleep and try again}
push ecx
push edx
push AdditionalSleepTime
call Sleep
pop edx
pop ecx
{Try again}
jmp @DoMediumLockForUpsize
{Align branch target}
{$ifdef AssumeMultiThreaded}
nop
{$endif}
@RecheckMediumInPlaceUpsize:
{Re-read the info for this block}
mov ebx, ExtractMediumAndLargeFlagsMask
and ebx, [esi - 4]
{Re-read the info for the next block}
mov eax, [edi - 4]
{Next block still free?}
test al, IsFreeBlockFlag
jz @NextMediumBlockChanged
{Recalculate the next block size}
and eax, DropMediumAndLargeFlagsMask
{The available size including the next block}
lea ebp, [eax + ecx]
{Can the block still fit?}
cmp edx, ebp
ja @NextMediumBlockChanged
@DoMediumInPlaceUpsize:
{Is the next block binnable?}
cmp eax, MinimumMediumBlockSize
{Remove the next block}
jb @MediumInPlaceNoNextRemove
mov eax, edi
push ecx
push edx
call RemoveMediumFreeBlock
pop edx
pop ecx
@MediumInPlaceNoNextRemove:
{Medium blocks grow a minimum of 25% in in-place upsizes}
mov eax, ecx
shr eax, 2
add eax, ecx
{Get the maximum of the requested size and the minimum growth size}
xor edi, edi
sub eax, edx
adc edi, -1
and eax, edi
{Round up to the nearest block size granularity}
lea eax, [eax + edx + BlockHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset]
and eax, -MediumBlockGranularity
add eax, MediumBlockSizeOffset
{Calculate the size of the second split}
lea edx, [ebp + BlockHeaderSize]
sub edx, eax
{Does it fit?}
ja @MediumInPlaceUpsizeSplit
{Grab the whole block: Mark it as used in the block following it}
and dword ptr [esi + ebp], not PreviousMediumBlockIsFreeFlag
{The block size is the full available size plus header}
add ebp, 4
{Upsize done}
jmp @MediumUpsizeInPlaceDone
{Align branch target}
nop
nop
@MediumInPlaceUpsizeSplit:
{Store the size of the second split as the second last dword}
mov [esi + ebp - 4], edx
{Set the second split header}
lea edi, [edx + IsMediumBlockFlag + IsFreeBlockFlag]
mov [esi + eax - 4], edi
mov ebp, eax
cmp edx, MinimumMediumBlockSize
jb @MediumUpsizeInPlaceDone
add eax, esi
call InsertMediumBlockIntoBin
@MediumUpsizeInPlaceDone:
{Set the size and flags for this block}
or ebp, ebx
mov [esi - 4], ebp
{Unlock the medium blocks}
mov MediumBlocksLocked, False
{Result = old pointer}
mov eax, esi
@MediumBlockResizeDone2:
{Restore registers}
pop ebp
pop edi
pop esi
pop ebx
{Return}
ret
{Align branch target for "@CannotUpsizeMediumBlockInPlace"}
nop
nop
@NextMediumBlockChanged:
{The next medium block changed while the medium blocks were being locked}
mov MediumBlocksLocked, False
@CannotUpsizeMediumBlockInPlace:
{Couldn't upsize in place. Grab a new block and move the data across:
If we have to reallocate and move medium blocks, we grow by at
least 25%}
mov eax, ecx
shr eax, 2
add eax, ecx
{Get the maximum of the requested size and the minimum growth size}
xor edi, edi
sub eax, edx
adc edi, -1
and eax, edi
add eax, edx
{Save the size to allocate}
mov ebp, eax
{Save the size to move across}
mov edi, ecx
{Get the block}
push edx
call FastGetMem
pop edx
{Success?}
test eax, eax
jz @MediumBlockResizeDone2
{If it's a Large block - store the actual user requested size}
cmp ebp, MaximumMediumBlockSize - BlockHeaderSize
jbe @MediumUpsizeNotLarge
mov [eax - 8], edx
@MediumUpsizeNotLarge:
{Save the result}
mov ebp, eax
{Move the data across}
mov edx, eax
mov eax, esi
mov ecx, edi
{$ifdef UseCustomVariableSizeMoveRoutines}
call MoveX16L4
{$else}
call System.Move
{$endif}
{Free the old block}
mov eax, esi
call FastFreeMem
{Restore the result}
mov eax, ebp
{Restore registers}
pop ebp
pop edi
pop esi
pop ebx
{Return}
ret
{Align branch target}
nop
@PossibleLargeBlock:
{-----------------------Large block------------------------------}
{Restore registers}
pop esi
pop ebx
{Is this a valid large block?}
test cl, IsFreeBlockFlag + IsMediumBlockFlag
jz ReallocateLargeBlock
{-----------------------Invalid block------------------------------}
xor eax, eax
end;
{$endif}
{$endif}
{Allocates a block and fills it with zeroes}
{$ifndef ASMVersion}
function FastAllocMem(ASize: Cardinal): Pointer;
begin
Result := FastGetMem(ASize);
{Large blocks are already zero filled}
if (Result <> nil) and (ASize <= (MaximumMediumBlockSize - BlockHeaderSize)) then
FillChar(Result^, ASize, 0);
end;
{$else}
function FastAllocMem(ASize: Cardinal): Pointer;
asm
push ebx
{Get the size rounded down to the previous multiple of 4 into ebx}
lea ebx, [eax - 1]
and ebx, -4
{Get the block}
call FastGetMem
{Could a block be allocated? ecx = 0 if yes, $ffffffff if no}
cmp eax, 1
sbb ecx, ecx
{Point edx to the last dword}
lea edx, [eax + ebx]
{ebx = $ffffffff if no block could be allocated, otherwise size rounded down
to previous multiple of 4}
or ebx, ecx
{Large blocks are already zero filled}
cmp ebx, MaximumMediumBlockSize - BlockHeaderSize
jae @Done
{Make the counter negative based}
neg ebx
{Load zero into st(0)}
fldz
{Clear groups of 8 bytes. Block sizes are always four less than a multiple
of 8, with a minimum of 12 bytes}
@FillLoop:
fst qword ptr [edx + ebx]
add ebx, 8
js @FillLoop
{Clear the last four bytes}
mov [edx], ecx
{Clear st(0)}
ffree st(0)
@Done:
pop ebx
end;
{$endif}
{-----------------Post Uninstall GetMem/FreeMem/ReallocMem-------------------}
{$ifdef DetectMMOperationsAfterUninstall}
function InvalidGetMem(ASize: Integer): Pointer;
{$ifndef NoMessageBoxes}
var
LErrorMessageTitle: array[0..1023] of char;
{$endif}
begin
{$ifdef UseOutputDebugString}
OutputDebugString(InvalidGetMemMsg);
{$endif}
{$ifndef NoMessageBoxes}
AppendStringToModuleName(InvalidOperationTitle, LErrorMessageTitle);
MessageBox(0, InvalidGetMemMsg, LErrorMessageTitle,
MB_OK or MB_ICONERROR or MB_TASKMODAL);
{$endif}
Result := nil;
end;
function InvalidFreeMem(APointer: Pointer): Integer;
{$ifndef NoMessageBoxes}
var
LErrorMessageTitle: array[0..1023] of char;
{$endif}
begin
{$ifdef UseOutputDebugString}
OutputDebugString(InvalidFreeMemMsg);
{$endif}
{$ifndef NoMessageBoxes}
AppendStringToModuleName(InvalidOperationTitle, LErrorMessageTitle);
MessageBox(0, InvalidFreeMemMsg, LErrorMessageTitle,
MB_OK or MB_ICONERROR or MB_TASKMODAL);
{$endif}
Result := -1;
end;
function InvalidReallocMem(APointer: Pointer; ANewSize: Integer): Pointer;
{$ifndef NoMessageBoxes}
var
LErrorMessageTitle: array[0..1023] of char;
{$endif}
begin
{$ifdef UseOutputDebugString}
OutputDebugString(InvalidReallocMemMsg);
{$endif}
{$ifndef NoMessageBoxes}
AppendStringToModuleName(InvalidOperationTitle, LErrorMessageTitle);
MessageBox(0, InvalidReallocMemMsg, LErrorMessageTitle,
MB_OK or MB_ICONERROR or MB_TASKMODAL);
{$endif}
Result := nil;
end;
function InvalidAllocMem(ASize: Cardinal): Pointer;
{$ifndef NoMessageBoxes}
var
LErrorMessageTitle: array[0..1023] of char;
{$endif}
begin
{$ifdef UseOutputDebugString}
OutputDebugString(InvalidAllocMemMsg);
{$endif}
{$ifndef NoMessageBoxes}
AppendStringToModuleName(InvalidOperationTitle, LErrorMessageTitle);
MessageBox(0, InvalidAllocMemMsg, LErrorMessageTitle,
MB_OK or MB_ICONERROR or MB_TASKMODAL);
{$endif}
Result := nil;
end;
function InvalidRegisterAndUnRegisterMemoryLeak(APointer: Pointer): Boolean;
begin
Result := False;
end;
{$endif}
{-----------------Full Debug Mode Memory Manager Interface--------------------}
{$ifdef FullDebugMode}
procedure DeleteEventLog;
begin
{Delete the file}
DeleteFile(MMLogFileName);
end;
procedure AppendEventLog(ABuffer: Pointer; ACount: Cardinal);
var
LFileHandle, LBytesWritten: Cardinal;
LEventHeader: array[0..1023] of char;
LMsgPtr: PChar;
LSystemTime: TSystemTime;
begin
{Append the file}
LFileHandle := CreateFile(MMLogFileName, GENERIC_READ or GENERIC_WRITE,
0, nil, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
if LFileHandle <> 0 then
begin
{Seek to the end of the file}
SetFilePointer(LFileHandle, 0, nil, FILE_END);
{Set the separator}
LMsgPtr := AppendStringToBuffer(CRLF, @LEventHeader[0], length(CRLF));
LMsgPtr := AppendStringToBuffer(EventSeparator, LMsgPtr, length(EventSeparator));
{Set the date & time}
GetLocalTime(LSystemTime);
LMsgPtr := CardinalToStrBuf(LSystemTime.wYear, LMsgPtr);
LMsgPtr^ := '/';
Inc(LMsgPtr);
LMsgPtr := CardinalToStrBuf(LSystemTime.wMonth, LMsgPtr);
LMsgPtr^ := '/';
Inc(LMsgPtr);
LMsgPtr := CardinalToStrBuf(LSystemTime.wDay, LMsgPtr);
LMsgPtr^ := ' ';
Inc(LMsgPtr);
LMsgPtr := CardinalToStrBuf(LSystemTime.wHour, LMsgPtr);
LMsgPtr^ := ':';
Inc(LMsgPtr);
if LSystemTime.wMinute < 10 then
begin
LMsgPtr^ := '0';
Inc(LMsgPtr);
end;
LMsgPtr := CardinalToStrBuf(LSystemTime.wMinute, LMsgPtr);
LMsgPtr^ := ':';
Inc(LMsgPtr);
if LSystemTime.wSecond < 10 then
begin
LMsgPtr^ := '0';
Inc(LMsgPtr);
end;
LMsgPtr := CardinalToStrBuf(LSystemTime.WSecond, LMsgPtr);
{Write the header}
LMsgPtr := AppendStringToBuffer(EventSeparator, LMsgPtr, length(EventSeparator));
LMsgPtr := AppendStringToBuffer(CRLF, LMsgPtr, length(CRLF));
WriteFile(LFileHandle, LEventHeader[0], Cardinal(LMsgPtr) - Cardinal(@LEventHeader[0]), LBytesWritten, nil);
{Write the data}
WriteFile(LFileHandle, ABuffer^, ACount, LBytesWritten, nil);
{Close the file}
CloseHandle(LFileHandle);
end;
end;
{Sets the default log filename}
procedure SetDefaultMMLogFileName;
var
LModuleNameLength: Cardinal;
begin
{Get the name of the application}
LModuleNameLength := GetModuleFileName(0, @MMLogFileName[0], length(MMLogFileName) - 100);
{Replace the last few characters}
if LModuleNameLength > 0 then
begin
{Change the filename}
System.Move(LogFileExtension, MMLogFileName[LModuleNameLength - 4], Length(LogFileExtension));
end;
end;
{Specify the full path and name for the filename to be used for logging memory
errors, etc. If ALogFileName is nil or points to an empty string it will
revert to the default log file name.}
procedure SetMMLogFileName(ALogFileName: PChar = nil);
var
i: integer;
begin
if (ALogFileName <> nil) and (ALogFileName^ <> #0) then
begin
for i := 0 to length(MMLogFileName) - 2 do
begin
MMLogFileName[i] := ALogFileName^;
if MMlogFileName[i] = #0 then
break;
Inc(ALogFileName);
end;
end
else
SetDefaultMMLogFileName;
end;
{Returns the current "allocation group". Whenever a GetMem request is serviced
in FullDebugMode, the current "allocation group" is stored in the block header.
This may help with debugging. Note that if a block is subsequently reallocated
that it keeps its original "allocation group" and "allocation number" (all
allocations are also numbered sequentially).}
function GetCurrentAllocationGroup: Cardinal;
begin
Result := AllocationGroupStack[AllocationGroupStackTop];
end;
{Allocation groups work in a stack like fashion. Group numbers are pushed onto
and popped off the stack. Note that the stack size is limited, so every push
should have a matching pop.}
procedure PushAllocationGroup(ANewCurrentAllocationGroup: Cardinal);
begin
if AllocationGroupStackTop < AllocationGroupStackSize - 1 then
begin
Inc(AllocationGroupStackTop);
AllocationGroupStack[AllocationGroupStackTop] := ANewCurrentAllocationGroup;
end
else
begin
{Raise a runtime error if the stack overflows}
{$ifdef BCB6OrDelphi7AndUp}
System.Error(reInvalidPtr);
{$else}
System.RunError(reInvalidPtr);
{$endif}
end;
end;
procedure PopAllocationGroup;
begin
if AllocationGroupStackTop > 0 then
begin
Dec(AllocationGroupStackTop);
end
else
begin
{Raise a runtime error if the stack underflows}
{$ifdef BCB6OrDelphi7AndUp}
System.Error(reInvalidPtr);
{$else}
System.RunError(reInvalidPtr);
{$endif}
end;
end;
{Sums all the dwords starting at the given address.}
function SumCardinals(AStartValue: Cardinal; APointer: PCardinal; ACount: Cardinal): Cardinal;
asm
{On entry: eax = AStartValue, edx = APointer; ecx = ACount}
add edx, ecx
neg ecx
@AddLoop:
add eax, [edx + ecx]
add edx, 4
js @AddLoop
end;
{Sums all the dwords starting at the given address for the fill pattern.
Returns true if they are all valid}
function CheckFillPattern(APointer: PCardinal; ACount: Cardinal): boolean;
asm
{On entry: eax = APointer; edx = ACount}
add eax, edx
neg edx
@CheckLoop:
cmp dword ptr [eax + edx], DebugFillDWord
jne @Done
add edx, 4
js @CheckLoop
@Done:
sete al
end;
{Calculates the checksum for the debug header. Adds all dwords in the debug
header to the start address of the block.}
function CalculateHeaderCheckSum(APointer: PFullDebugBlockHeader): Cardinal;
begin
Result := SumCardinals(Cardinal(APointer),
PCardinal(Cardinal(APointer) + 8),
SizeOf(TFullDebugBlockHeader) - 8 - 4);
end;
procedure UpdateHeaderAndFooterCheckSums(APointer: PFullDebugBlockHeader);
var
LHeaderCheckSum: Cardinal;
begin
LHeaderCheckSum := CalculateHeaderCheckSum(APointer);
APointer.HeaderCheckSum := LHeaderCheckSum;
PCardinal(Cardinal(APointer) + SizeOf(TFullDebugBlockHeader) + APointer.UserSize)^ := not LHeaderCheckSum;
end;
function LogCurrentStackTrace(ASkipFrames: Cardinal; ABuffer: PChar): PChar;
var
LCurrentStackTrace: TStackTrace;
begin
{Get the current call stack}
GetStackTrace(@LCurrentStackTrace[0], StackTraceDepth, ASkipFrames);
{List it}
Result := AppendStringToBuffer(CurrentStackTraceMsg, ABuffer, length(CurrentStackTraceMsg));
Result := LogStackTrace(@LCurrentStackTrace, StackTraceDepth, Result);
end;
function LogMemoryDump(APointer: PFullDebugBlockHeader; ABuffer: PChar): PChar;
var
LByteNum, LVal: Cardinal;
LDataPtr: PByte;
begin
Result := AppendStringToBuffer(MemoryDumpMsg, ABuffer, Length(MemoryDumpMsg));
Result := CardinalToHexBuf(Cardinal(APointer) + SizeOf(TFullDebugBlockHeader), Result);
Result^ := ':';
Inc(Result);
{Add the bytes}
LDataPtr := PByte(Cardinal(APointer) + SizeOf(TFullDebugBlockHeader));
for LByteNum := 0 to 255 do
begin
if LByteNum and 31 = 0 then
begin
Result^ := #13;
Inc(Result);
Result^ := #10;
Inc(Result);
end
else
begin
Result^ := ' ';
Inc(Result);
end;
{Set the hex data}
LVal := LDataPtr^;
Result^ := HexTable[LVal shr 4];
Inc(Result);
Result^ := HexTable[LVal and $f];
Inc(Result);
{Next byte}
Inc(LDataPtr);
end;
{Dump ASCII}
LDataPtr := PByte(Cardinal(APointer) + SizeOf(TFullDebugBlockHeader));
for LByteNum := 0 to 255 do
begin
if LByteNum and 31 = 0 then
begin
Result^ := #13;
Inc(Result);
Result^ := #10;
Inc(Result);
end
else
begin
Result^ := ' ';
Inc(Result);
Result^ := ' ';
Inc(Result);
end;
{Set the hex data}
LVal := LDataPtr^;
if LVal < 32 then
Result^ := '.'
else
Result^ := Char(LVal);
Inc(Result);
{Next byte}
Inc(LDataPtr);
end;
end;
procedure LogBlockError(APointer: PFullDebugBlockHeader; AOperation: TBlockOperation; LHeaderValid, LFooterValid: Boolean);
var
LMsgPtr: PChar;
LErrorMessage: array[0..32767] of char;
{$ifndef NoMessageBoxes}
LErrorMessageTitle: array[0..1023] of char;
{$endif}
LClass: TClass;
LClassName: ShortString;
begin
{Display the error header and the operation type.}
LMsgPtr := AppendStringToBuffer(ErrorMsgHeader, @LErrorMessage[0], Length(ErrorMsgHeader));
case AOperation of
boGetMem: LMsgPtr := AppendStringToBuffer(GetMemMsg, LMsgPtr, Length(GetMemMsg));
boFreeMem: LMsgPtr := AppendStringToBuffer(FreeMemMsg, LMsgPtr, Length(FreeMemMsg));
boReallocMem: LMsgPtr := AppendStringToBuffer(ReallocMemMsg, LMsgPtr, Length(ReallocMemMsg));
boBlockCheck: LMsgPtr := AppendStringToBuffer(BlockCheckMsg, LMsgPtr, Length(BlockCheckMsg));
end;
LMsgPtr := AppendStringToBuffer(OperationMsg, LMsgPtr, Length(OperationMsg));
{Is the header still intact?}
if LHeaderValid then
begin
{Is the footer still valid?}
if LFooterValid then
begin
{A freed block has been modified, or a double free has occurred}
if AOperation <= boGetMem then
LMsgPtr := AppendStringToBuffer(FreeModifiedErrorMsg, LMsgPtr, Length(FreeModifiedErrorMsg))
else
LMsgPtr := AppendStringToBuffer(DoubleFreeErrorMsg, LMsgPtr, Length(DoubleFreeErrorMsg));
end
else
begin
LMsgPtr := AppendStringToBuffer(BlockFooterCorruptedMsg, LMsgPtr, Length(BlockFooterCorruptedMsg))
end;
{Set the block size message}
if AOperation <= boGetMem then
LMsgPtr := AppendStringToBuffer(PreviousBlockSizeMsg, LMsgPtr, Length(PreviousBlockSizeMsg))
else
LMsgPtr := AppendStringToBuffer(CurrentBlockSizeMsg, LMsgPtr, Length(CurrentBlockSizeMsg));
LMsgPtr := CardinalToStrBuf(APointer.UserSize, LMsgPtr);
{The header is still intact - display info about the this/previous allocation}
if APointer.AllocationStackTrace[0] <> 0 then
begin
if AOperation <= boGetMem then
LMsgPtr := AppendStringToBuffer(StackTraceAtPrevAllocMsg, LMsgPtr, Length(StackTraceAtPrevAllocMsg))
else
LMsgPtr := AppendStringToBuffer(StackTraceAtAllocMsg, LMsgPtr, Length(StackTraceAtAllocMsg));
LMsgPtr := LogStackTrace(@APointer.AllocationStackTrace, StackTraceDepth, LMsgPtr);
end;
{Get the class this block was used for previously}
LClass := GetObjectClass(@APointer.PreviouslyUsedByClass);
if (LClass <> nil) and (Cardinal(LClass) <> Cardinal(@FreedObjectVMT.VMTMethods[0])) then
begin
LClassName := LClass.ClassName;
LMsgPtr := AppendStringToBuffer(PreviousObjectClassMsg, LMsgPtr, Length(PreviousObjectClassMsg));
LMsgPtr := AppendStringToBuffer(@LClassName[1], LMsgPtr, Length(LClassName));
end;
{Get the current class for this block}
if (AOperation > boGetMem) and (not LFooterValid) then
begin
LClass := GetObjectClass(Pointer(Cardinal(APointer) + SizeOf(TFullDebugBlockHeader)));
if (LClass <> nil) and (Cardinal(LClass) <> Cardinal(@FreedObjectVMT.VMTMethods[0])) then
LClassName := LClass.ClassName
else
LClassName := UnknownClassNameMsg;
LMsgPtr := AppendStringToBuffer(CurrentObjectClassMsg, LMsgPtr, Length(CurrentObjectClassMsg));
LMsgPtr := AppendStringToBuffer(@LClassName[1], LMsgPtr, Length(LClassName));
{Log the allocation group}
if APointer.AllocationGroup > 0 then
begin
LMsgPtr := AppendStringToBuffer(CurrentAllocationGroupMsg, LMsgPtr, Length(CurrentAllocationGroupMsg));
LMsgPtr := CardinalToStrBuf(APointer.AllocationGroup, LMsgPtr);
end;
{Log the allocation number}
LMsgPtr := AppendStringToBuffer(CurrentAllocationNumberMsg, LMsgPtr, Length(CurrentAllocationNumberMsg));
LMsgPtr := CardinalToStrBuf(APointer.AllocationNumber, LMsgPtr);
end
else
begin
{Log the allocation group}
if APointer.AllocationGroup > 0 then
begin
LMsgPtr := AppendStringToBuffer(PreviousAllocationGroupMsg, LMsgPtr, Length(PreviousAllocationGroupMsg));
LMsgPtr := CardinalToStrBuf(APointer.AllocationGroup, LMsgPtr);
end;
{Log the allocation number}
LMsgPtr := AppendStringToBuffer(PreviousAllocationNumberMsg, LMsgPtr, Length(PreviousAllocationNumberMsg));
LMsgPtr := CardinalToStrBuf(APointer.AllocationNumber, LMsgPtr);
end;
{Get the call stack for the previous free}
if APointer.FreeStackTrace[0] <> 0 then
begin
LMsgPtr := AppendStringToBuffer(StackTraceAtFreeMsg, LMsgPtr, Length(StackTraceAtFreeMsg));
LMsgPtr := LogStackTrace(@APointer.FreeStackTrace, StackTraceDepth, LMsgPtr);
end;
end
else
begin
{Header has been corrupted}
LMsgPtr := AppendStringToBuffer(BlockHeaderCorruptedMsg, LMsgPtr, Length(BlockHeaderCorruptedMsg));
end;
{Add the current stack trace}
LMsgPtr := LogCurrentStackTrace(3 + ord(AOperation <> boGetMem) + ord(AOperation = boReallocMem), LMsgPtr);
{Add the memory dump}
LMsgPtr := LogMemoryDump(APointer, LMsgPtr);
{Trailing CRLF}
LMsgPtr^ := #13;
Inc(LMsgPtr);
LMsgPtr^ := #10;
Inc(LMsgPtr);
{Trailing #0}
LMsgPtr^ := #0;
{$ifdef LogErrorsToFile}
{Log the error}
AppendEventLog(@LErrorMessage[0], Cardinal(LMsgPtr) - Cardinal(@LErrorMessage[0]));
{$endif}
{$ifdef UseOutputDebugString}
OutputDebugString(LErrorMessage);
{$endif}
{Show the message}
{$ifndef NoMessageBoxes}
AppendStringToModuleName(BlockErrorMsgTitle, LErrorMessageTitle);
MessageBox(0, LErrorMessage, LErrorMessageTitle,
MB_OK or MB_ICONERROR or MB_TASKMODAL);
{$endif}
end;
{Logs the stack traces for a memory leak to file}
procedure LogMemoryLeakOrAllocatedBlock(APointer: PFullDebugBlockHeader; IsALeak: Boolean);
var
LHeaderValid: boolean;
LMsgPtr: PChar;
LErrorMessage: array[0..32767] of char;
LClass: TClass;
LClassName: ShortString;
begin
{Display the error header and the operation type.}
if IsALeak then
LMsgPtr := AppendStringToBuffer(LeakLogHeader, @LErrorMessage[0], Length(LeakLogHeader))
else
LMsgPtr := AppendStringToBuffer(BlockScanLogHeader, @LErrorMessage[0], Length(BlockScanLogHeader));
LMsgPtr := CardinalToStrBuf(GetAvailableSpaceInBlock(APointer) - FullDebugBlockOverhead, LMsgPtr);
{Is the debug info surrounding the block valid?}
LHeaderValid := CalculateHeaderCheckSum(APointer) = APointer.HeaderCheckSum;
{Is the header still intact?}
if LHeaderValid then
begin
{The header is still intact - display info about this/previous allocation}
if APointer.AllocationStackTrace[0] <> 0 then
begin
LMsgPtr := AppendStringToBuffer(StackTraceAtAllocMsg, LMsgPtr, Length(StackTraceAtAllocMsg));
LMsgPtr := LogStackTrace(@APointer.AllocationStackTrace, StackTraceDepth, LMsgPtr);
end;
{Get the current class for this block}
LClass := GetObjectClass(Pointer(Cardinal(APointer) + SizeOf(TFullDebugBlockHeader)));
if (LClass <> nil) and (Cardinal(LClass) <> Cardinal(@FreedObjectVMT.VMTMethods[0])) then
LClassName := LClass.ClassName
else
LClassName := UnknownClassNameMsg;
LMsgPtr := AppendStringToBuffer(CurrentObjectClassMsg, LMsgPtr, Length(CurrentObjectClassMsg));
LMsgPtr := AppendStringToBuffer(@LClassName[1], LMsgPtr, Length(LClassName));
{Log the allocation group}
if APointer.AllocationGroup > 0 then
begin
LMsgPtr := AppendStringToBuffer(CurrentAllocationGroupMsg, LMsgPtr, Length(CurrentAllocationGroupMsg));
LMsgPtr := CardinalToStrBuf(APointer.AllocationGroup, LMsgPtr);
end;
{Log the allocation number}
LMsgPtr := AppendStringToBuffer(CurrentAllocationNumberMsg, LMsgPtr, Length(CurrentAllocationNumberMsg));
LMsgPtr := CardinalToStrBuf(APointer.AllocationNumber, LMsgPtr);
end
else
begin
{Header has been corrupted}
LMsgPtr^ := '.';
Inc(LMsgPtr);
LMsgPtr^ := ' ';
Inc(LMsgPtr);
LMsgPtr := AppendStringToBuffer(BlockHeaderCorruptedMsg, LMsgPtr, Length(BlockHeaderCorruptedMsg));
end;
{Add the memory dump}
LMsgPtr := LogMemoryDump(APointer, LMsgPtr);
{Trailing CRLF}
LMsgPtr^ := #13;
Inc(LMsgPtr);
LMsgPtr^ := #10;
Inc(LMsgPtr);
{Trailing #0}
LMsgPtr^ := #0;
{Log the error}
AppendEventLog(@LErrorMessage[0], Cardinal(LMsgPtr) - Cardinal(@LErrorMessage[0]));
end;
{Checks that a free block is unmodified}
function CheckFreeBlockUnmodified(APBlock: PFullDebugBlockHeader; ABlockSize: Cardinal;
AOperation: TBlockOperation): Boolean;
var
LHeaderCheckSum: Cardinal;
LHeaderValid, LFooterValid{$ifndef CatchUseOfFreedInterfaces}, LBlockUnmodified{$endif}: boolean;
begin
LHeaderCheckSum := CalculateHeaderCheckSum(APBlock);
LHeaderValid := LHeaderCheckSum = PFullDebugBlockHeader(APBlock).HeaderCheckSum;
{Is the footer itself still in place}
LFooterValid := LHeaderValid
and (PCardinal(Cardinal(APBlock) + SizeOf(TFullDebugBlockHeader) + PFullDebugBlockHeader(APBlock).UserSize)^ = (not LHeaderCheckSum));
{$ifndef CatchUseOfFreedInterfaces}
if LFooterValid then
begin
{Clear the old footer}
PCardinal(Cardinal(APBlock) + SizeOf(TFullDebugBlockHeader) + PFullDebugBlockHeader(APBlock).UserSize)^ := DebugFillDWord;
{Check that all the filler bytes are valid inside the block, except for the four byte "dummy" class header}
LBlockUnmodified := CheckFillPattern(PCardinal(Cardinal(APBlock) + SizeOf(TFullDebugBlockHeader) + 4),
ABlockSize - (BlockHeaderSize + FullDebugBlockOverhead));
{Reset the old footer}
PCardinal(Cardinal(APBlock) + SizeOf(TFullDebugBlockHeader) + PFullDebugBlockHeader(APBlock).UserSize)^ := not LHeaderCheckSum;
end
else
LBlockUnmodified := False;
{$endif}
if (not LHeaderValid) or (not LFooterValid){$ifndef CatchUseOfFreedInterfaces}or (not LBlockUnmodified){$endif} then
begin
LogBlockError(APBlock, AOperation, LHeaderValid, LFooterValid);
Result := False;
end
else
Result := True;
end;
function DebugGetMem(ASize: Integer): Pointer;
begin
{We need extra space for (a) The debug header, (b) the block debug trailer
and (c) the trailing block size pointer for free blocks}
Result := FastGetMem(ASize + FullDebugBlockOverhead);
if Result <> nil then
begin
if CheckFreeBlockUnmodified(Result, GetAvailableSpaceInBlock(Result) + 4, boGetMem) then
begin
{Set the allocation call stack}
GetStackTrace(@PFullDebugBlockHeader(Result).AllocationStackTrace, StackTraceDepth, 1);
{Block is now in use}
PFullDebugBlockHeader(Result).BlockInUse := True;
{Set the group number}
PFullDebugBlockHeader(Result).AllocationGroup := AllocationGroupStack[AllocationGroupStackTop];
{Set the allocation number}
Inc(CurrentAllocationNumber);
PFullDebugBlockHeader(Result).AllocationNumber := CurrentAllocationNumber;
{Clear the previous block trailer}
PCardinal(Cardinal(Result) + SizeOf(TFullDebugBlockHeader) + PFullDebugBlockHeader(Result).UserSize)^ := DebugFillDWord;
{Set the user size for the block}
PFullDebugBlockHeader(Result).UserSize := ASize;
{Set the checksums}
UpdateHeaderAndFooterCheckSums(Result);
{Return the start of the actual block}
Result := Pointer(Cardinal(Result) + SizeOf(TFullDebugBlockHeader));
end
else
begin
Result := nil;
end;
end;
end;
function CheckBlockBeforeFreeOrRealloc(APointer: PFullDebugBlockHeader; AOperation: TBlockOperation): boolean;
var
LHeaderValid, LFooterValid: boolean;
begin
{Is the debug info surrounding the block valid?}
LHeaderValid := CalculateHeaderCheckSum(APointer) = APointer.HeaderCheckSum;
LFooterValid := LHeaderValid
and (APointer.HeaderCheckSum = (not PCardinal(Cardinal(APointer) + SizeOf(TFullDebugBlockHeader) + PFullDebugBlockHeader(APointer).UserSize)^));
if LHeaderValid and LFooterValid and APointer.BlockInUse then
begin
Result := True;
end
else
begin
{Log the error}
LogBlockError(APointer, AOperation, LHeaderValid, LFooterValid);
{Return an error}
Result := False;
end;
end;
function DebugFreeMem(APointer: Pointer): Integer;
var
LActualBlock: PFullDebugBlockHeader;
begin
{Get a pointer to the start of the actual block}
LActualBlock := PFullDebugBlockHeader(Cardinal(APointer)
- SizeOf(TFullDebugBlockHeader));
{Is the debug info surrounding the block valid?}
if CheckBlockBeforeFreeOrRealloc(LActualBlock, boFreeMem) then
begin
{Get the class the block was used for}
LActualBlock.PreviouslyUsedByClass := PCardinal(APointer)^;
{Set the free call stack}
GetStackTrace(@LActualBlock.FreeStackTrace, StackTraceDepth, 1);
{Block is now free}
LActualBlock.BlockInUse := False;
{Clear the user area of the block}
FillDWord(APointer^, LActualBlock.UserSize,
{$ifndef CatchUseOfFreedInterfaces}DebugFillDWord{$else}Cardinal(@VMTBadInterface){$endif});
{Set a pointer to the dummy VMT}
PCardinal(APointer)^ := Cardinal(@FreedObjectVMT.VMTMethods[0]);
{Recalculate the checksums}
UpdateHeaderAndFooterCheckSums(LActualBlock);
{Free the actual block}
Result := FastFreeMem(LActualBlock);
end
else
begin
Result := -1;
end;
end;
{In debug mode we never do an in-place resize, data is always moved. This
increases the likelihood of catching memory overwrite bugs.}
function DebugReallocMem(APointer: Pointer; ANewSize: Integer): Pointer;
var
LMoveSize, LBlockSpace: Cardinal;
LActualBlock, LNewActualBlock: PFullDebugBlockHeader;
begin
{Get a pointer to the start of the actual block}
LActualBlock := PFullDebugBlockHeader(Cardinal(APointer)
- SizeOf(TFullDebugBlockHeader));
{Is the debug info surrounding the block valid?}
if CheckBlockBeforeFreeOrRealloc(LActualBlock, boReallocMem) then
begin
{Get the current block size}
LBlockSpace := GetAvailableSpaceInBlock(LActualBlock);
{Can the block fit? We need space for the debug overhead and the block header
of the next block}
if LBlockSpace < (Cardinal(ANewSize) + FullDebugBlockOverhead) then
begin
{Get a new block of the requested size}
Result := DebugGetMem(ANewSize);
if Result <> nil then
begin
{How many bytes to move?}
LMoveSize := LActualBlock.UserSize;
if LMoveSize > Cardinal(ANewSize) then
LMoveSize := ANewSize;
{Move the data across}
System.Move(APointer^, Result^, LMoveSize);
{Keep the old group and allocation numbers}
LNewActualBlock := PFullDebugBlockHeader(Cardinal(Result)
- SizeOf(TFullDebugBlockHeader));
LNewActualBlock.AllocationGroup := LActualBlock.AllocationGroup;
LNewActualBlock.AllocationNumber := LActualBlock.AllocationNumber;
{This was not a new allocation number - decrement the allocation number
that was incremented in the DebugGetMem call}
Dec(CurrentAllocationNumber);
{Recalculate the header and footer checksums}
UpdateHeaderAndFooterCheckSums(LNewActualBlock);
{Free the old block}
DebugFreeMem(APointer);
end
else
begin
Result := nil;
end;
end
else
begin
{Clear all data after the new end of the block up to the old end of the
block, including the trailer}
FillDWord(Pointer(Cardinal(APointer) + Cardinal(ANewSize) + 4)^,
Integer(LActualBlock.UserSize) - ANewSize,
{$ifndef CatchUseOfFreedInterfaces}DebugFillDWord{$else}Cardinal(@VMTBadInterface){$endif});
{Update the user size}
LActualBlock.UserSize := ANewSize;
{Set the new checksums}
UpdateHeaderAndFooterCheckSums(LActualBlock);
{Return the old pointer}
Result := APointer;
end;
end
else
begin
Result := nil;
end;
end;
{Allocates a block and fills it with zeroes}
function DebugAllocMem(ASize: Cardinal): Pointer;
begin
Result := DebugGetMem(ASize);
{Large blocks are already zero filled}
if (Result <> nil) and (ASize <= (MaximumMediumBlockSize - BlockHeaderSize)) then
FillChar(Result^, ASize, 0);
end;
{Logs detail about currently allocated memory blocks for the specified range of
allocation groups. if ALastAllocationGroupToLog is less than
AFirstAllocationGroupToLog or it is zero, then all allocation groups are
logged. This routine also checks the memory pool for consistency at the same
time.}
procedure LogAllocatedBlocksToFile(AFirstAllocationGroupToLog, ALastAllocationGroupToLog: Cardinal);
var
LPLargeBlock: PLargeBlockHeader;
LPMediumBlock: Pointer;
LPMediumBlockPoolHeader: PMediumBlockPoolHeader;
LMediumBlockHeader: Cardinal;
{Checks the small block pool for allocated blocks}
procedure ScanSmallBlockPool(APSmallBlockPool: PSmallBlockPoolHeader);
var
LCurPtr, LEndPtr: Pointer;
begin
{Get the first and last pointer for the pool}
GetFirstAndLastSmallBlockInPool(APSmallBlockPool, LCurPtr, LEndPtr);
{Step through all blocks}
while Cardinal(LCurPtr) <= Cardinal(LEndPtr) do
begin
{Is this block in use? If so, is the debug info intact?}
if ((PCardinal(Cardinal(LCurPtr) - 4)^ and IsFreeBlockFlag) = 0) then
begin
if CheckBlockBeforeFreeOrRealloc(LCurPtr, boBlockCheck)
and (PFullDebugBlockHeader(LCurPtr).AllocationGroup >= AFirstAllocationGroupToLog)
and (PFullDebugBlockHeader(LCurPtr).AllocationGroup <= ALastAllocationGroupToLog) then
begin
LogMemoryLeakOrAllocatedBlock(LCurPtr, False);
end;
end
else
begin
{Check that the block has not been modified since being freed}
CheckFreeBlockUnmodified(LCurPtr, APSmallBlockPool.BlockType.BlockSize, boBlockCheck);
end;
{Next block}
Inc(Cardinal(LCurPtr), APSmallBlockPool.BlockType.BlockSize);
end;
end;
begin
{Validate input}
if (ALastAllocationGroupToLog = 0) or (ALastAllocationGroupToLog < AFirstAllocationGroupToLog) then
begin
{Bad input: log all groups}
AFirstAllocationGroupToLog := 0;
ALastAllocationGroupToLog := $ffffffff;
end;
{Step through all the medium block pools}
LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader;
while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do
begin
LPMediumBlock := GetFirstMediumBlockInPool(LPMediumBlockPoolHeader);
while LPMediumBlock <> nil do
begin
LMediumBlockHeader := PCardinal(Cardinal(LPMediumBlock) - 4)^;
{Is the block in use?}
if LMediumBlockHeader and IsFreeBlockFlag = 0 then
begin
{Block is in use: Is it a medium block or small block pool?}
if (LMediumBlockHeader and IsSmallBlockPoolInUseFlag) <> 0 then
begin
{Get all the leaks for the small block pool}
ScanSmallBlockPool(LPMediumBlock);
end
else
begin
if CheckBlockBeforeFreeOrRealloc(LPMediumBlock, boBlockCheck)
and (PFullDebugBlockHeader(LPMediumBlock).AllocationGroup >= AFirstAllocationGroupToLog)
and (PFullDebugBlockHeader(LPMediumBlock).AllocationGroup <= ALastAllocationGroupToLog) then
begin
LogMemoryLeakOrAllocatedBlock(LPMediumBlock, False);
end;
end;
end
else
begin
{Check that the block has not been modified since being freed}
CheckFreeBlockUnmodified(LPMediumBlock, LMediumBlockHeader and DropMediumAndLargeFlagsMask, boBlockCheck);
end;
{Next medium block}
LPMediumBlock := NextMediumBlock(LPMediumBlock);
end;
{Get the next medium block pool}
LPMediumBlockPoolHeader := LPMediumBlockPoolHeader.NextMediumBlockPoolHeader;
end;
{Scan large blocks}
LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader;
while (LPLargeBlock <> @LargeBlocksCircularList) do
begin
if CheckBlockBeforeFreeOrRealloc(Pointer(Cardinal(LPLargeBlock) + LargeBlockHeaderSize), boBlockCheck)
and (PFullDebugBlockHeader(Cardinal(LPLargeBlock) + LargeBlockHeaderSize).AllocationGroup >= AFirstAllocationGroupToLog)
and (PFullDebugBlockHeader(Cardinal(LPLargeBlock) + LargeBlockHeaderSize).AllocationGroup <= ALastAllocationGroupToLog) then
begin
LogMemoryLeakOrAllocatedBlock(Pointer(Cardinal(LPLargeBlock) + LargeBlockHeaderSize), False);
end;
{Get the next large block}
LPLargeBlock := LPLargeBlock.NextLargeBlockHeader;
end;
end;
{-----------------------Invalid Virtual Method Calls-------------------------}
{ TFreedObject }
{Used to determine the index of the virtual method call on the freed object.
Do not change this without updating MaxFakeVMTEntries. Currently 200.}
procedure TFreedObject.GetVirtualMethodIndex;
asm
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex); Inc(VMIndex);
jmp TFreedObject.VirtualMethodError
end;
procedure TFreedObject.VirtualMethodError;
var
LVMOffset: Integer;
LMsgPtr: PChar;
LErrorMessage: array[0..32767] of char;
{$ifndef NoMessageBoxes}
LErrorMessageTitle: array[0..1023] of char;
{$endif}
LClass: TClass;
LClassName: ShortString;
LActualBlock: PFullDebugBlockHeader;
begin
{Get the offset of the virtual method}
LVMOffset := (MaxFakeVMTEntries - VMIndex) * 4 + vmtParent + 4;
{Reset the index for the next error}
VMIndex := 0;
{Get the address of the actual block}
LActualBlock := PFullDebugBlockHeader(Cardinal(Self) - SizeOf(TFullDebugBlockHeader));
{Display the error header}
LMsgPtr := AppendStringToBuffer(VirtualMethodErrorHeader, @LErrorMessage[0], Length(VirtualMethodErrorHeader));
{Is the debug info surrounding the block valid?}
if CalculateHeaderCheckSum(LActualBlock) = LActualBlock.HeaderCheckSum then
begin
{Get the class this block was used for previously}
LClass := GetObjectClass(@LActualBlock.PreviouslyUsedByClass);
if (LClass <> nil) and (Cardinal(LClass) <> Cardinal(@FreedObjectVMT.VMTMethods[0])) then
begin
LClassName := LClass.ClassName;
LMsgPtr := AppendStringToBuffer(FreedObjectClassMsg, LMsgPtr, Length(FreedObjectClassMsg));
LMsgPtr := AppendStringToBuffer(@LClassName[1], LMsgPtr, Length(LClassName));
end;
{Get the virtual method name}
LMsgPtr := AppendStringToBuffer(VirtualMethodName, LMsgPtr, Length(VirtualMethodName));
if LVMOffset < 0 then
begin
LMsgPtr := AppendStringToBuffer(StandardVirtualMethodNames[LVMOffset div 4], LMsgPtr, Length(StandardVirtualMethodNames[LVMOffset div 4]));
end
else
begin
LMsgPtr := AppendStringToBuffer(VirtualMethodOffset, LMsgPtr, Length(VirtualMethodOffset));
LMsgPtr := CardinalToStrBuf(LVMOffset, LMsgPtr);
end;
{Virtual method address}
if (LClass <> nil) and (Cardinal(LClass) <> Cardinal(@FreedObjectVMT.VMTMethods[0])) then
begin
LMsgPtr := AppendStringToBuffer(VirtualMethodAddress, LMsgPtr, Length(VirtualMethodAddress));
LMsgPtr := CardinalToHexBuf(PCardinal(Integer(LClass) + LVMOffset)^, LMsgPtr);
end;
{Log the allocation group}
if LActualBlock.AllocationGroup > 0 then
begin
LMsgPtr := AppendStringToBuffer(PreviousAllocationGroupMsg, LMsgPtr, Length(PreviousAllocationGroupMsg));
LMsgPtr := CardinalToStrBuf(LActualBlock.AllocationGroup, LMsgPtr);
end;
{Log the allocation number}
LMsgPtr := AppendStringToBuffer(PreviousAllocationNumberMsg, LMsgPtr, Length(PreviousAllocationNumberMsg));
LMsgPtr := CardinalToStrBuf(LActualBlock.AllocationNumber, LMsgPtr);
{The header is still intact - display info about the this/previous allocation}
if LActualBlock.AllocationStackTrace[0] <> 0 then
begin
LMsgPtr := AppendStringToBuffer(StackTraceAtObjectAllocMsg, LMsgPtr, Length(StackTraceAtObjectAllocMsg));
LMsgPtr := LogStackTrace(@LActualBlock.AllocationStackTrace, StackTraceDepth, LMsgPtr);
end;
{Get the call stack for the previous free}
if LActualBlock.FreeStackTrace[0] <> 0 then
begin
LMsgPtr := AppendStringToBuffer(StackTraceAtObjectFreeMsg, LMsgPtr, Length(StackTraceAtObjectFreeMsg));
LMsgPtr := LogStackTrace(@LActualBlock.FreeStackTrace, StackTraceDepth, LMsgPtr);
end;
end
else
begin
{Header has been corrupted}
LMsgPtr := AppendStringToBuffer(BlockHeaderCorruptedNoHistoryMsg, LMsgPtr, Length(BlockHeaderCorruptedNoHistoryMsg));
end;
{Add the current stack trace}
LMsgPtr := LogCurrentStackTrace(2, LMsgPtr);
{Add the pointer address}
LMsgPtr := LogMemoryDump(LActualBlock, LMsgPtr);
{Trailing CRLF}
LMsgPtr^ := #13;
Inc(LMsgPtr);
LMsgPtr^ := #10;
Inc(LMsgPtr);
{Trailing #0}
LMsgPtr^ := #0;
{$ifdef LogErrorsToFile}
{Log the error}
AppendEventLog(@LErrorMessage[0], Cardinal(LMsgPtr) - Cardinal(@LErrorMessage[0]));
{$endif}
{$ifdef UseOutputDebugString}
OutputDebugString(LErrorMessage);
{$endif}
{$ifndef NoMessageBoxes}
{Show the message}
AppendStringToModuleName(BlockErrorMsgTitle, LErrorMessageTitle);
MessageBox(0, LErrorMessage, LErrorMessageTitle,
MB_OK or MB_ICONERROR or MB_TASKMODAL);
{$endif}
{Raise an access violation}
RaiseException(EXCEPTION_ACCESS_VIOLATION, 0, 0, nil);
end;
{$ifdef CatchUseOfFreedInterfaces}
procedure TFreedObject.InterfaceError;
var
LMsgPtr: PChar;
{$ifndef NoMessageBoxes}
LErrorMessageTitle: array[0..1023] of char;
{$endif}
LErrorMessage: array[0..4000] of char;
begin
{Display the error header}
LMsgPtr := AppendStringToBuffer(InterfaceErrorHeader, @LErrorMessage[0], Length(InterfaceErrorHeader));
{Add the current stack trace}
LMsgPtr := LogCurrentStackTrace(2, LMsgPtr);
{Trailing CRLF}
LMsgPtr^ := #13;
Inc(LMsgPtr);
LMsgPtr^ := #10;
Inc(LMsgPtr);
{Trailing #0}
LMsgPtr^ := #0;
{$ifdef LogErrorsToFile}
{Log the error}
AppendEventLog(@LErrorMessage[0], Cardinal(LMsgPtr) - Cardinal(@LErrorMessage[0]));
{$endif}
{$ifdef UseOutputDebugString}
OutputDebugString(LErrorMessage);
{$endif}
{$ifndef NoMessageBoxes}
{Show the message}
AppendStringToModuleName(BlockErrorMsgTitle, LErrorMessageTitle);
MessageBox(0, LErrorMessage, LErrorMessageTitle,
MB_OK or MB_ICONERROR or MB_TASKMODAL);
{$endif}
{Raise an access violation}
RaiseException(EXCEPTION_ACCESS_VIOLATION, 0, 0, nil);
end;
{$endif}
{$endif}
{----------------------------Memory Leak Checking-----------------------------}
{$ifdef EnableMemoryLeakReporting}
{Adds a leak to the specified list}
function UpdateExpectedLeakList(APLeakList: PPExpectedMemoryLeak;
APNewEntry: PExpectedMemoryLeak; AExactSizeMatch: Boolean = True): boolean;
var
LPInsertAfter, LPNewEntry: PExpectedMemoryLeak;
begin
{Default to error}
Result := False;
{Find the insertion spot}
LPInsertAfter := APLeakList^;
while (LPInsertAfter <> nil) do
begin
{Too big?}
if (LPInsertAfter.LeakSize > APNewEntry.LeakSize) then
begin
LPInsertAfter := LPInsertAfter.PreviousLeak;
break;
end;
{Find a matching entry. If an exact size match is not required and the leak
is larger than the current entry, use it if the expected size of the next
entry is too large.}
if (Cardinal(LPInsertAfter.LeakAddress) = Cardinal(APNewEntry.LeakAddress))
and (Cardinal(LPInsertAfter.LeakedClass) = Cardinal(APNewEntry.LeakedClass))
and ((LPInsertAfter.LeakSize = APNewEntry.LeakSize)
or ((not AExactSizeMatch)
and (LPInsertAfter.LeakSize < APNewEntry.LeakSize)
and ((LPInsertAfter.NextLeak = nil)
or (LPInsertAfter.NextLeak.LeakSize > APNewEntry.LeakSize))
)) then
begin
if Integer(LPInsertAfter.LeakCount + APNewEntry.LeakCount) >= 0 then
begin
Inc(LPInsertAfter.LeakCount, APNewEntry.LeakCount);
{Is the count now 0?}
if LPInsertAfter.LeakCount = 0 then
begin
{Delete the entry}
if LPInsertAfter.NextLeak <> nil then
LPInsertAfter.NextLeak.PreviousLeak := LPInsertAfter.PreviousLeak;
if LPInsertAfter.PreviousLeak <> nil then
LPInsertAfter.PreviousLeak.NextLeak := LPInsertAfter.NextLeak
else
APLeakList^ := LPInsertAfter.NextLeak;
{Insert it as the first free slot}
LPInsertAfter.NextLeak := ExpectedMemoryLeaks.FirstFreeSlot;
ExpectedMemoryLeaks.FirstFreeSlot := LPInsertAfter;
end;
Result := True;
end;
exit;
end;
{Next entry}
if LPInsertAfter.NextLeak <> nil then
LPInsertAfter := LPInsertAfter.NextLeak
else
break;
end;
if APNewEntry.LeakCount > 0 then
begin
{Get a position for the entry}
LPNewEntry := ExpectedMemoryLeaks.FirstFreeSlot;
if LPNewEntry <> nil then
begin
ExpectedMemoryLeaks.FirstFreeSlot := LPNewEntry.NextLeak;
end
else
begin
if (ExpectedMemoryLeaks.EntriesUsed < length(ExpectedMemoryLeaks.ExpectedLeaks)) then
begin
LPNewEntry := @ExpectedMemoryLeaks.ExpectedLeaks[ExpectedMemoryLeaks.EntriesUsed];
Inc(ExpectedMemoryLeaks.EntriesUsed);
end
else
begin
{No more space}
exit;
end;
end;
{Set the entry}
LPNewEntry^ := APNewEntry^;
{Insert it into the list}
LPNewEntry.PreviousLeak := LPInsertAfter;
if LPInsertAfter <> nil then
begin
LPNewEntry.NextLeak := LPInsertAfter.NextLeak;
LPInsertAfter.NextLeak := LPNewEntry;
end
else
begin
LPNewEntry.NextLeak := APLeakList^;
APLeakList^ := LPNewEntry;
end;
Result := True;
end;
end;
{Locks the expected leaks. Returns false if the list could not be allocated.}
function LockExpectedMemoryLeaksList: Boolean;
begin
{Lock the expected leaks list}
{$ifndef AssumeMultiThreaded}
if IsMultiThread then
{$endif}
begin
while LockCmpxchg(0, 1, @ExpectedMemoryLeaksListLocked) <> 0 do
begin
Sleep(InitialSleepTime);
if LockCmpxchg(0, 1, @ExpectedMemoryLeaksListLocked) = 0 then
break;
Sleep(AdditionalSleepTime);
end;
end;
{Allocate the list if it does not exist}
if ExpectedMemoryLeaks = nil then
ExpectedMemoryLeaks := VirtualAlloc(nil, ExpectedMemoryLeaksListSize, MEM_COMMIT, PAGE_READWRITE);
{Done}
Result := ExpectedMemoryLeaks <> nil;
end;
{Registers expected memory leaks. Returns true on success. The list of leaked
blocks is limited, so failure is possible if the list is full.}
function RegisterExpectedMemoryLeak(ALeakedPointer: Pointer): boolean; overload;
var
LNewEntry: TExpectedMemoryLeak;
begin
{Fill out the structure}
{$ifndef FullDebugMode}
LNewEntry.LeakAddress := ALeakedPointer;
{$else}
LNewEntry.LeakAddress := Pointer(Cardinal(ALeakedPointer) - SizeOf(TFullDebugBlockHeader));
{$endif}
LNewEntry.LeakedClass := nil;
LNewEntry.LeakSize := 0;
LNewEntry.LeakCount := 1;
{Add it to the correct list}
Result := LockExpectedMemoryLeaksList
and UpdateExpectedLeakList(@ExpectedMemoryLeaks.FirstEntryByAddress, @LNewEntry);
ExpectedMemoryLeaksListLocked := False;
end;
function RegisterExpectedMemoryLeak(ALeakedObjectClass: TClass; ACount: Integer = 1): boolean; overload;
var
LNewEntry: TExpectedMemoryLeak;
begin
{Fill out the structure}
LNewEntry.LeakAddress := nil;
LNewEntry.LeakedClass := ALeakedObjectClass;
LNewEntry.LeakSize := ALeakedObjectClass.InstanceSize;
LNewEntry.LeakCount := ACount;
{Add it to the correct list}
Result := LockExpectedMemoryLeaksList
and UpdateExpectedLeakList(@ExpectedMemoryLeaks.FirstEntryByClass, @LNewEntry);
ExpectedMemoryLeaksListLocked := False;
end;
function RegisterExpectedMemoryLeak(ALeakedBlockSize: Integer; ACount: Integer = 1): boolean; overload;
var
LNewEntry: TExpectedMemoryLeak;
begin
{Fill out the structure}
LNewEntry.LeakAddress := nil;
LNewEntry.LeakedClass := nil;
LNewEntry.LeakSize := ALeakedBlockSize;
LNewEntry.LeakCount := ACount;
{Add it to the correct list}
Result := LockExpectedMemoryLeaksList
and UpdateExpectedLeakList(@ExpectedMemoryLeaks.FirstEntryBySizeOnly, @LNewEntry);
ExpectedMemoryLeaksListLocked := False;
end;
function UnregisterExpectedMemoryLeak(ALeakedPointer: Pointer): boolean; overload;
var
LNewEntry: TExpectedMemoryLeak;
begin
{Fill out the structure}
{$ifndef FullDebugMode}
LNewEntry.LeakAddress := ALeakedPointer;
{$else}
LNewEntry.LeakAddress := Pointer(Cardinal(ALeakedPointer) - SizeOf(TFullDebugBlockHeader));
{$endif}
LNewEntry.LeakedClass := nil;
LNewEntry.LeakSize := 0;
LNewEntry.LeakCount := -1;
{Remove it from the list}
Result := LockExpectedMemoryLeaksList
and UpdateExpectedLeakList(@ExpectedMemoryLeaks.FirstEntryByAddress, @LNewEntry);
ExpectedMemoryLeaksListLocked := False;
end;
function UnregisterExpectedMemoryLeak(ALeakedObjectClass: TClass; ACount: Integer = 1): boolean; overload;
begin
Result := RegisterExpectedMemoryLeak(ALeakedObjectClass, - ACount);
end;
function UnregisterExpectedMemoryLeak(ALeakedBlockSize: Integer; ACount: Integer = 1): boolean; overload;
begin
Result := RegisterExpectedMemoryLeak(ALeakedBlockSize, - ACount);
end;
{Returns a list of all expected memory leaks}
function GetRegisteredMemoryLeaks: TRegisteredMemoryLeaks;
procedure AddEntries(AEntry: PExpectedMemoryLeak);
var
LInd: integer;
begin
while AEntry <> nil do
begin
LInd := length(Result);
SetLength(Result, LInd + 1);
{Add the entry}
{$ifndef FullDebugMode}
Result[LInd].LeakAddress := AEntry.LeakAddress;
{$else}
Result[LInd].LeakAddress := Pointer(Cardinal(AEntry.LeakAddress) + SizeOf(TFullDebugBlockHeader));
{$endif}
Result[LInd].LeakedClass := AEntry.LeakedClass;
Result[LInd].LeakSize := AEntry.LeakSize;
Result[LInd].LeakCount := AEntry.LeakCount;
{Next entry}
AEntry := AEntry.NextLeak;
end;
end;
begin
SetLength(Result, 0);
if (ExpectedMemoryLeaks <> nil) and LockExpectedMemoryLeaksList then
begin
{Add all entries}
AddEntries(ExpectedMemoryLeaks.FirstEntryByAddress);
AddEntries(ExpectedMemoryLeaks.FirstEntryByClass);
AddEntries(ExpectedMemoryLeaks.FirstEntryBySizeOnly);
{Unlock the list}
ExpectedMemoryLeaksListLocked := False;
end;
end;
{$endif}
{Checks blocks for modification after free and also for memory
leaks}
procedure CheckBlocksOnShutdown(ACheckForLeakedBlocks: Boolean);
{$ifdef EnableMemoryLeakReporting}
type
{Leaked class type}
TLeakedClass = packed record
ClassPointer: TClass;
NumLeaks: Cardinal;
end;
TLeakedClasses = array[0..255] of TLeakedClass;
PLeakedClasses = ^TLeakedClasses;
{Leak statistics for a small block type}
TSmallBlockLeaks = array[0..NumSmallBlockTypes - 1] of TLeakedClasses;
{A leaked medium or large block}
TMediumAndLargeBlockLeaks = array[0..4095] of Cardinal;
{$endif}
var
{$ifdef EnableMemoryLeakReporting}
{The leaked classes for small blocks}
LSmallBlockLeaks: TSmallBlockLeaks;
LLeakType: TMemoryLeakType;
LMediumAndLargeBlockLeaks: TMediumAndLargeBlockLeaks;
LNumMediumAndLargeLeaks: Integer;
LPLargeBlock: PLargeBlockHeader;
LLeakMessage: array[0..32767] of char;
{$ifndef NoMessageBoxes}
LMessageTitleBuffer: array[0..1023] of char;
{$endif}
LMsgPtr: PChar;
LClassName: ShortString;
LExpectedLeaksOnly, LSmallLeakHeaderAdded, LBlockSizeHeaderAdded: Boolean;
LBlockTypeInd, LMediumBlockSize, LLargeBlockSize,
LClassInd, LPreviousBlockSize, LThisBlockSize, LBlockInd: Cardinal;
{$endif}
LPMediumBlock: Pointer;
LPMediumBlockPoolHeader: PMediumBlockPoolHeader;
LMediumBlockHeader: Cardinal;
{$ifdef EnableMemoryLeakReporting}
{Tries to account for a memory leak. Returns true if the leak is expected and
removes the leak from the list}
function GetMemoryLeakType(AAddress: Pointer; ASpaceInsideBlock: Cardinal): TMemoryLeakType;
var
LLeak: TExpectedMemoryLeak;
begin
{Default to not found}
Result := mltUnexpectedLeak;
if ExpectedMemoryLeaks <> nil then
begin
{Check by pointer address}
LLeak.LeakAddress := AAddress;
LLeak.LeakedClass := nil;
LLeak.LeakSize := 0;
LLeak.LeakCount := -1;
if UpdateExpectedLeakList(@ExpectedMemoryLeaks.FirstEntryByAddress, @LLeak, False) then
begin
Result := mltExpectedLeakRegisteredByPointer;
exit;
end;
{Check by class}
LLeak.LeakAddress := nil;
{$ifdef FullDebugMode}
LLeak.LeakedClass := TClass(PCardinal(Cardinal(AAddress)+ SizeOf(TFullDebugBlockHeader))^);
{$else}
LLeak.LeakedClass := TClass(PCardinal(AAddress)^);
{$endif}
LLeak.LeakSize := ASpaceInsideBlock;
if UpdateExpectedLeakList(@ExpectedMemoryLeaks.FirstEntryByClass, @LLeak, False) then
begin
Result := mltExpectedLeakRegisteredByClass;
exit;
end;
{Check by size: the block must be large enough to hold the leak}
LLeak.LeakedClass := nil;
if UpdateExpectedLeakList(@ExpectedMemoryLeaks.FirstEntryBySizeOnly, @LLeak, False) then
Result := mltExpectedLeakRegisteredBySize;
end;
end;
{Checks the small block pool for leaks.}
procedure CheckSmallBlockPoolForLeaks(APSmallBlockPool: PSmallBlockPoolHeader);
var
LLeakedClass: TClass;
LSmallBlockLeakType: TMemoryLeakType;
LCharInd, LClassIndex, LStringLength: Integer;
LPStr: PChar;
LPossibleString: boolean;
LCurPtr, LEndPtr, LDataPtr: Pointer;
LBlockTypeIndex: Cardinal;
LPLeakedClasses: PLeakedClasses;
LSmallBlockSize: Cardinal;
begin
{Get the useable size inside a block}
LSmallBlockSize := APSmallBlockPool.BlockType.BlockSize - BlockHeaderSize;
{$ifdef FullDebugMode}
Dec(LSmallBlockSize, FullDebugBlockOverhead);
{$endif}
{Get the block type index}
LBlockTypeIndex := (Cardinal(APSmallBlockPool.BlockType) - Cardinal(@SmallBlockTypes[0])) div SizeOf(TSmallBlockType);
LPLeakedClasses := @LSmallBlockLeaks[LBlockTypeIndex];
{Get the first and last pointer for the pool}
GetFirstAndLastSmallBlockInPool(APSmallBlockPool, LCurPtr, LEndPtr);
{Step through all blocks}
while Cardinal(LCurPtr) <= Cardinal(LEndPtr) do
begin
{Is this block in use? If so, is the debug info intact?}
if ((PCardinal(Cardinal(LCurPtr) - 4)^ and IsFreeBlockFlag) = 0) then
begin
{$ifdef FullDebugMode}
if CheckBlockBeforeFreeOrRealloc(LCurPtr, boBlockCheck) then
{$endif}
begin
{Get the leak type}
LSmallBlockLeakType := GetMemoryLeakType(LCurPtr, LSmallBlockSize);
{$ifdef LogMemoryLeakDetailToFile}
{$ifdef HideExpectedLeaksRegisteredByPointer}
if LSmallBlockLeakType <> mltExpectedLeakRegisteredByPointer then
{$endif}
LogMemoryLeakOrAllocatedBlock(LCurPtr, True);
{$endif}
{Only expected leaks?}
LExpectedLeaksOnly := LExpectedLeaksOnly and (LSmallBlockLeakType <> mltUnexpectedLeak);
{$ifdef HideExpectedLeaksRegisteredByPointer}
if LSmallBlockLeakType <> mltExpectedLeakRegisteredByPointer then
{$endif}
begin
{Get a pointer to the user data}
{$ifndef FullDebugMode}
LDataPtr := LCurPtr;
{$else}
LDataPtr := Pointer(Cardinal(LCurPtr) + SizeOf(TFullDebugBlockHeader));
{$endif}
{Default to an unknown block}
LClassIndex := 0;
{Get the class contained by the block}
LLeakedClass := GetObjectClass(LDataPtr);
{Not a class? -> is it perhaps a string?}
if LLeakedClass = nil then
begin
{Reference count < 256}
if (PCardinal(LDataPtr)^ < 256) then
begin
LStringLength := PCardinal(Cardinal(LDataPtr) + 4)^;
{Does the string fit?}
if (LStringLength > 0)
and (LStringLength < (APSmallBlockPool.BlockType.BlockSize - (8 + 1 + 4 {$ifdef FullDebugMode} + FullDebugBlockOverhead{$endif}))) then
begin
{Check that all characters are in range #32..#127}
LPStr := PChar(Cardinal(LDataPtr) + 8);
LPossibleString := True;
for LCharInd := 1 to LStringLength do
begin
LPossibleString := LPossibleString and (LPStr^ >= #32) and (LPStr^ < #128);
Inc(LPStr);
end;
{Must have a trailing #0}
if LPossibleString and (LPStr^ = #0) then
begin
LClassIndex := 1;
end;
end;
end;
end
else
begin
LClassIndex := 2;
while LClassIndex <= High(TLeakedClasses) do
begin
if (LPLeakedClasses[LClassIndex].ClassPointer = LLeakedClass)
or (LPLeakedClasses[LClassIndex].ClassPointer = nil) then
begin
break;
end;
Inc(LClassIndex);
end;
if LClassIndex <= High(TLeakedClasses) then
LPLeakedClasses[LClassIndex].ClassPointer := LLeakedClass
else
LClassIndex := 0;
end;
{Add to the number of leaks for the class}
Inc(LPLeakedClasses[LClassIndex].NumLeaks);
end;
end;
end
else
begin
{$ifdef CheckUseOfFreedBlocksOnShutdown}
{Check that the block has not been modified since being freed}
CheckFreeBlockUnmodified(LCurPtr, APSmallBlockPool.BlockType.BlockSize, boBlockCheck);
{$endif}
end;
{Next block}
Inc(Cardinal(LCurPtr), APSmallBlockPool.BlockType.BlockSize);
end;
end;
{$endif}
begin
{$ifdef EnableMemoryLeakReporting}
{Clear the leak arrays}
FillChar(LSmallBlockLeaks, SizeOf(LSmallBlockLeaks), 0);
FillChar(LMediumAndLargeBlockLeaks, SizeOf(LMediumAndLargeBlockLeaks), 0);
{Step through all the medium block pools}
LNumMediumAndLargeLeaks := 0;
{No unexpected leaks so far}
LExpectedLeaksOnly := True;
{$endif}
{Step through all the medium block pools}
LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader;
while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do
begin
LPMediumBlock := GetFirstMediumBlockInPool(LPMediumBlockPoolHeader);
while LPMediumBlock <> nil do
begin
LMediumBlockHeader := PCardinal(Cardinal(LPMediumBlock) - 4)^;
{Is the block in use?}
if LMediumBlockHeader and IsFreeBlockFlag = 0 then
begin
{$ifdef EnableMemoryLeakReporting}
if ACheckForLeakedBlocks then
begin
if (LMediumBlockHeader and IsSmallBlockPoolInUseFlag) <> 0 then
begin
{Get all the leaks for the small block pool}
CheckSmallBlockPoolForLeaks(LPMediumBlock);
end
else
begin
if (LNumMediumAndLargeLeaks < length(LMediumAndLargeBlockLeaks))
{$ifdef FullDebugMode}
and CheckBlockBeforeFreeOrRealloc(LPMediumBlock, boBlockCheck)
{$endif}
then
begin
LMediumBlockSize := (LMediumBlockHeader and DropMediumAndLargeFlagsMask) - BlockHeaderSize;
{$ifdef FullDebugMode}
Dec(LMediumBlockSize, FullDebugBlockOverhead);
{$endif}
{Get the leak type}
LLeakType := GetMemoryLeakType(LPMediumBlock, LMediumBlockSize);
{Is it an expected leak?}
LExpectedLeaksOnly := LExpectedLeaksOnly and (LLeakType <> mltUnexpectedLeak);
{$ifdef LogMemoryLeakDetailToFile}
{$ifdef HideExpectedLeaksRegisteredByPointer}
if LLeakType <> mltExpectedLeakRegisteredByPointer then
{$endif}
LogMemoryLeakOrAllocatedBlock(LPMediumBlock, True);
{$endif}
{$ifdef HideExpectedLeaksRegisteredByPointer}
if LLeakType <> mltExpectedLeakRegisteredByPointer then
{$endif}
begin
{Add the leak to the list}
LMediumAndLargeBlockLeaks[LNumMediumAndLargeLeaks] := LMediumBlockSize;
Inc(LNumMediumAndLargeLeaks);
end;
end;
end;
end;
{$endif}
end
else
begin
{$ifdef CheckUseOfFreedBlocksOnShutdown}
{Check that the block has not been modified since being freed}
CheckFreeBlockUnmodified(LPMediumBlock, LMediumBlockHeader and DropMediumAndLargeFlagsMask, boBlockCheck);
{$endif}
end;
{Next medium block}
LPMediumBlock := NextMediumBlock(LPMediumBlock);
end;
{Get the next medium block pool}
LPMediumBlockPoolHeader := LPMediumBlockPoolHeader.NextMediumBlockPoolHeader;
end;
{$ifdef EnableMemoryLeakReporting}
if ACheckForLeakedBlocks then
begin
{Get all leaked large blocks}
LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader;
while (LPLargeBlock <> @LargeBlocksCircularList) do
begin
if (LNumMediumAndLargeLeaks < length(LMediumAndLargeBlockLeaks))
{$ifdef FullDebugMode}
and CheckBlockBeforeFreeOrRealloc(Pointer(Cardinal(LPLargeBlock) + LargeBlockHeaderSize), boBlockCheck)
{$endif}
then
begin
LLargeBlockSize := (LPLargeBlock.BlockSizeAndFlags and DropMediumAndLargeFlagsMask) - BlockHeaderSize - LargeBlockHeaderSize;
{$ifdef FullDebugMode}
Dec(LLargeBlockSize, FullDebugBlockOverhead);
{$endif}
{Get the leak type}
LLeakType := GetMemoryLeakType(Pointer(Cardinal(LPLargeBlock) + LargeBlockHeaderSize), LLargeBlockSize);
{Is it an expected leak?}
LExpectedLeaksOnly := LExpectedLeaksOnly and (LLeakType <> mltUnexpectedLeak);
{$ifdef LogMemoryLeakDetailToFile}
{$ifdef HideExpectedLeaksRegisteredByPointer}
if LLeakType <> mltExpectedLeakRegisteredByPointer then
{$endif}
LogMemoryLeakOrAllocatedBlock(Pointer(Cardinal(LPLargeBlock) + LargeBlockHeaderSize), True);
{$endif}
{$ifdef HideExpectedLeaksRegisteredByPointer}
if LLeakType <> mltExpectedLeakRegisteredByPointer then
{$endif}
begin
{Add the leak}
LMediumAndLargeBlockLeaks[LNumMediumAndLargeLeaks] := LLargeBlockSize;
Inc(LNumMediumAndLargeLeaks);
end;
end;
{Get the next large block}
LPLargeBlock := LPLargeBlock.NextLargeBlockHeader;
end;
{Display the leak message if required}
if not LExpectedLeaksOnly then
begin
{Small leak header has not been added}
LSmallLeakHeaderAdded := False;
LPreviousBlockSize := 0;
{Set up the leak message header so long}
LMsgPtr := AppendStringToBuffer(LeakMessageHeader, @LLeakMessage[0], length(LeakMessageHeader));
{Step through all the small block types}
for LBlockTypeInd := 0 to NumSmallBlockTypes - 1 do
begin
LThisBlockSize := SmallBlockTypes[LBlockTypeInd].BlockSize - BlockHeaderSize;
{$ifdef FullDebugMode}
Dec(LThisBlockSize, FullDebugBlockOverhead);
if Integer(LThisBlockSize) < 0 then
LThisBlockSize := 0;
{$endif}
LBlockSizeHeaderAdded := False;
{Any leaks?}
for LClassInd := high(LSmallBlockLeaks[LBlockTypeInd]) downto 0 do
begin
{Is there still space in the message buffer? Reserve space for the message
footer.}
if LMsgPtr > @LLeakMessage[high(LLeakMessage) - 2048] then
break;
{Check the count}
if LSmallBlockLeaks[LBlockTypeInd][LClassInd].NumLeaks > 0 then
begin
{Need to add the header?}
if not LSmallLeakHeaderAdded then
begin
LMsgPtr := AppendStringToBuffer(SmallLeakDetail, LMsgPtr, Length(SmallLeakDetail));
LSmallLeakHeaderAdded := True;
end;
{Need to add the size header?}
if not LBlockSizeHeaderAdded then
begin
LMsgPtr^ := #13;
Inc(LMsgPtr);
LMsgPtr^ := #10;
Inc(LMsgPtr);
LMsgPtr := CardinalToStrBuf(LPreviousBlockSize + 1, LMsgPtr);
LMsgPtr^ := ' ';
Inc(LMsgPtr);
LMsgPtr^ := '-';
Inc(LMsgPtr);
LMsgPtr^ := ' ';
Inc(LMsgPtr);
LMsgPtr := CardinalToStrBuf(LThisBlockSize, LMsgPtr);
LMsgPtr := AppendStringToBuffer(BytesMessage, LMsgPtr, Length(BytesMessage));
LBlockSizeHeaderAdded := True;
end
else
begin
LMsgPtr^ := ',';
Inc(LMsgPtr);
LMsgPtr^ := ' ';
Inc(LMsgPtr);
end;
{Show the count}
case LClassInd of
{Unknown}
0:
begin
LMsgPtr := AppendStringToBuffer(UnknownClassNameMsg, LMsgPtr, Length(UnknownClassNameMsg));
end;
{Strings}
1:
begin
LMsgPtr := AppendStringToBuffer(StringBlockMessage, LMsgPtr, Length(StringBlockMessage));
end;
{Classes}
else
begin
LClassName := LSmallBlockLeaks[LBlockTypeInd][LClassInd].ClassPointer.ClassName;
LMsgPtr := AppendStringToBuffer(@LClassName[1], LMsgPtr, Length(LClassName));
end;
end;
{Add the count}
LMsgPtr^ := ' ';
Inc(LMsgPtr);
LMsgPtr^ := 'x';
Inc(LMsgPtr);
LMsgPtr^ := ' ';
Inc(LMsgPtr);
LMsgPtr := CardinalToStrBuf(LSmallBlockLeaks[LBlockTypeInd][LClassInd].NumLeaks, LMsgPtr);
end;
end;
LPreviousBlockSize := LThisBlockSize;
end;
{Add the medium/large block leak message}
if LNumMediumAndLargeLeaks > 0 then
begin
{Any non-small leaks?}
if LSmallLeakHeaderAdded then
begin
LMsgPtr^ := #13;
Inc(LMsgPtr);
LMsgPtr^ := #10;
Inc(LMsgPtr);
LMsgPtr^ := #13;
Inc(LMsgPtr);
LMsgPtr^ := #10;
Inc(LMsgPtr);
end;
{Add the medium/large block leak message}
LMsgPtr := AppendStringToBuffer(LargeLeakDetail, LMsgPtr, Length(LargeLeakDetail));
{List all the blocks}
for LBlockInd := 0 to LNumMediumAndLargeLeaks - 1 do
begin
if LBlockInd <> 0 then
begin
LMsgPtr^ := ',';
Inc(LMsgPtr);
LMsgPtr^ := ' ';
Inc(LMsgPtr);
end;
LMsgPtr := CardinalToStrBuf(LMediumAndLargeBlockLeaks[LBlockInd], LMsgPtr);
{Is there still space in the message buffer? Reserve space for the
message footer.}
if LMsgPtr > @LLeakMessage[high(LLeakMessage) - 2048] then
break;
end;
end;
{$ifdef LogErrorsToFile}
{Set the message footer}
LMsgPtr := AppendStringToBuffer(LeakMessageFooter, LMsgPtr, Length(LeakMessageFooter));
{Append the message to the memory errors file}
AppendEventLog(@LLeakMessage[0], Cardinal(LMsgPtr) - Cardinal(@LLeakMessage[1]));
{$else}
{Set the message footer}
AppendStringToBuffer(LeakMessageFooter, LMsgPtr, Length(LeakMessageFooter));
{$endif}
{$ifdef UseOutputDebugString}
OutputDebugString(LLeakMessage);
{$endif}
{$ifndef NoMessageBoxes}
{Show the message}
AppendStringToModuleName(LeakMessageTitle, LMessageTitleBuffer);
MessageBox(0, LLeakMessage, LMessageTitleBuffer,
MB_OK or MB_ICONERROR or MB_TASKMODAL);
{$endif}
end;
end;
{$endif}
end;
{Returns statistics about the current state of the memory manager}
procedure GetMemoryManagerState(var AMemoryManagerState: TMemoryManagerState);
var
LPMediumBlockPoolHeader: PMediumBlockPoolHeader;
LPMediumBlock: Pointer;
LInd: Integer;
LBlockTypeIndex, LMediumBlockSize, LMediumBlockHeader, LLargeBlockSize: Cardinal;
LPLargeBlock: PLargeBlockHeader;
begin
{Clear the structure}
FillChar(AMemoryManagerState, SizeOf(AMemoryManagerState), 0);
{Set the small block size stats}
for LInd := 0 to NumSmallBlockTypes - 1 do
begin
AMemoryManagerState.SmallBlockTypeStates[LInd].InternalBlockSize :=
SmallBlockTypes[LInd].BlockSize;
AMemoryManagerState.SmallBlockTypeStates[LInd].UseableBlockSize :=
SmallBlockTypes[LInd].BlockSize - BlockHeaderSize{$ifdef FullDebugMode} - FullDebugBlockOverhead{$endif};
if Integer(AMemoryManagerState.SmallBlockTypeStates[LInd].UseableBlockSize) < 0 then
AMemoryManagerState.SmallBlockTypeStates[LInd].UseableBlockSize := 0;
end;
{Lock all small block types}
LockAllSmallBlockTypes;
{Lock the medium blocks}
LockMediumBlocks;
{Step through all the medium block pools}
LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader;
while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do
begin
{Add to the medium block used space}
Inc(AMemoryManagerState.ReservedMediumBlockAddressSpace, MediumBlockPoolSize);
LPMediumBlock := GetFirstMediumBlockInPool(LPMediumBlockPoolHeader);
while LPMediumBlock <> nil do
begin
LMediumBlockHeader := PCardinal(Cardinal(LPMediumBlock) - 4)^;
{Is the block in use?}
if LMediumBlockHeader and IsFreeBlockFlag = 0 then
begin
{Get the block size}
LMediumBlockSize := LMediumBlockHeader and DropMediumAndLargeFlagsMask;
if (LMediumBlockHeader and IsSmallBlockPoolInUseFlag) <> 0 then
begin
{Get the block type index}
LBlockTypeIndex := (Cardinal(PSmallBlockPoolHeader(LPMediumBlock).BlockType) - Cardinal(@SmallBlockTypes[0])) div SizeOf(TSmallBlockType);
{Subtract from medium block usage}
Dec(AMemoryManagerState.ReservedMediumBlockAddressSpace, LMediumBlockSize);
{Add it to the reserved space for the block size}
Inc(AMemoryManagerState.SmallBlockTypeStates[LBlockTypeIndex].ReservedAddressSpace, LMediumBlockSize);
{Add the usage for the pool}
Inc(AMemoryManagerState.SmallBlockTypeStates[LBlockTypeIndex].AllocatedBlockCount,
PSmallBlockPoolHeader(LPMediumBlock).BlocksInUse);
end
else
begin
{$ifdef FullDebugMode}
Dec(LMediumBlockSize, FullDebugBlockOverhead);
{$endif}
Inc(AMemoryManagerState.AllocatedMediumBlockCount);
Inc(AMemoryManagerState.TotalAllocatedMediumBlockSize, LMediumBlockSize - BlockHeaderSize);
end;
end;
{Next medium block}
LPMediumBlock := NextMediumBlock(LPMediumBlock);
end;
{Get the next medium block pool}
LPMediumBlockPoolHeader := LPMediumBlockPoolHeader.NextMediumBlockPoolHeader;
end;
{Unlock medium blocks}
MediumBlocksLocked := False;
{Unlock all the small block types}
for LInd := 0 to NumSmallBlockTypes - 1 do
SmallBlockTypes[LInd].BlockTypeLocked := False;
{Step through all the large blocks}
LockLargeBlocks;
LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader;
while (LPLargeBlock <> @LargeBlocksCircularList) do
begin
LLargeBlockSize := LPLargeBlock.BlockSizeAndFlags and DropMediumAndLargeFlagsMask;
Inc(AMemoryManagerState.AllocatedLargeBlockCount);
Inc(AMemoryManagerState.ReservedLargeBlockAddressSpace, LLargeBlockSize);
Inc(AMemoryManagerState.TotalAllocatedLargeBlockSize, LPLargeBlock.UserAllocatedSize);
{Get the next large block}
LPLargeBlock := LPLargeBlock.NextLargeBlockHeader;
end;
LargeBlocksLocked := False;
end;
{$ifndef Linux}
{Gets the state of every 64K block in the 4GB address space}
procedure GetMemoryMap(var AMemoryMap: TMemoryMap);
var
LPMediumBlockPoolHeader: PMediumBlockPoolHeader;
LPLargeBlock: PLargeBlockHeader;
LLargeBlockSize, LChunkIndex, LInd: Cardinal;
LMBI: TMemoryBasicInformation;
begin
{Clear the map}
FillChar(AMemoryMap, SizeOf(AMemoryMap), ord(csUnallocated));
{Step through all the medium block pools}
LockMediumBlocks;
LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader;
while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do
begin
{Add to the medium block used space}
LChunkIndex := Cardinal(LPMediumBlockPoolHeader) shr 16;
for LInd := 0 to (MediumBlockPoolSize - 1) shr 16 do
AMemoryMap[LChunkIndex + LInd] := csAllocated;
{Get the next medium block pool}
LPMediumBlockPoolHeader := LPMediumBlockPoolHeader.NextMediumBlockPoolHeader;
end;
MediumBlocksLocked := False;
{Step through all the large blocks}
LockLargeBlocks;
LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader;
while (LPLargeBlock <> @LargeBlocksCircularList) do
begin
LChunkIndex := Cardinal(LPLargeBlock) shr 16;
LLargeBlockSize := LPLargeBlock.BlockSizeAndFlags and DropMediumAndLargeFlagsMask;
for LInd := 0 to (LLargeBlockSize - 1) shr 16 do
AMemoryMap[LChunkIndex + LInd] := csAllocated;
{Get the next large block}
LPLargeBlock := LPLargeBlock.NextLargeBlockHeader;
end;
LargeBlocksLocked := False;
{Fill in the rest of the map}
for LInd := 0 to 65535 do
begin
{If the chunk is not allocated by this MM, what is its status?}
if AMemoryMap[LInd] = csUnallocated then
begin
{Get all the reserved memory blocks and windows allocated memory blocks, etc.}
VirtualQuery(Pointer(LInd * 65536), LMBI, SizeOf(LMBI));
if LMBI.State = MEM_COMMIT then
AMemoryMap[LInd] := csSysAllocated
else
if LMBI.State = MEM_RESERVE then
AMemoryMap[LInd] := csSysReserved;
end;
end;
end;
{$endif}
{Returns summarised information about the state of the memory manager. (For
backward compatibility.)}
function FastGetHeapStatus: THeapStatus;
var
LPMediumBlockPoolHeader: PMediumBlockPoolHeader;
LPMediumBlock: Pointer;
LBlockTypeIndex, LMediumBlockSize, LMediumBlockHeader, LLargeBlockSize,
LSmallBlockUsage, LSmallBlockOverhead: Cardinal;
LInd: Integer;
LPLargeBlock: PLargeBlockHeader;
begin
{Clear the structure}
FillChar(Result, SizeOf(Result), 0);
{Lock all small block types}
LockAllSmallBlockTypes;
{Lock the medium blocks}
LockMediumBlocks;
{Step through all the medium block pools}
LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader;
while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do
begin
{Add to the total and committed address space}
Inc(Result.TotalAddrSpace, ((MediumBlockPoolSize + $ffff) and $ffff0000));
Inc(Result.TotalCommitted, ((MediumBlockPoolSize + $ffff) and $ffff0000));
{Add the medium block pool overhead}
Inc(Result.Overhead, (((MediumBlockPoolSize + $ffff) and $ffff0000)
- MediumBlockPoolSize + MediumBlockPoolHeaderSize));
{Get the first medium block in the pool}
LPMediumBlock := GetFirstMediumBlockInPool(LPMediumBlockPoolHeader);
while LPMediumBlock <> nil do
begin
{Get the block header}
LMediumBlockHeader := PCardinal(Cardinal(LPMediumBlock) - 4)^;
{Get the block size}
LMediumBlockSize := LMediumBlockHeader and DropMediumAndLargeFlagsMask;
{Is the block in use?}
if LMediumBlockHeader and IsFreeBlockFlag = 0 then
begin
if (LMediumBlockHeader and IsSmallBlockPoolInUseFlag) <> 0 then
begin
{Get the block type index}
LBlockTypeIndex := (Cardinal(PSmallBlockPoolHeader(LPMediumBlock).BlockType) - Cardinal(@SmallBlockTypes[0])) div SizeOf(TSmallBlockType);
{Get the usage in the block}
LSmallBlockUsage := PSmallBlockPoolHeader(LPMediumBlock).BlocksInUse
* SmallBlockTypes[LBlockTypeIndex].BlockSize;
{Get the total overhead for all the small blocks}
LSmallBlockOverhead := PSmallBlockPoolHeader(LPMediumBlock).BlocksInUse
* (BlockHeaderSize{$ifdef FullDebugMode} + FullDebugBlockOverhead{$endif});
{Add to the totals}
Inc(Result.FreeSmall, LMediumBlockSize - LSmallBlockUsage - BlockHeaderSize);
Inc(Result.Overhead, LSmallBlockOverhead + BlockHeaderSize);
Inc(Result.TotalAllocated, LSmallBlockUsage - LSmallBlockOverhead);
end
else
begin
{$ifdef FullDebugMode}
Dec(LMediumBlockSize, FullDebugBlockOverhead);
Inc(Result.Overhead, FullDebugBlockOverhead);
{$endif}
{Add to the result}
Inc(Result.TotalAllocated, LMediumBlockSize - BlockHeaderSize);
Inc(Result.Overhead, BlockHeaderSize);
end;
end
else
begin
{The medium block is free}
Inc(Result.FreeBig, LMediumBlockSize);
end;
{Next medium block}
LPMediumBlock := NextMediumBlock(LPMediumBlock);
end;
{Get the next medium block pool}
LPMediumBlockPoolHeader := LPMediumBlockPoolHeader.NextMediumBlockPoolHeader;
end;
{Add the sequential feed unused space}
Inc(Result.Unused, MediumSequentialFeedBytesLeft);
{Unlock the medium blocks}
MediumBlocksLocked := False;
{Unlock all the small block types}
for LInd := 0 to NumSmallBlockTypes - 1 do
SmallBlockTypes[LInd].BlockTypeLocked := False;
{Step through all the large blocks}
LockLargeBlocks;
LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader;
while (LPLargeBlock <> @LargeBlocksCircularList) do
begin
LLargeBlockSize := LPLargeBlock.BlockSizeAndFlags and DropMediumAndLargeFlagsMask;
Inc(Result.TotalAddrSpace, LLargeBlockSize);
Inc(Result.TotalCommitted, LLargeBlockSize);
Inc(Result.TotalAllocated, LPLargeBlock.UserAllocatedSize
{$ifdef FullDebugMode} - FullDebugBlockOverhead{$endif});
Inc(Result.Overhead, LLargeBlockSize - LPLargeBlock.UserAllocatedSize
{$ifdef FullDebugMode} + FullDebugBlockOverhead{$endif});
{Get the next large block}
LPLargeBlock := LPLargeBlock.NextLargeBlockHeader;
end;
LargeBlocksLocked := False;
{Set the total number of free bytes}
Result.TotalFree := Result.FreeSmall + Result.FreeBig + Result.Unused;
end;
{Frees all allocated memory.}
procedure FreeAllMemory;
var
LPMediumBlockPoolHeader, LPNextMediumBlockPoolHeader: PMediumBlockPoolHeader;
LPMediumFreeBlock: PMediumFreeBlock;
LPLargeBlock, LPNextLargeBlock: PLargeBlockHeader;
LInd: integer;
begin
{Free all block pools}
LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader;
while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do
begin
{Get the next medium block pool so long}
LPNextMediumBlockPoolHeader := LPMediumBlockPoolHeader.NextMediumBlockPoolHeader;
{Free this pool}
VirtualFree(LPMediumBlockPoolHeader, 0, MEM_RELEASE);
{Next pool}
LPMediumBlockPoolHeader := LPNextMediumBlockPoolHeader;
end;
{Clear all small block types}
for LInd := 0 to high(SmallBlockTypes) do
begin
SmallBlockTypes[Lind].PreviousPartiallyFreePool := @SmallBlockTypes[Lind];
SmallBlockTypes[Lind].NextPartiallyFreePool := @SmallBlockTypes[Lind];
SmallBlockTypes[Lind].NextSequentialFeedBlockAddress := pointer(1);
SmallBlockTypes[Lind].MaxSequentialFeedBlockAddress := nil;
end;
{Clear all medium block pools}
MediumBlockPoolsCircularList.PreviousMediumBlockPoolHeader := @MediumBlockPoolsCircularList;
MediumBlockPoolsCircularList.NextMediumBlockPoolHeader := @MediumBlockPoolsCircularList;
{All medium bins are empty}
for LInd := 0 to high(MediumBlockBins) do
begin
LPMediumFreeBlock := @MediumBlockBins[LInd];
LPMediumFreeBlock.PreviousFreeBlock := LPMediumFreeBlock;
LPMediumFreeBlock.NextFreeBlock := LPMediumFreeBlock;
end;
{Free all large blocks}
LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader;
while LPLargeBlock <> @LargeBlocksCircularList do
begin
{Get the next large block}
LPNextLargeBlock := LPLargeBlock.NextLargeBlockHeader;
{Free this large block}
VirtualFree(LPLargeBlock, 0, MEM_RELEASE);
{Next large block}
LPLargeBlock := LPNextLargeBlock;
end;
{There are no large blocks allocated}
LargeBlocksCircularList.PreviousLargeBlockHeader := @LargeBlocksCircularList;
LargeBlocksCircularList.NextLargeBlockHeader := @LargeBlocksCircularList;
end;
{----------------------------Memory Manager Setup-----------------------------}
{Checks that no other memory manager has been installed after the RTL MM and
that there are currently no live pointers allocated through the RTL MM.}
function CheckCanInstallMemoryManager: boolean;
{$ifndef NoMessageBoxes}
var
LErrorMessageTitle: array[0..1023] of char;
{$endif}
begin
{Default to error}
Result := False;
{Is FastMM already installed?}
if FastMMIsInstalled then
begin
{$ifdef UseOutputDebugString}
OutputDebugString(AlreadyInstalledMsg);
{$endif}
{$ifndef NoMessageBoxes}
AppendStringToModuleName(AlreadyInstalledTitle, LErrorMessageTitle);
MessageBox(0, AlreadyInstalledMsg, LErrorMessageTitle,
MB_OK or MB_ICONERROR or MB_TASKMODAL);
{$endif}
exit;
end;
{Has another MM been set, or has the Borland MM been used? If so, this file
is not the first unit in the uses clause of the project's .dpr file.}
if IsMemoryManagerSet then
begin
{When using runtime packages, another library may already have installed
FastMM: Silently ignore the installation request.}
{$ifndef UseRuntimePackages}
{Another memory manager has been set.}
{$ifdef UseOutputDebugString}
OutputDebugString(OtherMMInstalledMsg);
{$endif}
{$ifndef NoMessageBoxes}
AppendStringToModuleName(OtherMMInstalledTitle, LErrorMessageTitle);
MessageBox(0, OtherMMInstalledMsg, LErrorMessageTitle,
MB_OK or MB_ICONERROR or MB_TASKMODAL);
{$endif}
{$endif}
exit;
end;
{$ifndef Linux}
if (GetHeapStatus.TotalAllocated <> 0) then
begin
{Memory has been already been allocated with the RTL MM}
{$ifdef UseOutputDebugString}
OutputDebugString(MemoryAllocatedMsg);
{$endif}
{$ifndef NoMessageBoxes}
AppendStringToModuleName(MemoryAllocatedTitle, LErrorMessageTitle);
MessageBox(0, MemoryAllocatedMsg, LErrorMessageTitle,
MB_OK or MB_ICONERROR or MB_TASKMODAL);
{$endif}
exit;
end;
{$endif}
{All OK}
Result := True;
end;
{Initializes the lookup tables for the memory manager}
procedure InitializeMemoryManager;
var
i, LSizeInd, LMinimumPoolSize, LOptimalPoolSize, LGroupNumber,
LBlocksPerPool, LPreviousBlockSize: Cardinal;
LPMediumFreeBlock: PMediumFreeBlock;
begin
{$ifdef EnableMMX}
{$ifndef ForceMMX}
UseMMX := MMX_Supported;
{$endif}
{$endif}
{Initialize the memory manager}
{-------------Set up the small block types-------------}
LPreviousBlockSize := 0;
for i := 0 to high(SmallBlockTypes) do
begin
{Set the move procedure}
{$ifdef UseCustomFixedSizeMoveRoutines}
{The upsize move procedure may move chunks in 16 bytes even with 8-byte
alignment, since the new size will always be at least 8 bytes bigger than
the old size.}
if not Assigned(SmallBlockTypes[i].UpsizeMoveProcedure) then
{$ifdef UseCustomVariableSizeMoveRoutines}
SmallBlockTypes[i].UpsizeMoveProcedure := MoveX16L4;
{$else}
SmallBlockTypes[i].UpsizeMoveProcedure := @System.Move;
{$endif}
{$endif}
{Set the first "available pool" to the block type itself, so that the
allocation routines know that there are currently no pools with free
blocks of this size.}
SmallBlockTypes[i].PreviousPartiallyFreePool := @SmallBlockTypes[i];
SmallBlockTypes[i].NextPartiallyFreePool := @SmallBlockTypes[i];
{Set the block size to block type index translation table}
for LSizeInd := (LPreviousBlockSize div SmallBlockGranularity) to ((SmallBlockTypes[i].BlockSize - 1) div SmallBlockGranularity) do
AllocSize2SmallBlockTypeIndX4[LSizeInd] := i * 4;
{Cannot sequential feed yet: Ensure that the next address is greater than
the maximum address}
SmallBlockTypes[i].MaxSequentialFeedBlockAddress := pointer(0);
SmallBlockTypes[i].NextSequentialFeedBlockAddress := pointer(1);
{Get the mask to use for finding a medium block suitable for a block pool}
LMinimumPoolSize :=
((SmallBlockTypes[i].BlockSize * MinimumSmallBlocksPerPool
+ SmallBlockPoolHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset)
and -MediumBlockGranularity) + MediumBlockSizeOffset;
if LMinimumPoolSize < MinimumMediumBlockSize then
LMinimumPoolSize := MinimumMediumBlockSize;
{Get the closest group number for the minimum pool size}
LGroupNumber := (LMinimumPoolSize - MinimumMediumBlockSize + MediumBlockBinsPerGroup * MediumBlockGranularity div 2)
div (MediumBlockBinsPerGroup * MediumBlockGranularity);
{Too large?}
if LGroupNumber > 7 then
LGroupNumber := 7;
{Set the bitmap}
SmallBlockTypes[i].AllowedGroupsForBlockPoolBitmap := Byte(-(1 shl LGroupNumber));
{Set the minimum pool size}
SmallBlockTypes[i].MinimumBlockPoolSize := MinimumMediumBlockSize + LGroupNumber * (MediumBlockBinsPerGroup * MediumBlockGranularity);
{Get the optimal block pool size}
LOptimalPoolSize := ((SmallBlockTypes[i].BlockSize * TargetSmallBlocksPerPool
+ SmallBlockPoolHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset)
and -MediumBlockGranularity) + MediumBlockSizeOffset;
{Limit the optimal pool size to within range}
if LOptimalPoolSize < OptimalSmallBlockPoolSizeLowerLimit then
LOptimalPoolSize := OptimalSmallBlockPoolSizeLowerLimit;
if LOptimalPoolSize > OptimalSmallBlockPoolSizeUpperLimit then
LOptimalPoolSize := OptimalSmallBlockPoolSizeUpperLimit;
{How many blocks will fit in the adjusted optimal size?}
LBlocksPerPool := (LOptimalPoolSize - SmallBlockPoolHeaderSize) div SmallBlockTypes[i].BlockSize;
{Recalculate the optimal pool size to minimize wastage due to a partial
last block.}
SmallBlockTypes[i].OptimalBlockPoolSize :=
((LBlocksPerPool * SmallBlockTypes[i].BlockSize + SmallBlockPoolHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset) and -MediumBlockGranularity) + MediumBlockSizeOffset;
{$ifdef CheckHeapForCorruption}
{Debug checks}
if (SmallBlockTypes[i].OptimalBlockPoolSize < MinimumMediumBlockSize)
or (SmallBlockTypes[i].BlockSize div SmallBlockGranularity * SmallBlockGranularity <> SmallBlockTypes[i].BlockSize) then
begin
{$ifdef BCB6OrDelphi7AndUp}
System.Error(reInvalidPtr);
{$else}
System.RunError(reInvalidPtr);
{$endif}
end;
{$endif}
{Set the previous small block size}
LPreviousBlockSize := SmallBlockTypes[i].BlockSize;
end;
{-------------------Set up the medium blocks-------------------}
{$ifdef CheckHeapForCorruption}
{Check that there are no gaps between where the small blocks end and the
medium blocks start}
if (((MaximumSmallBlockSize - 3) + (MediumBlockGranularity - 1 + BlockHeaderSize - MediumBlockSizeOffset))
and -MediumBlockGranularity) + MediumBlockSizeOffset < MinimumMediumBlockSize then
begin
{$ifdef BCB6OrDelphi7AndUp}
System.Error(reInvalidPtr);
{$else}
System.RunError(reInvalidPtr);
{$endif}
end;
{$endif}
{There are currently no medium block pools}
MediumBlockPoolsCircularList.PreviousMediumBlockPoolHeader := @MediumBlockPoolsCircularList;
MediumBlockPoolsCircularList.NextMediumBlockPoolHeader := @MediumBlockPoolsCircularList;
{All medium bins are empty}
for i := 0 to high(MediumBlockBins) do
begin
LPMediumFreeBlock := @MediumBlockBins[i];
LPMediumFreeBlock.PreviousFreeBlock := LPMediumFreeBlock;
LPMediumFreeBlock.NextFreeBlock := LPMediumFreeBlock;
end;
{------------------Set up the large blocks---------------------}
LargeBlocksCircularList.PreviousLargeBlockHeader := @LargeBlocksCircularList;
LargeBlocksCircularList.NextLargeBlockHeader := @LargeBlocksCircularList;
{------------------Set up the debugging structures---------------------}
{$ifdef FullDebugMode}
{Set up the fake VMT}
{Copy the basic info from the TFreedObject class}
System.Move(Pointer(Integer(TFreedObject) + vmtSelfPtr + 4)^,
FreedObjectVMT.VMTData[vmtSelfPtr + 4], vmtParent - vmtSelfPtr);
PCardinal(@FreedObjectVMT.VMTData[vmtSelfPtr])^ := Cardinal(@FreedObjectVMT.VMTMethods[0]);
{Set up the virtual method table}
for i := 0 to MaxFakeVMTEntries - 1 do
begin
PCardinal(@FreedObjectVMT.VMTMethods[low(FreedObjectVMT.VMTMethods) + Integer(i * 4)])^ :=
Cardinal(@TFreedObject.GetVirtualMethodIndex) + i * 6;
{$ifdef CatchUseOfFreedInterfaces}
VMTBadInterface[i] := @TFreedObject.InterfaceError;
{$endif}
end;
{Set up the default log file name}
SetDefaultMMLogFileName;
{$endif}
end;
{Installs the memory manager (InitializeMemoryManager should be called first)}
procedure InstallMemoryManager;
{$ifndef Linux}
var
i, LCurrentProcessID: Cardinal;
{$endif}
begin
if not FastMMIsInstalled then
begin
{$ifndef Linux}
{$ifdef FullDebugMode}
{Try to reserve the 64K block}
ReservedBlock := VirtualAlloc(Pointer(DebugReservedAddress), 65536, MEM_RESERVE, PAGE_NOACCESS);
{$endif}
{Build a string identifying the current process}
LCurrentProcessID := GetCurrentProcessId;
for i := 0 to 7 do
begin
UniqueProcessIDString[8 - i] :=
HexTable[((LCurrentProcessID shr (i * 4)) and $F)];
{$ifdef EnableSharingWithDefaultMM}
UniqueProcessIDStringBE[8 - i] := UniqueProcessIDString[8 - i];
{$endif}
end;
{$endif}
{$ifdef AttemptToUseSharedMM}
{Is the replacement memory manager already installed for this process?}
MMWindow := FindWindow('STATIC', PChar(@UniqueProcessIDString[1]));
{$ifdef EnableSharingWithDefaultMM}
MMWindowBE := FindWindow('STATIC', PChar(@UniqueProcessIDStringBE[1]));
{$endif}
if (MMWindow = 0)
{$ifdef EnableSharingWithDefaultMM}
and (MMWindowBE = 0)
{$endif}
then
begin
{$endif}
{$ifdef ShareMM}
{Share the MM with other DLLs? - if this DLL is unloaded, then
dependent DLLs will cause a crash.}
{$ifndef ShareMMIfLibrary}
if not IsLibrary then
{$endif}
begin
{No memory manager installed yet - create the invisible window}
MMWindow := CreateWindow('STATIC', PChar(@UniqueProcessIDString[1]),
WS_POPUP, 0, 0, 0, 0, 0, 0, hInstance, nil);
{$ifdef EnableSharingWithDefaultMM}
MMWindowBE := CreateWindow('STATIC', PChar(@UniqueProcessIDStringBE[1]),
WS_POPUP, 0, 0, 0, 0, 0, 0, hInstance, nil);
{$endif}
{The window data is a pointer to this memory manager}
if MMWindow <> 0 then
SetWindowLong(MMWindow, GWL_USERDATA, Integer(@NewMemoryManager));
{$ifdef EnableSharingWithDefaultMM}
if MMWindowBE <> 0 then
SetWindowLong(MMWindowBE, GWL_USERDATA, Integer(@NewMemoryManager));
{$endif}
end;
{$endif}
{We will be using this memory manager}
{$ifndef FullDebugMode}
NewMemoryManager.GetMem := FastGetMem;
NewMemoryManager.FreeMem := FastFreeMem;
NewMemoryManager.ReallocMem := FastReallocMem;
{$else}
NewMemoryManager.GetMem := DebugGetMem;
NewMemoryManager.FreeMem := DebugFreeMem;
NewMemoryManager.ReallocMem := DebugReallocMem;
{$endif}
{$ifdef BDS2006AndUp}
{$ifndef FullDebugMode}
NewMemoryManager.AllocMem := FastAllocMem;
{$else}
NewMemoryManager.AllocMem := DebugAllocMem;
{$endif}
NewMemoryManager.RegisterExpectedMemoryLeak := RegisterExpectedMemoryLeak;
NewMemoryManager.UnRegisterExpectedMemoryLeak := UnRegisterExpectedMemoryLeak;
{$endif}
{Owns the MMWindow}
IsMemoryManagerOwner := True;
{$ifdef AttemptToUseSharedMM}
end
else
begin
{Get the address of the shared memory manager}
{$ifndef BDS2006AndUp}
{$ifdef EnableSharingWithDefaultMM}
if MMWindow <> 0 then
begin
{$endif}
NewMemoryManager := PMemoryManager(GetWindowLong(MMWindow, GWL_USERDATA))^;
{$ifdef EnableSharingWithDefaultMM}
end
else
begin
NewMemoryManager := PMemoryManager(GetWindowLong(MMWindowBE, GWL_USERDATA))^;
end;
{$endif}
{$else}
{$ifdef EnableSharingWithDefaultMM}
if MMWindow <> 0 then
begin
{$endif}
NewMemoryManager := PMemoryManagerEx(GetWindowLong(MMWindow, GWL_USERDATA))^;
{$ifdef EnableSharingWithDefaultMM}
end
else
begin
NewMemoryManager := PMemoryManagerEx(GetWindowLong(MMWindowBE, GWL_USERDATA))^;
end;
{$endif}
{$endif}
{The MMWindow is owned by the main program (not this DLL)}
IsMemoryManagerOwner := False;
end;
{$endif}
{Save the old memory manager}
GetMemoryManager(OldMemoryManager);
{Replace the memory manager with either this one or the shared one.}
SetMemoryManager(NewMemoryManager);
{FastMM is now installed}
FastMMIsInstalled := True;
{$ifdef UseOutputDebugString}
if IsMemoryManagerOwner then
OutputDebugString(FastMMInstallMsg)
else
OutputDebugString(FastMMInstallSharedMsg);
{$endif}
end;
end;
procedure UninstallMemoryManager;
begin
{Is this the owner of the shared MM window?}
if IsMemoryManagerOwner then
begin
{$ifdef ShareMM}
{Destroy the window}
if MMWindow <> 0 then
begin
DestroyWindow(MMWindow);
MMWindow := 0;
end;
{$ifdef EnableSharingWithDefaultMM}
if MMWindowBE <> 0 then
begin
DestroyWindow(MMWindowBE);
MMWindowBE := 0;
end;
{$endif}
{$endif}
{$ifdef FullDebugMode}
{Release the reserved block}
if ReservedBlock <> nil then
begin
VirtualFree(ReservedBlock, 0, MEM_RELEASE);
ReservedBlock := nil;
end;
{$endif}
end;
{$ifndef DetectMMOperationsAfterUninstall}
{Restore the old memory manager}
SetMemoryManager(OldMemoryManager);
{$else}
{Set the invalid memory manager: no more MM operations allowed}
SetMemoryManager(InvalidMemoryManager);
{$endif}
{Memory manager has been uninstalled}
FastMMIsInstalled := False;
{$ifdef UseOutputDebugString}
if IsMemoryManagerOwner then
OutputDebugString(FastMMuninstallMsg)
else
OutputDebugString(FastMMUninstallSharedMsg);
{$endif}
end;
initialization
{$ifndef BCB}
{Initialize all the lookup tables, etc. for the memory manager}
InitializeMemoryManager;
{Has another MM been set, or has the Borland MM been used? If so, this file
is not the first unit in the uses clause of the project's .dpr file.}
if CheckCanInstallMemoryManager then
begin
{$ifdef ClearLogFileOnStartup}
DeleteEventLog;
{$endif}
InstallMemoryManager;
end;
{$endif}
finalization
{Restore the old memory manager if FastMM has been installed}
if FastMMIsInstalled then
begin
{$ifndef NeverUninstall}
{Uninstall FastMM}
UninstallMemoryManager;
{$endif}
{Do we own the memory manager, or are we just sharing it?}
if IsMemoryManagerOwner then
begin
{$ifdef CheckUseOfFreedBlocksOnShutdown}
CheckBlocksOnShutdown(
{$ifdef EnableMemoryLeakReporting}
True
{$ifdef RequireIDEPresenceForLeakReporting}
and DelphiIsRunning
{$endif}
{$ifdef RequireDebuggerPresenceForLeakReporting}
and (DebugHook <> 0)
{$endif}
{$ifdef ManualLeakReportingControl}
and ReportMemoryLeaksOnShutdown
{$endif}
{$else}
False
{$endif}
);
{$else}
{$ifdef EnableMemoryLeakReporting}
if True
{$ifdef RequireIDEPresenceForLeakReporting}
and DelphiIsRunning
{$endif}
{$ifdef RequireDebuggerPresenceForLeakReporting}
and (DebugHook <> 0)
{$endif}
{$ifdef ManualLeakReportingControl}
and ReportMemoryLeaksOnShutdown
{$endif}
then
CheckBlocksOnShutdown(True);
{$endif}
{$endif}
{$ifdef EnableMemoryLeakReporting}
{Free the expected memory leaks list}
if ExpectedMemoryLeaks <> nil then
begin
VirtualFree(ExpectedMemoryLeaks, 0, MEM_RELEASE);
ExpectedMemoryLeaks := nil;
end;
{$endif}
{$ifndef NeverUninstall}
{Clean up: Free all memory. If this is a .DLL that owns its own MM, then
it is necessary to prevent the main application from running out of
address space.}
FreeAllMemory;
{$endif}
end;
end;
end.