diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000..0ea90a0 --- /dev/null +++ b/.gitmodules @@ -0,0 +1,3 @@ +[submodule "submodules/FastMM4"] + path = submodules/FastMM4 + url = https://github.com/pleriche/FastMM4 diff --git a/Readme.markdown b/Readme.markdown index cfdfce1..9d69a90 100644 --- a/Readme.markdown +++ b/Readme.markdown @@ -1 +1 @@ -Command line program to analyze Borland Delphi's source code to provide information about the cyclomatic complexity, uses dependency tree and other factors. +Command line program to analyze Embarcadero Delphi's source code to provide information about the cyclomatic complexity, uses dependency tree and other factors. diff --git a/components/fastmm/CPP Builder Support/FastMM4BCB.cpp b/components/fastmm/CPP Builder Support/FastMM4BCB.cpp deleted file mode 100644 index 1b950c8..0000000 --- a/components/fastmm/CPP Builder Support/FastMM4BCB.cpp +++ /dev/null @@ -1,62 +0,0 @@ -/* - -Fast Memory Manager: BCB support 1.01 - -Description: - FastMM support unit for BCB6 1.0. Loads FastMM4 on startup of the Borland C++ - Builder application or DLL. - -Usage: - 1) Under the Project -> Options -> Linker menu uncheck "Use Dynamic RTL" - (sorry, won't work with the RTL DLL). - 2) Add FastMM4.pas to your project and build it so that FastMM4.hpp is - created. - 3) Add FastMM4BCB.cpp to your project. - FastMM will now install itself on startup and replace the RTL memory manager. - -Acknowledgements: - - Jarek Karciarz, Vladimir Ulchenko (Vavan) and Bob Gonder for their help in - implementing the BCB support. - -Notes: - FastMM cannot uninstall itself under BCB, so memory leak checking is not - available. Also, since it cannot be uninstalled you should only use it in - dynamically loaded DLLs that will be sharing the main application's MM - - otherwise memory will be leaked every time you unload the DLL. Unfortunately - there is nothing I can do about the situation. The __exit procedure in exit.c - calls all finalization routines before it has properly freed all memory. With - live pointers still around, FastMM cannot uninstall itself. Not a good - situation, and the only solution I see at this stage would be to patch the - RTL. - -Change log: - Version 1.00 (15 June 2005): - - Initial release. Due to limitations of BCB it cannot be uninstalled (thus - no leak checking and not useable in DLLs unless the DLL always shares the - main application's MM). Thanks to Jarek Karciarz, Vladimir Ulchenko and Bob - Gonder for their help. - Version 1.01 (6 August 2005): - - Fixed a regression bug (Thanks to Omar Zelaya). - -*/ - -#pragma hdrstop -#include "FastMM4.hpp" - -void BCBInstallFastMM() -{ - InitializeMemoryManager(); - if (CheckCanInstallMemoryManager()) - { - InstallMemoryManager(); - } -} -#pragma startup BCBInstallFastMM 0 - -void BCBUninstallFastMM() -{ - //Sadly we cannot uninstall here since there are still live pointers. -} -#pragma exit BCBUninstallFastMM 0 - - diff --git a/components/fastmm/Demos/Dynamically Loaded DLL/ApplicationForm.dfm b/components/fastmm/Demos/Dynamically Loaded DLL/ApplicationForm.dfm deleted file mode 100644 index a6582f3..0000000 --- a/components/fastmm/Demos/Dynamically Loaded DLL/ApplicationForm.dfm +++ /dev/null @@ -1,47 +0,0 @@ -object fAppMain: TfAppMain - Left = 0 - Top = 0 - Caption = 'FastMM Sharing Test Application' - ClientHeight = 208 - ClientWidth = 300 - Color = clBtnFace - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'Tahoma' - Font.Style = [] - OldCreateOrder = False - Position = poScreenCenter - PixelsPerInch = 96 - TextHeight = 13 - object Button1: TButton - Left = 8 - Top = 172 - Width = 281 - Height = 25 - Caption = 'Load DLL and Display DLL Form' - TabOrder = 0 - OnClick = Button1Click - end - object Memo1: TMemo - Left = 8 - Top = 8 - Width = 281 - Height = 157 - Enabled = False - Lines.Strings = ( - 'This application shows how to share FastMM between ' - 'an application and dynamically loaded DLL, without ' - 'using the borlndmm.dll library.' - '' - 'Click the button to load the test DLL and display its ' - 'form.' - '' - 'The relevant settings for this application:' - '1) FastMM4.pas is the first unit in the uses clause ' - '2) The "ShareMM" option is enabled' - '3) "Use Runtime Packages" is disabled' - '') - TabOrder = 1 - end -end diff --git a/components/fastmm/Demos/Dynamically Loaded DLL/ApplicationForm.pas b/components/fastmm/Demos/Dynamically Loaded DLL/ApplicationForm.pas deleted file mode 100644 index 8ad8bfe..0000000 --- a/components/fastmm/Demos/Dynamically Loaded DLL/ApplicationForm.pas +++ /dev/null @@ -1,51 +0,0 @@ -unit ApplicationForm; - -interface - -uses - Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, - Dialogs, StdCtrls; - -type - TfAppMain = class(TForm) - Button1: TButton; - Memo1: TMemo; - procedure Button1Click(Sender: TObject); - private - { Private declarations } - public - { Public declarations } - end; - -var - fAppMain: TfAppMain; - -implementation - -{$R *.dfm} - -procedure TfAppMain.Button1Click(Sender: TObject); -var - LDLLHandle: HModule; - LShowProc: TProcedure; -begin - LDLLHandle := LoadLibrary('TestDLL.dll'); - if LDLLHandle <> 0 then - begin - try - LShowProc := GetProcAddress(LDLLHandle, 'ShowDLLForm'); - if Assigned(LShowProc) then - begin - LShowProc; - end - else - ShowMessage('The ShowDLLForm procedure could not be found in the DLL.'); - finally - FreeLibrary(LDLLHandle); - end; - end - else - ShowMessage('The DLL was not found. Please compile the DLL before running this application.'); -end; - -end. diff --git a/components/fastmm/Demos/Dynamically Loaded DLL/DLLForm.dfm b/components/fastmm/Demos/Dynamically Loaded DLL/DLLForm.dfm deleted file mode 100644 index b5d27f4..0000000 --- a/components/fastmm/Demos/Dynamically Loaded DLL/DLLForm.dfm +++ /dev/null @@ -1,54 +0,0 @@ -object fDLLMain: TfDLLMain - Left = 0 - Top = 0 - Caption = 'FastMM Sharing DLL Form' - ClientHeight = 185 - ClientWidth = 337 - Color = clBtnFace - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'Tahoma' - Font.Style = [] - OldCreateOrder = False - PixelsPerInch = 96 - TextHeight = 13 - object Button1: TButton - Left = 8 - Top = 152 - Width = 165 - Height = 25 - Caption = 'Click to leak some memory' - TabOrder = 0 - OnClick = Button1Click - end - object Memo1: TMemo - Left = 8 - Top = 8 - Width = 317 - Height = 137 - Enabled = False - Lines.Strings = ( - 'This DLL is sharing the memory manager of the main ' - 'application. ' - '' - 'The following settings were used to achieve this:' - - '1) FastMM4.pas is the first unit in the "uses" clause of the .dp' + - 'r' - '2) The "ShareMM" option is enabled.' - '3) The "AttemptToUseSharedMM" option is enabled.' - '' - 'Click the button to leak some memory.') - TabOrder = 1 - end - object Button2: TButton - Left = 180 - Top = 152 - Width = 145 - Height = 25 - Caption = 'Unload DLL' - TabOrder = 2 - OnClick = Button2Click - end -end diff --git a/components/fastmm/Demos/Dynamically Loaded DLL/DLLForm.pas b/components/fastmm/Demos/Dynamically Loaded DLL/DLLForm.pas deleted file mode 100644 index 5d5000c..0000000 --- a/components/fastmm/Demos/Dynamically Loaded DLL/DLLForm.pas +++ /dev/null @@ -1,39 +0,0 @@ -unit DLLForm; - -interface - -uses - Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, - Dialogs, StdCtrls; - -type - TfDLLMain = class(TForm) - Button1: TButton; - Memo1: TMemo; - Button2: TButton; - procedure Button1Click(Sender: TObject); - procedure Button2Click(Sender: TObject); - private - { Private declarations } - public - { Public declarations } - end; - -var - fDLLMain: TfDLLMain; - -implementation - -{$R *.dfm} - -procedure TfDLLMain.Button1Click(Sender: TObject); -begin - TObject.Create; -end; - -procedure TfDLLMain.Button2Click(Sender: TObject); -begin - Close; -end; - -end. diff --git a/components/fastmm/Demos/Dynamically Loaded DLL/DynamicallyLoadedDLLDemo.bdsgroup b/components/fastmm/Demos/Dynamically Loaded DLL/DynamicallyLoadedDLLDemo.bdsgroup deleted file mode 100644 index a3617a6..0000000 --- a/components/fastmm/Demos/Dynamically Loaded DLL/DynamicallyLoadedDLLDemo.bdsgroup +++ /dev/null @@ -1,20 +0,0 @@ - - - - - - - - - - - - - TestApplication.bdsproj - TestDLL.bdsproj - TestApplication.exe TestDLL.dll - - - - diff --git a/components/fastmm/Demos/Dynamically Loaded DLL/TestApplication.bdsproj b/components/fastmm/Demos/Dynamically Loaded DLL/TestApplication.bdsproj deleted file mode 100644 index 1f92211..0000000 --- a/components/fastmm/Demos/Dynamically Loaded DLL/TestApplication.bdsproj +++ /dev/null @@ -1,177 +0,0 @@ - - - - - - - - - - - - TestApplication.dpr - - - 7.0 - - - 8 - 0 - 1 - 1 - 0 - 0 - 1 - 1 - 1 - 0 - 0 - 1 - 0 - 1 - 1 - 1 - 0 - 0 - 0 - 0 - 0 - 1 - 0 - 1 - 1 - 1 - True - True - WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; - - False - - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - False - False - False - True - True - True - True - True - True - - - - 0 - 0 - False - 1 - False - False - False - 16384 - 1048576 - 4194304 - - - - - - - - - - ShareMM - - False - - - - - - False - - - True - False - - - - $00000000 - - - - False - False - 1 - 0 - 0 - 0 - False - False - False - False - False - 7177 - 1252 - - - - - 1.0.0.0 - - - - - - 1.0.0.0 - - - - - - diff --git a/components/fastmm/Demos/Dynamically Loaded DLL/TestApplication.cfg b/components/fastmm/Demos/Dynamically Loaded DLL/TestApplication.cfg deleted file mode 100644 index d4108e2..0000000 --- a/components/fastmm/Demos/Dynamically Loaded DLL/TestApplication.cfg +++ /dev/null @@ -1,39 +0,0 @@ --$A8 --$B- --$C+ --$D+ --$E- --$F- --$G+ --$H+ --$I+ --$J- --$K- --$L+ --$M- --$N+ --$O+ --$P+ --$Q- --$R- --$S- --$T- --$U- --$V+ --$W- --$X+ --$YD --$Z1 --cg --AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; --H+ --W+ --M --$M16384,1048576 --K$00400000 --LE"C:\Documents and Settings\Administrator\My Documents\Borland Studio Projects\Bpl" --LN"C:\Documents and Settings\Administrator\My Documents\Borland Studio Projects\Bpl" --DShareMM --w-UNSAFE_TYPE --w-UNSAFE_CODE --w-UNSAFE_CAST diff --git a/components/fastmm/Demos/Dynamically Loaded DLL/TestApplication.dpr b/components/fastmm/Demos/Dynamically Loaded DLL/TestApplication.dpr deleted file mode 100644 index 4451ed7..0000000 --- a/components/fastmm/Demos/Dynamically Loaded DLL/TestApplication.dpr +++ /dev/null @@ -1,14 +0,0 @@ -program TestApplication; - -uses - FastMM4, - Forms, - ApplicationForm in 'ApplicationForm.pas' {fAppMain}; - -{$R *.res} - -begin - Application.Initialize; - Application.CreateForm(TfAppMain, fAppMain); - Application.Run; -end. diff --git a/components/fastmm/Demos/Dynamically Loaded DLL/TestApplication.res b/components/fastmm/Demos/Dynamically Loaded DLL/TestApplication.res deleted file mode 100644 index fcbd537..0000000 Binary files a/components/fastmm/Demos/Dynamically Loaded DLL/TestApplication.res and /dev/null differ diff --git a/components/fastmm/Demos/Dynamically Loaded DLL/TestDLL.bdsproj b/components/fastmm/Demos/Dynamically Loaded DLL/TestDLL.bdsproj deleted file mode 100644 index 70515cd..0000000 --- a/components/fastmm/Demos/Dynamically Loaded DLL/TestDLL.bdsproj +++ /dev/null @@ -1,175 +0,0 @@ - - - - - - - - - - - - TestDLL.dpr - - - 7.0 - - - 8 - 0 - 1 - 1 - 0 - 0 - 1 - 1 - 1 - 0 - 0 - 1 - 0 - 1 - 1 - 1 - 0 - 0 - 0 - 0 - 0 - 1 - 0 - 1 - 1 - 1 - True - True - WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; - - False - - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - False - False - False - True - True - True - True - True - True - - - - 0 - 0 - False - 1 - False - False - False - 16384 - 1048576 - 4194304 - - - - - - - - - - ShareMM;AttemptToUseSharedMM - - False - - - - - - False - - - True - False - - - - $00000000 - - - - False - False - 1 - 0 - 0 - 0 - False - False - False - False - False - 7177 - 1252 - - - - - 1.0.0.0 - - - - - - 1.0.0.0 - - - - diff --git a/components/fastmm/Demos/Dynamically Loaded DLL/TestDLL.cfg b/components/fastmm/Demos/Dynamically Loaded DLL/TestDLL.cfg deleted file mode 100644 index c44cd0e..0000000 --- a/components/fastmm/Demos/Dynamically Loaded DLL/TestDLL.cfg +++ /dev/null @@ -1,39 +0,0 @@ --$A8 --$B- --$C+ --$D+ --$E- --$F- --$G+ --$H+ --$I+ --$J- --$K- --$L+ --$M- --$N+ --$O+ --$P+ --$Q- --$R- --$S- --$T- --$U- --$V+ --$W- --$X+ --$YD --$Z1 --cg --AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; --H+ --W+ --M --$M16384,1048576 --K$00400000 --LE"C:\Documents and Settings\Administrator\My Documents\Borland Studio Projects\Bpl" --LN"C:\Documents and Settings\Administrator\My Documents\Borland Studio Projects\Bpl" --DShareMM;AttemptToUseSharedMM --w-UNSAFE_TYPE --w-UNSAFE_CODE --w-UNSAFE_CAST diff --git a/components/fastmm/Demos/Dynamically Loaded DLL/TestDLL.dpr b/components/fastmm/Demos/Dynamically Loaded DLL/TestDLL.dpr deleted file mode 100644 index db866e4..0000000 --- a/components/fastmm/Demos/Dynamically Loaded DLL/TestDLL.dpr +++ /dev/null @@ -1,26 +0,0 @@ -library TestDLL; - -uses - FastMM4, - SysUtils, - Classes, - DLLForm in 'DLLForm.pas' {fDLLMain}; - -{$R *.res} - -procedure ShowDLLForm; -begin - with TfDLLMain.Create(nil) do - begin - try - ShowModal; - finally - Free; - end; - end; -end; - -exports ShowDllForm; - -begin -end. diff --git a/components/fastmm/Demos/Dynamically Loaded DLL/TestDLL.res b/components/fastmm/Demos/Dynamically Loaded DLL/TestDLL.res deleted file mode 100644 index fcbd537..0000000 Binary files a/components/fastmm/Demos/Dynamically Loaded DLL/TestDLL.res and /dev/null differ diff --git a/components/fastmm/Demos/Replacement borlndmm DLL/BorlndMM.dll b/components/fastmm/Demos/Replacement borlndmm DLL/BorlndMM.dll deleted file mode 100644 index d3ef8ae..0000000 Binary files a/components/fastmm/Demos/Replacement borlndmm DLL/BorlndMM.dll and /dev/null differ diff --git a/components/fastmm/Demos/Replacement borlndmm DLL/DemoForm.dfm b/components/fastmm/Demos/Replacement borlndmm DLL/DemoForm.dfm deleted file mode 100644 index 522b9a3..0000000 --- a/components/fastmm/Demos/Replacement borlndmm DLL/DemoForm.dfm +++ /dev/null @@ -1,44 +0,0 @@ -object Form1: TForm1 - Left = 0 - Top = 0 - Caption = 'borlndmm.dll using FullDebugMode' - ClientHeight = 146 - ClientWidth = 369 - Color = clBtnFace - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'Tahoma' - Font.Style = [] - OldCreateOrder = False - Position = poScreenCenter - PixelsPerInch = 96 - TextHeight = 13 - object Button1: TButton - Left = 24 - Top = 24 - Width = 321 - Height = 25 - Caption = 'Click this button to leak a TObject' - TabOrder = 0 - OnClick = Button1Click - end - object Button2: TButton - Left = 24 - Top = 60 - Width = 321 - Height = 25 - Caption = 'Click this button to test the allocation grouping functionality' - TabOrder = 1 - OnClick = Button2Click - end - object Button3: TButton - Left = 24 - Top = 96 - Width = 321 - Height = 25 - Caption = 'Cause a "virtual method on freed object" error' - TabOrder = 2 - OnClick = Button3Click - end -end diff --git a/components/fastmm/Demos/Replacement borlndmm DLL/DemoForm.pas b/components/fastmm/Demos/Replacement borlndmm DLL/DemoForm.pas deleted file mode 100644 index 76736d5..0000000 --- a/components/fastmm/Demos/Replacement borlndmm DLL/DemoForm.pas +++ /dev/null @@ -1,76 +0,0 @@ -unit DemoForm; - -interface - -uses - Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, - Dialogs, FastMMDebugSupport, StdCtrls; - -type - TForm1 = class(TForm) - Button1: TButton; - Button2: TButton; - Button3: TButton; - procedure Button3Click(Sender: TObject); - procedure Button2Click(Sender: TObject); - procedure Button1Click(Sender: TObject); - private - { Private declarations } - public - { Public declarations } - end; - -var - Form1: TForm1; - -implementation - -{$R *.dfm} - -procedure TForm1.Button1Click(Sender: TObject); -begin - TObject.Create; -end; - -procedure TForm1.Button2Click(Sender: TObject); -var - x, y, z: TObject; -begin - {Set the allocation group to 1} - PushAllocationGroup(1); - {Allocate an object} - x := TPersistent.Create; - {Set the allocation group to 2} - PushAllocationGroup(2); - {Allocate a TControl} - y := TControl.Create(nil); - {Go back to allocation group 1} - PopAllocationGroup; - {Allocate a TWinControl} - z := TWinControl.Create(nil); - {Pop the last group off the stack} - PopAllocationGroup; - {Specify the name of the log file} - SetMMLogFileName('AllocationGroupTest.log'); - {Log all live blocks in groups 1 and 2} - LogAllocatedBlocksToFile(1, 2); - {Restore the default log file name} - SetMMLogFileName(nil); - {Free all the objects} - x.Free; - y.Free; - z.Free; - {Done} - ShowMessage('Allocation detail logged to file.'); -end; - -procedure TForm1.Button3Click(Sender: TObject); -begin - with TObject.Create do - begin - Free; - Free; - end; -end; - -end. diff --git a/components/fastmm/Demos/Replacement borlndmm DLL/FastMM_FullDebugMode.dll b/components/fastmm/Demos/Replacement borlndmm DLL/FastMM_FullDebugMode.dll deleted file mode 100644 index 7f42270..0000000 Binary files a/components/fastmm/Demos/Replacement borlndmm DLL/FastMM_FullDebugMode.dll and /dev/null differ diff --git a/components/fastmm/Demos/Replacement borlndmm DLL/FullDebugModeDemo.cfg b/components/fastmm/Demos/Replacement borlndmm DLL/FullDebugModeDemo.cfg deleted file mode 100644 index b04c097..0000000 --- a/components/fastmm/Demos/Replacement borlndmm DLL/FullDebugModeDemo.cfg +++ /dev/null @@ -1,39 +0,0 @@ --$A8 --$B- --$C+ --$D+ --$E- --$F- --$G+ --$H+ --$I+ --$J- --$K- --$L+ --$M- --$N+ --$O+ --$P+ --$Q- --$R- --$S- --$T- --$U- --$V+ --$W- --$X+ --$YD --$Z1 --cg --vn --AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; --H+ --W+ --M --$M16384,1048576 --K$00400000 --LE"C:\Documents and Settings\Administrator\My Documents\Borland Studio Projects\Bpl" --LN"C:\Documents and Settings\Administrator\My Documents\Borland Studio Projects\Bpl" --w-UNSAFE_TYPE --w-UNSAFE_CODE --w-UNSAFE_CAST diff --git a/components/fastmm/Demos/Replacement borlndmm DLL/FullDebugModeDemo.dpr b/components/fastmm/Demos/Replacement borlndmm DLL/FullDebugModeDemo.dpr deleted file mode 100644 index f3aaa5e..0000000 --- a/components/fastmm/Demos/Replacement borlndmm DLL/FullDebugModeDemo.dpr +++ /dev/null @@ -1,15 +0,0 @@ -program FullDebugModeDemo; - -uses - ShareMem, - Forms, - DemoForm in 'DemoForm.pas' {Form1}, - FastMMDebugSupport in '..\..\Replacement BorlndMM DLL\FastMMDebugSupport.pas'; - -{$R *.res} - -begin - Application.Initialize; - Application.CreateForm(TForm1, Form1); - Application.Run; -end. diff --git a/components/fastmm/Demos/Replacement borlndmm DLL/FullDebugModeDemo.res b/components/fastmm/Demos/Replacement borlndmm DLL/FullDebugModeDemo.res deleted file mode 100644 index fcbd537..0000000 Binary files a/components/fastmm/Demos/Replacement borlndmm DLL/FullDebugModeDemo.res and /dev/null differ diff --git a/components/fastmm/Demos/Usage Tracker/DemoForm.dfm b/components/fastmm/Demos/Usage Tracker/DemoForm.dfm deleted file mode 100644 index 86ef4f2..0000000 --- a/components/fastmm/Demos/Usage Tracker/DemoForm.dfm +++ /dev/null @@ -1,28 +0,0 @@ -object fDemo: TfDemo - Left = 199 - Top = 114 - BorderIcons = [biSystemMenu] - BorderStyle = bsSingle - Caption = 'Usage Tracker Demo' - ClientHeight = 53 - ClientWidth = 239 - Color = clBtnFace - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'MS Sans Serif' - Font.Style = [] - OldCreateOrder = False - Position = poScreenCenter - PixelsPerInch = 96 - TextHeight = 13 - object bShowTracker: TButton - Left = 8 - Top = 8 - Width = 221 - Height = 37 - Caption = 'Show Usage Tracker' - TabOrder = 0 - OnClick = bShowTrackerClick - end -end diff --git a/components/fastmm/Demos/Usage Tracker/DemoForm.pas b/components/fastmm/Demos/Usage Tracker/DemoForm.pas deleted file mode 100644 index 976de6b..0000000 --- a/components/fastmm/Demos/Usage Tracker/DemoForm.pas +++ /dev/null @@ -1,31 +0,0 @@ -unit DemoForm; - -interface - -uses - Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, - Dialogs, StdCtrls, FastMMUsageTracker; - -type - TfDemo = class(TForm) - bShowTracker: TButton; - procedure bShowTrackerClick(Sender: TObject); - private - { Private declarations } - public - { Public declarations } - end; - -var - fDemo: TfDemo; - -implementation - -{$R *.dfm} - -procedure TfDemo.bShowTrackerClick(Sender: TObject); -begin - ShowFastMMUsageTracker; -end; - -end. diff --git a/components/fastmm/Demos/Usage Tracker/FastMMUsageTracker.dfm b/components/fastmm/Demos/Usage Tracker/FastMMUsageTracker.dfm deleted file mode 100644 index 687d2be..0000000 --- a/components/fastmm/Demos/Usage Tracker/FastMMUsageTracker.dfm +++ /dev/null @@ -1,149 +0,0 @@ -object fFastMMUsageTracker: TfFastMMUsageTracker - Left = 259 - Top = 93 - BorderIcons = [biSystemMenu] - BorderStyle = bsSingle - Caption = 'FastMM4 Usage Tracker' - ClientHeight = 566 - ClientWidth = 792 - Color = clBtnFace - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'MS Sans Serif' - Font.Style = [] - OldCreateOrder = False - Position = poScreenCenter - OnClose = FormClose - OnCreate = FormCreate - PixelsPerInch = 96 - TextHeight = 13 - object gbMemoryMap: TGroupBox - Left = 8 - Top = 4 - Width = 301 - Height = 525 - Caption = 'Memory Map' - TabOrder = 0 - object Label1: TLabel - Left = 12 - Top = 496 - Width = 38 - Height = 13 - Caption = 'Address' - end - object Label2: TLabel - Left = 148 - Top = 496 - Width = 25 - Height = 13 - Caption = 'State' - end - object dgMemoryMap: TDrawGrid - Left = 16 - Top = 16 - Width = 277 - Height = 469 - ColCount = 32 - DefaultColWidth = 8 - DefaultRowHeight = 8 - FixedCols = 0 - RowCount = 2048 - FixedRows = 0 - GridLineWidth = 0 - Options = [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine] - ScrollBars = ssVertical - TabOrder = 0 - OnDrawCell = dgMemoryMapDrawCell - OnSelectCell = dgMemoryMapSelectCell - end - object eAddress: TEdit - Left = 56 - Top = 492 - Width = 81 - Height = 21 - Enabled = False - TabOrder = 1 - Text = '$00000000' - end - object eState: TEdit - Left = 184 - Top = 492 - Width = 105 - Height = 21 - Enabled = False - TabOrder = 2 - Text = 'Unallocated' - end - end - object gbBlockStats: TGroupBox - Left = 320 - Top = 4 - Width = 465 - Height = 469 - Caption = 'Block Statistics' - TabOrder = 1 - object sgBlockStatistics: TStringGrid - Left = 12 - Top = 16 - Width = 441 - Height = 441 - DefaultColWidth = 83 - DefaultRowHeight = 17 - Options = [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine] - ScrollBars = ssVertical - TabOrder = 0 - end - end - object bClose: TBitBtn - Left = 708 - Top = 536 - Width = 75 - Height = 25 - Caption = 'Close' - TabOrder = 2 - OnClick = bCloseClick - Glyph.Data = { - 76010000424D7601000000000000760000002800000020000000100000000100 - 04000000000000010000130B0000130B00001000000000000000000000000000 - 800000800000008080008000000080008000808000007F7F7F00BFBFBF000000 - FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333333333333 - 3333333333FFFFF3333333333999993333333333F77777FFF333333999999999 - 33333337777FF377FF3333993370739993333377FF373F377FF3399993000339 - 993337777F777F3377F3393999707333993337F77737333337FF993399933333 - 399377F3777FF333377F993339903333399377F33737FF33377F993333707333 - 399377F333377FF3377F993333101933399377F333777FFF377F993333000993 - 399377FF3377737FF7733993330009993933373FF3777377F7F3399933000399 - 99333773FF777F777733339993707339933333773FF7FFF77333333999999999 - 3333333777333777333333333999993333333333377777333333} - NumGlyphs = 2 - end - object GroupBox1: TGroupBox - Left = 320 - Top = 480 - Width = 465 - Height = 49 - Caption = 'Address Space Usage' - Enabled = False - TabOrder = 3 - object Label3: TLabel - Left = 12 - Top = 20 - Width = 199 - Height = 13 - Caption = 'Total Process Address Space In Use (MB)' - end - object eTotalAddressSpaceInUse: TEdit - Left = 332 - Top = 16 - Width = 121 - Height = 21 - TabOrder = 0 - end - end - object tTimer: TTimer - OnTimer = tTimerTimer - Left = 20 - Top = 24 - end -end diff --git a/components/fastmm/Demos/Usage Tracker/FastMMUsageTracker.pas b/components/fastmm/Demos/Usage Tracker/FastMMUsageTracker.pas deleted file mode 100644 index 9e9075c..0000000 --- a/components/fastmm/Demos/Usage Tracker/FastMMUsageTracker.pas +++ /dev/null @@ -1,261 +0,0 @@ -unit FastMMUsageTracker; - -interface - -uses - Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, - Dialogs, StdCtrls, ExtCtrls, Grids, Buttons, FastMM4; - -type - TfFastMMUsageTracker = class(TForm) - gbMemoryMap: TGroupBox; - gbBlockStats: TGroupBox; - tTimer: TTimer; - sgBlockStatistics: TStringGrid; - dgMemoryMap: TDrawGrid; - bClose: TBitBtn; - Label1: TLabel; - eAddress: TEdit; - Label2: TLabel; - eState: TEdit; - GroupBox1: TGroupBox; - Label3: TLabel; - eTotalAddressSpaceInUse: TEdit; - procedure FormClose(Sender: TObject; var Action: TCloseAction); - procedure tTimerTimer(Sender: TObject); - procedure FormCreate(Sender: TObject); - procedure bCloseClick(Sender: TObject); - procedure dgMemoryMapDrawCell(Sender: TObject; ACol, ARow: Integer; - Rect: TRect; State: TGridDrawState); - procedure dgMemoryMapSelectCell(Sender: TObject; ACol, ARow: Integer; - var CanSelect: Boolean); - private - {The current state} - FMemoryManagerState: TMemoryManagerState; - FMemoryMap: TMemoryMap; - public - {Refreshes the display} - procedure RefreshSnapShot; - end; - -function ShowFastMMUsageTracker: TfFastMMUsageTracker; - -{Gets the number of bytes of virtual memory either reserved or committed by this - process} -function GetAddressSpaceUsed: Cardinal; - -implementation - -{$R *.dfm} - -function ShowFastMMUsageTracker: TfFastMMUsageTracker; -begin - Application.CreateForm(TfFastMMUsageTracker, Result); - Result.RefreshSnapShot; - Result.Show; -end; - -function GetAddressSpaceUsed: Cardinal; -var - LMemoryStatus: TMemoryStatus; -begin - {Set the structure size} - LMemoryStatus.dwLength := SizeOf(LMemoryStatus); - {Get the memory status} - GlobalMemoryStatus(LMemoryStatus); - {The result is the total address space less the free address space} - Result := (LMemoryStatus.dwTotalVirtual - LMemoryStatus.dwAvailVirtual) shr 10; -end; - -{ TfUsageTracker } - -procedure TfFastMMUsageTracker.FormClose(Sender: TObject; - var Action: TCloseAction); -begin - Action := caFree; -end; - -procedure TfFastMMUsageTracker.RefreshSnapShot; -var - LInd: integer; - LAllocatedSize, LTotalBlocks, LTotalAllocated, LTotalReserved: Cardinal; -begin - {Get the state} - GetMemoryManagerState(FMemoryManagerState); - GetMemoryMap(FMemoryMap); - dgMemoryMap.Invalidate; - {Set the texts inside the results string grid} - LTotalBlocks := 0; - LTotalAllocated := 0; - LTotalReserved := 0; - for LInd := 0 to high(FMemoryManagerState.SmallBlockTypeStates) do - begin - with FMemoryManagerState.SmallBlockTypeStates[LInd] do - begin - sgBlockStatistics.Cells[1, LInd + 1] := IntToStr(AllocatedBlockCount); - Inc(LTotalBlocks, AllocatedBlockCount); - LAllocatedSize := AllocatedBlockCount * UseableBlockSize; - sgBlockStatistics.Cells[2, LInd + 1] := IntToStr(LAllocatedSize); - Inc(LTotalAllocated, LAllocatedSize); - sgBlockStatistics.Cells[3, LInd + 1] := IntToStr(ReservedAddressSpace); - Inc(LTotalReserved, ReservedAddressSpace); - if ReservedAddressSpace > 0 then - sgBlockStatistics.Cells[4, LInd + 1] := FormatFloat('0.##%', LAllocatedSize/ReservedAddressSpace * 100) - else - sgBlockStatistics.Cells[4, LInd + 1] := 'N/A'; - end; - end; - {Medium blocks} - LInd := length(FMemoryManagerState.SmallBlockTypeStates) + 1; - sgBlockStatistics.Cells[1, LInd] := IntToStr(FMemoryManagerState.AllocatedMediumBlockCount); - Inc(LTotalBlocks, FMemoryManagerState.AllocatedMediumBlockCount); - sgBlockStatistics.Cells[2, LInd] := IntToStr(FMemoryManagerState.TotalAllocatedMediumBlockSize); - Inc(LTotalAllocated, FMemoryManagerState.TotalAllocatedMediumBlockSize); - sgBlockStatistics.Cells[3, LInd] := IntToStr(FMemoryManagerState.ReservedMediumBlockAddressSpace); - Inc(LTotalReserved, FMemoryManagerState.ReservedMediumBlockAddressSpace); - if FMemoryManagerState.ReservedMediumBlockAddressSpace > 0 then - sgBlockStatistics.Cells[4, LInd] := FormatFloat('0.##%', FMemoryManagerState.TotalAllocatedMediumBlockSize/FMemoryManagerState.ReservedMediumBlockAddressSpace * 100) - else - sgBlockStatistics.Cells[4, LInd] := 'N/A'; - {Large blocks} - LInd := length(FMemoryManagerState.SmallBlockTypeStates) + 2; - sgBlockStatistics.Cells[1, LInd] := IntToStr(FMemoryManagerState.AllocatedLargeBlockCount); - Inc(LTotalBlocks, FMemoryManagerState.AllocatedLargeBlockCount); - sgBlockStatistics.Cells[2, LInd] := IntToStr(FMemoryManagerState.TotalAllocatedLargeBlockSize); - Inc(LTotalAllocated, FMemoryManagerState.TotalAllocatedLargeBlockSize); - sgBlockStatistics.Cells[3, LInd] := IntToStr(FMemoryManagerState.ReservedLargeBlockAddressSpace); - Inc(LTotalReserved, FMemoryManagerState.ReservedLargeBlockAddressSpace); - if FMemoryManagerState.ReservedLargeBlockAddressSpace > 0 then - sgBlockStatistics.Cells[4, LInd] := FormatFloat('0.##%', FMemoryManagerState.TotalAllocatedLargeBlockSize/FMemoryManagerState.ReservedLargeBlockAddressSpace * 100) - else - sgBlockStatistics.Cells[4, LInd] := 'N/A'; - {Overall} - LInd := length(FMemoryManagerState.SmallBlockTypeStates) + 3; - sgBlockStatistics.Cells[1, LInd] := IntToStr(LTotalBlocks); - sgBlockStatistics.Cells[2, LInd] := IntToStr(LTotalAllocated); - sgBlockStatistics.Cells[3, LInd] := IntToStr(LTotalReserved); - if LTotalReserved > 0 then - sgBlockStatistics.Cells[4, LInd] := FormatFloat('0.##%', LTotalAllocated/LTotalReserved * 100) - else - sgBlockStatistics.Cells[4, LInd] := 'N/A'; - {Address space usage} - eTotalAddressSpaceInUse.Text := FormatFloat('0.###', GetAddressSpaceUsed / 1024); -end; - -procedure TfFastMMUsageTracker.tTimerTimer(Sender: TObject); -begin - tTimer.Enabled := False; - try - RefreshSnapShot; - finally - tTimer.Enabled := True; - end; -end; - -procedure TfFastMMUsageTracker.FormCreate(Sender: TObject); -var - LInd: integer; -begin - {Set up the row count} - sgBlockStatistics.RowCount := length(FMemoryManagerState.SmallBlockTypeStates) + 4; - {Get the initial snapshot} - RefreshSnapShot; - {Set up the StringGrid columns} - sgBlockStatistics.Cells[0, 0] := 'Block Size'; - sgBlockStatistics.Cells[1, 0] := '# Live Pointers'; - sgBlockStatistics.Cells[2, 0] := 'Live Size'; - sgBlockStatistics.Cells[3, 0] := 'Used Space'; - sgBlockStatistics.Cells[4, 0] := 'Efficiency'; - for LInd := 0 to high(FMemoryManagerState.SmallBlockTypeStates) do - begin - sgBlockStatistics.Cells[0, LInd + 1] := - IntToStr(FMemoryManagerState.SmallBlockTypeStates[LInd].InternalBlockSize) - + '(' + IntToStr(FMemoryManagerState.SmallBlockTypeStates[LInd].UseableBlockSize) + ')'; - end; - sgBlockStatistics.Cells[0, length(FMemoryManagerState.SmallBlockTypeStates) + 1] := 'Medium Blocks'; - sgBlockStatistics.Cells[0, length(FMemoryManagerState.SmallBlockTypeStates) + 2] := 'Large Blocks'; - sgBlockStatistics.Cells[0, length(FMemoryManagerState.SmallBlockTypeStates) + 3] := 'Overall'; -end; - -procedure TfFastMMUsageTracker.bCloseClick(Sender: TObject); -begin - Close; -end; - -procedure TfFastMMUsageTracker.dgMemoryMapDrawCell(Sender: TObject; ACol, - ARow: Integer; Rect: TRect; State: TGridDrawState); -var - LChunkIndex: integer; - LChunkColour: TColor; -begin - {Get the chunk index} - LChunkIndex := ARow * dgMemoryMap.ColCount + ACol; - {Get the correct colour} - case FMemoryMap[LChunkIndex] of - csAllocated: - begin - LChunkColour := $9090ff; - end; - csReserved: - begin - LChunkColour := $90f090; - end; - csSysAllocated: - begin - LChunkColour := $707070; - end; - csSysReserved: - begin - LChunkColour := $c0c0c0; - end - else - begin - {Unallocated} - LChunkColour := $ffffff; - end; - end; - {Draw the chunk background} - dgMemoryMap.Canvas.Brush.Color := LChunkColour; - if State = [] then - begin - dgMemoryMap.Canvas.FillRect(Rect); - end - else - begin - dgMemoryMap.Canvas.Rectangle(Rect); - end; -end; - -procedure TfFastMMUsageTracker.dgMemoryMapSelectCell(Sender: TObject; ACol, - ARow: Integer; var CanSelect: Boolean); -var - LChunkIndex: Cardinal; -begin - LChunkIndex := ARow * dgMemoryMap.ColCount + ACol; - eAddress.Text := Format('$%0.8x', [LChunkIndex shl 16]); - case FMemoryMap[LChunkIndex] of - csAllocated: - begin - eState.Text := 'FastMM Allocated'; - end; - csReserved: - begin - eState.Text := 'FastMM Reserved'; - end; - csSysAllocated: - begin - eState.Text := 'System Allocated'; - end; - csSysReserved: - begin - eState.Text := 'System Reserved'; - end - else - begin - {Unallocated} - eState.Text := 'Unallocated'; - end; - end; -end; - -end. diff --git a/components/fastmm/Demos/Usage Tracker/UsageTrackerDemo.dpr b/components/fastmm/Demos/Usage Tracker/UsageTrackerDemo.dpr deleted file mode 100644 index 3a36106..0000000 --- a/components/fastmm/Demos/Usage Tracker/UsageTrackerDemo.dpr +++ /dev/null @@ -1,14 +0,0 @@ -program UsageTrackerDemo; - -uses - FastMM4, - Forms, - DemoForm in 'DemoForm.pas' {fDemo}; - -{$R *.res} - -begin - Application.Initialize; - Application.CreateForm(TfDemo, fDemo); - Application.Run; -end. diff --git a/components/fastmm/Demos/Usage Tracker/UsageTrackerDemo.res b/components/fastmm/Demos/Usage Tracker/UsageTrackerDemo.res deleted file mode 100644 index 4627e8f..0000000 Binary files a/components/fastmm/Demos/Usage Tracker/UsageTrackerDemo.res and /dev/null differ diff --git a/components/fastmm/FastMM4.pas b/components/fastmm/FastMM4.pas deleted file mode 100644 index 0da6f91..0000000 --- a/components/fastmm/FastMM4.pas +++ /dev/null @@ -1,7903 +0,0 @@ -(* - -Fast Memory Manager 4.78 - -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 6 - and later you can also specify this flag through the compiler directive - {$SetPEFlags $20} - *The EditBin tool ships with the MS Visual C compiler. - C++ Builder 6: - Refer to the instructions inside FastMM4BCB.cpp. - -License: - This work is copyright Professional Software Development / Pierre le Riche. It - is released under a dual license, and you may choose to use it under either the - Mozilla Public License 1.1 (MPL 1.1, available from - http://www.mozilla.org/MPL/MPL-1.1.html) or the GNU Lesser General Public - License 2.1 (LGPL 2.1, available from - http://www.opensource.org/licenses/lgpl-license.php). If you find FastMM useful - or you would like to support further development, a donation would be much - appreciated. My banking details are: - Country: South Africa - Bank: ABSA Bank Ltd - Branch: Somerset West - Branch Code: 334-712 - Account Name: PSD (Distribution) - Account No.: 4041827693 - Swift Code: ABSAZAJJ - My PayPal account is: - bof@psd.co.za - -Contact Details: - My contact details are shown below if you would like to get in touch with me. - If you use this memory manager I would like to hear from you: please e-mail me - your comments - good and bad. - Snailmail: - PO Box 2514 - Somerset West - 7129 - South Africa - E-mail: - plr@psd.co.za - -Support: - If you have trouble using FastMM, you are welcome to drop me an e-mail at the - address above, or you may post your questions in the BASM newsgroup on the - 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. - - Primoz Gabrijelcic for helping to track down various bugs. - - Dennis Christensen for his tireless efforts with the Fastcode project: - helping to develop, optimize and debug the growing Fastcode library. - - 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 various suggestions and bug reports. - - Craig Peterson for helping me identify the cache associativity issues that - could arise due to medium blocks always being an exact multiple of 256 bytes. - Also for various other bug reports and enhancement suggestions. - - Jarek Karciarz, Vladimir Ulchenko (Vavan) and Bob Gonder for their help in - implementing the BCB support. - - Ben Taylor for his suggestion to display the object class of all memory - leaks. - - Jean Marc Eber and Vincent Mahon (the Memcheck guys) for the call stack - trace code and also the method used to catch virtual method calls on freed - objects. - - Nahan Hyn for the suggestion to be able to enable or disable memory leak - reporting through a global variable (the "ManualLeakReportingControl" - option.) - - Leonel Togniolli for various suggestions with regard to enhancing the bug - tracking features of FastMM and other helpful advice. - - Joe Bain and Leonel Togniolli for the workaround to QC#10922 affecting - compilation under Delphi 2005. - - Robert Marquardt for the suggestion to make localisation of FastMM easier by - having all string constants together. - - Simon Kissel and Fikret Hasovic for their help in implementing Kylix support. - - Matthias Thoma, Petr Vones, Robert Rossmair and the rest of the JCL team for - their debug info library used in the debug info support DLL and also the - code used to check for a valid call site in the "raw" stack trace code. - - Andreas Hausladen for the suggestion to use an external DLL to enable the - reporting of debug information. - - Alexander Tabakov for various good suggestions regarding the debugging - facilities of FastMM. - - M. Skloff for some useful suggestions and bringing to my attention some - compiler warnings. - - Martin Aignesberger for the code to use madExcept instead of the JCL library - inside the debug info support DLL. - - Diederik and Dennis Passmore for the suggestion to be able to register - expected leaks. - - Dario Tiraboschi and Mark Gebauer for pointing out the problems that occur - when range checking and complete boolean evaluation is turned on. - - 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. - - Gnther Schoch for the "RequireDebuggerPresenceForLeakReporting" option. - - Jan Schlter for the "ForceMMX" option. - - Hallvard Vassbotn for various good enhancement suggestions. - - Mark Edington for some good suggestions and bug reports. - - Paul Ishenin for reporting the compilation error when the NoMessageBoxes - option is set and also the missing call stack entries issue when "raw" stack - traces are enabled, as well as for the Russian translation. - - Cristian Nicola for reporting the compilation bug when the - CatchUseOfFreedInterfaces option was enabled (4.40). - - Mathias Rauen (madshi) for improving the support for madExcept in the debug - info support DLL. - - Roddy Pratt for the BCB5 support code. - - Rene Mihula for the Czech translation and the suggestion to have dynamic - loading of the FullDebugMode DLL as an option. - - Artur Redzko for the Polish translation. - - Bart van der Werf for helping me solve the DLL unload order problem when - using the debug mode borlndmm.dll library, as well as various other - suggestions. - - JRG ("The Delphi Guy") for the Spanish translation. - - Justus Janssen for Delphi 4 support. - - Vadim Lopushansky and Charles Vinal for reporting the Delphi 5 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. - - RB Winston for suggesting the improvement to GExperts "backup" support. - - Thomas Schulz for reporting the bug affecting large address space support - under FullDebugMode. - - Luigi Sandon for the Italian translation. - - Werner Bochtler for various suggestions and bug reports. - - Markus Beth for suggesting the "NeverSleepOnThreadContention" option. - - JiYuan Xie for the Simplified Chinese translation. - - Andrey Shtukaturov for the updated Russian translation, as well as the - Ukrainian translation. - - Dimitry Timokhov for finding two elusive bugs in the memory leak class - detection code. - - Paulo Moreno for fixing the AllocMem bug in FullDebugMode that prevented - large blocks from being cleared. - - Vladimir Bochkarev for the suggestion to remove some unnecessary code if the - MM sharing mechanism is disabled. - - Loris Luise for the version constant suggestion. - - J.W. de Bokx for the MessageBox bugfix. - - Igor Lindunen for reporting the bug that caused the Align16Bytes option to - not work in FullDebugMode. - - Everyone who have made donations. Thanks! - - Any other Fastcoders or supporters that I have forgotten, and also everyone - that helped with the older versions. - -Change log: - Version 1.00 (28 June 2004): - - First version (called PSDMemoryManager). Based on RecyclerMM (free block - stack approach) by Eric Grange. - Version 2.00 (3 November 2004): - - Complete redesign and rewrite from scratch. Name changed to FastMM to - reflect this fact. Uses a linked-list approach. Is faster, has less memory - overhead, and will now catch most bad pointers on FreeMem calls. - Version 3.00 (1 March 2005): - - Another rewrite. Reduced the memory overhead by: (a) not having a separate - memory area for the linked list of free blocks (uses space inside free - blocks themselves) (b) batch managers are allocated as part of chunks (c) - block size lookup table size reduced. This should make FastMM more CPU - cache friendly. - Version 4.00 (7 June 2005): - - Yet another rewrite. FastMM4 is in fact three memory managers in one: Small - blocks (up to a few KB) are managed through the binning model in the same - way as previous versions, medium blocks (from a few KB up to approximately - 256K) are allocated in a linked-list fashion, and large blocks are grabbed - directly from the system through VirtualAlloc. This 3-layered design allows - very fast operation with the most frequently used block sizes (small - blocks), while also minimizing fragmentation and imparting significant - overhead savings with blocks larger than a few KB. - Version 4.01 (8 June 2005): - - Added the options "RequireDebugInfoForLeakReporting" and - "RequireIDEPresenceForLeakReporting" as suggested by Pierre Y. - - Fixed the "DelphiIsRunning" function not working under Delphi 5, and - consequently no leak checking. (Reported by Anders Isaksson and Greg.) - Version 4.02 (8 June 2005): - - Fixed the compilation error when both the "AssumeMultiThreaded" and - "CheckHeapForCorruption options were set. (Reported by Francois Malan.) - Version 4.03 (9 June 2005): - - Added descriptive error messages when FastMM4 cannot be installed because - another MM has already been installed or memory has already been allocated. - Version 4.04 (13 June 2005): - - Added a small fixed offset to the size of medium blocks (previously always - exact multiples of 256 bytes). This makes performance problems due to CPU - cache associativity limitations much less likely. (Reported by Craig - Peterson.) - Version 4.05 (17 June 2005): - - Added the Align16Bytes option. Disable this option to drop the 16 byte - alignment restriction and reduce alignment to 8 bytes for the smallest - block sizes. Disabling Align16Bytes should lower memory consumption at the - cost of complicating the use of aligned SSE move instructions. (Suggested - by Craig Peterson.) - - Added a support unit for C++ Builder 6 - Add FastMM4BCB.cpp and - FastMM4.pas to your BCB project to use FastMM instead of the RTL MM. Memory - leak checking is not supported because (unfortunately) once an MM is - installed under BCB you cannot uninstall it... at least not without - modifying the RTL code in exit.c or patching the RTL code runtime. (Thanks - to Jarek Karciarz, Vladimir Ulchenko and Bob Gonder.) - Version 4.06 (22 June 2005): - - Displays the class of all leaked objects on the memory leak report and also - tries to identify leaked long strings. Previously it only displayed the - sizes of all leaked blocks. (Suggested by Ben Taylor.) - - Added support for displaying the sizes of medium and large block memory - leaks. Previously it only displayed details for small block leaks. - Version 4.07 (22 June 2005): - - Fixed the detection of the class of leaked objects not working under - Windows 98/Me. - Version 4.08 (27 June 2005): - - Added a BorlndMM.dpr project to allow you to build a borlndmm.dll that uses - FastMM4 instead of the default memory manager. You may replace the old - DLL in the Delphi \Bin directory to make the IDE use this memory manager - instead. - Version 4.09 (30 June 2005): - - Included a patch fix for the bug affecting replacement borlndmm.dll files - with Delphi 2005 (QC#14007). Compile the patch, close Delphi, and run it - once to patch your vclide90.bpl. You will now be able to use the - replacement borlndmm.dll to speed up the Delphi 2005 IDE as well. - Version 4.10 (7 July 2005): - - Due to QC#14070 ("Delphi IDE attempts to free memory after the shutdown - code of borlndmm.dll has been called"), FastMM cannot be uninstalled - safely when used inside a replacement borlndmm.dll for the IDE. Added a - conditional define "NeverUninstall" for this purpose. - - Added the "FullDebugMode" option to pad all blocks with a header and footer - to help you catch memory overwrite bugs in your applications. All blocks - returned to freemem are also zeroed out to help catch bugs involving the - use of previously freed blocks. Also catches attempts at calling virtual - methods of freed objects provided the block in question has not been reused - since the object was freed. Displays stack traces on error to aid debugging. - - Added the "LogErrorsToFile" option to log all errors to a text file in the - same folder as the application. - - Added the "ManualLeakReportingControl" option (suggested by Nahan Hyn) to - enable control over whether the memory leak report should be done or not - via a global variable. - Version 4.11 (7 July 2005): - - Fixed a compilation error under Delphi 2005 due to QC#10922. (Thanks to Joe - Bain and Leonel Togniolli.) - - Fixed leaked object classes not displaying in the leak report in - "FullDebugMode". - Version 4.12 (8 July 2005): - - Moved all the string constants to one place to make it easier to do - translations into other languages. (Thanks to Robert Marquardt.) - - Added support for Kylix. Some functionality is currently missing: No - support for detecting the object class on leaks and also no MM sharing. - (Thanks to Simon Kissel and Fikret Hasovic). - Version 4.13 (11 July 2005): - - Added the FastMM_DebugInfo.dll support library to display debug info for - stack traces. - - Stack traces for the memory leak report is now logged to the log file in - "FullDebugMode". - Version 4.14 (14 July 2005): - - Fixed string leaks not being detected as such in "FullDebugMode". (Thanks - to Leonel Togniolli.) - - Fixed the compilation error in "FullDebugMode" when "LogErrorsToFile" is - not set. (Thanks to Leonel Togniolli.) - - Added a "Release" option to allow the grouping of various options and to - make it easier to make debug and release builds. (Thanks to Alexander - Tabakov.) - - Added a "HideMemoryLeakHintMessage" option to not display the hint below - the memory leak message. (Thanks to Alexander Tabakov.) - - Changed the fill character for "FullDebugMode" from zero to $80 to be able - to differentiate between invalid memory accesses using nil pointers to - invalid memory accesses using fields of freed objects. FastMM tries to - reserve the 64K block starting at $80800000 at startup to ensure that an - A/V will occur when this block is accessed. (Thanks to Alexander Tabakov.) - - Fixed some compiler warnings. (Thanks to M. Skloff) - - Fixed some display bugs in the memory leak report. (Thanks to Leonel - Togniolli.) - - Added a "LogMemoryLeakDetailToFile" option. Some applications leak a lot of - memory and can make the log file grow very large very quickly. - - Added the option to use madExcept instead of the JCL Debug library in the - debug info support DLL. (Thanks to Martin Aignesberger.) - - Added procedures "GetMemoryManagerState" and "GetMemoryMap" to retrieve - statistics about the current state of the memory manager and memory pool. - (A usage tracker form together with a demo is also available.) - Version 4.15 (14 July 2005): - - Fixed a false 4GB(!) memory leak reported in some instances. - Version 4.16 (15 July 2005): - - Added the "CatchUseOfFreedInterfaces" option to catch the use of interfaces - of freed objects. This option is not compatible with checking that a freed - block has not been modified, so enable this option only when hunting an - invalid interface reference. (Only relevant if "FullDebugMode" is set.) - - During shutdown FastMM now checks that all free blocks have not been - modified since being freed. (Only when "FullDebugMode" is set and - "CatchUseOfFreedInterfaces" is disabled.) - Version 4.17 (15 July 2005): - - Added the AddExpectedMemoryLeaks and RemoveExpectedMemoryLeaks procedures to - register/unregister expected leaks, thus preventing the leak report from - displaying if only expected leaks occurred. (Thanks to Diederik and Dennis - Passmore for the suggestion.) (Note: these functions were renamed in later - versions.) - - Fixed the "LogMemoryLeakDetailToFile" not logging memory leak detail to file - as it is supposed to. (Thanks to Leonel Togniolli.) - Version 4.18 (18 July 2005): - - Fixed some issues when range checking or complete boolean evaluation is - switched on. (Thanks to Dario Tiraboschi and Mark Gebauer.) - - Added the "OutputInstallUninstallDebugString" option to display a message when - FastMM is installed or uninstalled. (Thanks to Hanspeter Widmer.) - - Moved the options to a separate include file. (Thanks to Hanspeter Widmer.) - - Moved message strings to a separate file for easy translation. - Version 4.19 (19 July 2005): - - Fixed Kylix support that was broken in 4.14. - Version 4.20 (20 July 2005): - - Fixed a false memory overwrite report at shutdown in "FullDebugMode". If you - consistently got a "Block Header Has Been Corrupted" error message during - shutdown at address $xxxx0070 then it was probably a false alarm. (Thanks to - Theo Carr-Brion and Hanspeter Widmer.} - Version 4.21 (27 July 2005): - - Minor change to the block header flags to make it possible to immediately - tell whether a medium block is being used as a small block pool or not. - (Simplifies the leak checking and status reporting code.) - - Expanded the functionality around the management of expected memory leaks. - - Added the "ClearLogFileOnStartup" option. Deletes the log file during - initialization. (Thanks to M. Skloff.) - - Changed "OutputInstallUninstallDebugString" to use OutputDebugString instead - of MessageBox. (Thanks to Hanspeter Widmer.) - Version 4.22 (1 August 2005): - - Added a FastAllocMem function that avoids an unnecessary FillChar call with - large blocks. - - Changed large block resizing behavior to be a bit more conservative. Large - blocks will be downsized if the new size is less than half of the old size - (the threshold was a quarter previously). - Version 4.23 (6 August 2005): - - Fixed BCB6 support (Thanks to Omar Zelaya). - - Renamed "OutputInstallUninstallDebugString" to "UseOutputDebugString", and - added debug string output on memory leak or error detection. - Version 4.24 (11 August 2005): - - Added the "NoMessageBoxes" option to suppress the display of message boxes, - which is useful for services that should not be interrupted. (Thanks to Dan - Miser). - - Changed the stack trace code to return the line number of the caller and not - the line number of the return address. (Thanks to Dan Miser). - Version 4.25 (15 August 2005): - - Fixed GetMemoryLeakType not detecting expected leaks registered by class - when in "FullDebugMode". (Thanks to Arjen de Ruijter). - Version 4.26 (18 August 2005): - - Added a "UseRuntimePackages" option that allows FastMM to be used in a main - application together with DLLs that all use runtime packages. (Thanks to - Aleksander Oven.) - Version 4.27 (24 August 2005): - - Fixed a bug that sometimes caused the leak report to be shown even though all - leaks were registered as expected leaks. (Thanks to Kristofer Skaug.) - Version 4.29 (30 September 2005): - - Added the "RequireDebuggerPresenceForLeakReporting" option to only display - the leak report if the application is run inside the IDE. (Thanks to Gnther - Schoch.) - - Added the "ForceMMX" option, which when disabled will check the CPU for - MMX compatibility before using MMX. (Thanks to Jan Schlter.) - - 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.) - Version 4.66 (9 May 2006): - - Added a hint comment in this file so that FastMM4Messages.pas will also be - backed up by GExperts. (Thanks to RB Winston.) - - Fixed a bug affecting large address space (> 2GB) support under - FullDebugMode. (Thanks to Thomas Schulz.) - Version 4.68 (3 July 2006): - - Added the Italian translation by Luigi Sandon. - - If FastMM is used inside a DLL it will now use the name of the DLL as base - for the log file name. (Previously it always used the name of the main - application executable file.) - - Fixed a rare A/V when both the FullDebugMode and RawStackTraces options were - enabled. (Thanks to Primoz Gabrijelcic.) - - Added the "NeverSleepOnThreadContention" option. This option may improve - performance if the ratio of the the number of active threads to the number - of CPU cores is low (typically < 2). This option is only useful for 4+ CPU - systems, it almost always hurts performance on single and dual CPU systems. - (Thanks to Werner Bochtler and Markus Beth.) - Version 4.70 (4 August 2006): - - Added the Simplified Chinese translation by JiYuan Xie. - - Added the updated Russian as well as the Ukrainian translation by Andrey - Shtukaturov. - - Fixed two bugs in the leak class detection code that would sometimes fail - to detect the class of leaked objects and strings, and report them as - 'unknown'. (Thanks to Dimitry Timokhov) - Version 4.72 (24 September 2006): - - Fixed a bug that caused AllocMem to not clear blocks > 256K in - FullDebugMode. (Thanks to Paulo Moreno.) - Version 4.74 (9 November 2006): - - Fixed a bug in the segmented large block functionality that could lead to - an application freeze when upsizing blocks greater than 256K in a - multithreaded application (one of those "what the heck was I thinking?" - type bugs). - Version 4.76 (12 January 2007): - - Changed the RawStackTraces code in the FullDebugMode DLL - to prevent it from modifying the Windows "GetLastError" error code. - (Thanks to Primoz Gabrijelcic.) - - Fixed a threading issue when the "CheckHeapForCorruption" option was - enabled, but the "FullDebugMode" option was disabled. (Thanks to Primoz - Gabrijelcic.) - - Removed some unnecessary startup code when the MM sharing mechanism is - disabled. (Thanks to Vladimir Bochkarev.) - - In FullDebugMode leaked blocks would sometimes be reported as belonging to - the class "TFreedObject" if they were allocated but never used. Such blocks - will now be reported as "unknown". (Thanks to Francois Malan.) - - In recent versions the replacement borlndmm.dll created a log file (when - enabled) that used the "borlndmm" prefix instead of the application name. - It is now fixed to use the application name, however if FastMM is used - inside other DLLs the name of those DLLs will be used. (Thanks to Bart van - der Werf.) - - Added a "FastMMVersion" constant. (Suggested by Loris Luise.) - - Fixed an issue with error message boxes not displaying under certain - configurations. (Thanks to J.W. de Bokx.) - - FastMM will now display only one error message at a time. If many errors - occur in quick succession, only the first error will be shown (but all will - be logged). This avoids a stack overflow with badly misbehaved programs. - (Thanks to Bart van der Werf.) - - Added a LoadDebugDLLDynamically option to be used in conjunction with - FullDebugMode. In this mode FastMM_FullDebugMode.dll is loaded dynamically. - If the DLL cannot be found, stack traces will not be available. (Thanks to - Rene Mihula.) - Version 4.78 (1 March 2007): - - The MB_DEFAULT_DESKTOP_ONLY constant that is used when display messages - boxes since 4.76 is not defined under Kylix, and the source would thus not - compile. That constant is now defined. (Thanks to Werner Bochtler.) - - Moved the medium block locking code that was duplicated in several places - to a subroutine to reduce code size. (Thanks to Hallvard Vassbotn.) - - Fixed a bug in the leak registration code that sometimes caused registered - leaks to be reported erroneously. (Thanks to Primoz Gabrijelcic.) - - Added the NoDebugInfo option (on by default) that suppresses the generation - of debug info for the FastMM4.pas unit. This will prevent the integrated - debugger from stepping into the memory manager. (Thanks to Primoz - Gabrijelcic.) - - Increased the default stack trace depth in FullDebugMode from 9 to 10 to - ensure that the Align16Bytes setting works in FullDebugMode. (Thanks to - Igor Lindunen.) - - Updated the Czech translation. (Thanks to Rene Mihula.) - -*) - -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 FullDebugMode} - {$undef LogErrorsToFile} - {$undef LogMemoryLeakDetailToFile} - {$undef ShareMM} - {$undef AttemptToUseSharedMM} - {$undef EnableSharingWithDefaultMM} - {$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} - -{Are any of the MM sharing options enabled?} -{$ifdef ShareMM} - {$define MMSharingEnabled} -{$endif} -{$ifdef AttemptToUseSharedMM} - {$define MMSharingEnabled} -{$endif} - -{Instruct GExperts to back up the messages file as well.} -{#BACKUP FastMM4Messages.pas} - -{Should debug info be disabled?} -{$ifdef NoDebugInfo} - {$DEBUGINFO OFF} -{$endif} - -{-------------------------Public constants-----------------------------} -const - {The current version of FastMM} - FastMMVersion = '4.78'; - {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. (Must be an even number to ensure that the - Align16Bytes option works in FullDebugMode.)} - StackTraceDepth = 10; - {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---------------} -{$ifndef NeverSleepOnThreadContention} - {Sleep time when a resource (small/medium/large block manager) is in use} - InitialSleepTime = 0; - {Used when the resource is still in use after the first sleep} - AdditionalSleepTime = 10; -{$endif} - {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); - - {The header placed in front blocks in FullDebugMode (just after the standard - header). Must be a multiple of 16 bytes in size otherwise the Align16Bytes - option will not work.} - 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} - -{$ifdef MMSharingEnabled} - {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} -{$endif} - -{$ifdef ShareMM} - {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} - {Has FastMM been installed?} - FastMMIsInstalled: Boolean; - {Is the MM in place a shared memory manager?} - IsMemoryManagerOwner: Boolean; - {Must MMX be used for move operations?} -{$ifdef EnableMMX} - {$ifndef ForceMMX} - UseMMX: Boolean; - {$endif} -{$endif} - {Is a MessageBox currently showing? If so, do not show another one.} - ShowingMessageBox: Boolean; - -{----------------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} - -{Writes the module filename to the specified buffer and returns the number of - characters written.} -function AppendModuleFileName(ABuffer: PChar): Integer; -var - LModuleHandle: HModule; -begin - {Get the module handle} -{$ifndef borlndmmdll} - if IsLibrary then - LModuleHandle := HInstance - else -{$endif} - LModuleHandle := 0; - {Get the module name} - Result := GetModuleFileName(LModuleHandle, ABuffer, 512); -end; - -{Copies the name of the module followed by the given string to the buffer, - returning the pointer following the buffer.} -function AppendStringToModuleName(AString, ABuffer: PChar): PChar; -var - LModuleNameLength: Cardinal; - LCopyStart: PChar; -begin - {Get the name of the application} - LModuleNameLength := AppendModuleFileName(ABuffer); - {Replace the last few characters} - if LModuleNameLength > 0 then - begin - {Find the last backslash} - LCopyStart := 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; - MB_DEFAULT_DESKTOP_ONLY = $20000; - {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; - -{$ifndef NeverSleepOnThreadContention} -procedure Sleep(dwMilliseconds: Cardinal); stdcall; -begin - {Convert to microseconds (more or less)} - usleep(dwMilliseconds shl 10); -end; -{$endif} -{$endif} - -{-----------------Debugging Support Functions and Procedures------------------} - -{$ifdef FullDebugMode} - - {$ifndef LoadDebugDLLDynamically} - -{The stack trace procedure. The stack trace module is external since it may - raise handled access violations that result in the creation of exception - objects and the stack trace code is not re-entrant.} -procedure GetStackTrace(AReturnAddresses: 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'; - - {$else} - - {Default no-op stack trace and logging handlers} - procedure NoOpGetStackTrace(AReturnAddresses: PCardinal; - AMaxDepth, ASkipFrames: Cardinal); - begin - FillChar(AReturnAddresses^, AMaxDepth * 4, 0); - end; - - function NoOpLogStackTrace(AReturnAddresses: PCardinal; - AMaxDepth: Cardinal; ABuffer: PChar): PChar; - begin - Result := ABuffer; - end; - -var - - {Handle to the FullDebugMode DLL} - FullDebugModeDLL: HMODULE; - - GetStackTrace: procedure (AReturnAddresses: PCardinal; - AMaxDepth, ASkipFrames: Cardinal) = NoOpGetStackTrace; - - LogStackTrace: function (AReturnAddresses: PCardinal; - AMaxDepth: Cardinal; ABuffer: PChar): PChar = NoOpLogStackTrace; - - {$endif} - -{$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; - -{Shows a message box if the program is not showing one already.} -procedure ShowMessageBox(AText, ACaption: PChar); -begin - if not ShowingMessageBox then - begin - ShowingMessageBox := True; - MessageBox(0, AText, ACaption, - MB_OK or MB_ICONERROR or MB_TASKMODAL or MB_DEFAULT_DESKTOP_ONLY); - ShowingMessageBox := False; - end; -end; - -{Returns the class for a memory block. Returns nil if it is not a valid class} -function GetObjectClass(APointer: Pointer): TClass; -{$ifndef Linux} -var - LMemInfo: TMemoryBasicInformation; - - {Checks whether the given address is a valid address for a VMT entry.} - function IsValidVMTAddress(APAddress: PCardinal): Boolean; - begin - {Do some basic pointer checks: Must be dword aligned and beyond 64K} - if (Cardinal(APAddress) > 65535) - and (Cardinal(APAddress) and 3 = 0) then - begin - {Do we need to recheck the virtual memory?} - if (Cardinal(LMemInfo.BaseAddress) > Cardinal(APAddress)) - or ((Cardinal(LMemInfo.BaseAddress) + LMemInfo.RegionSize) < (Cardinal(APAddress) + 4)) then - begin - {Get the VM status for the pointer} - LMemInfo.RegionSize := 0; - VirtualQuery(APAddress, LMemInfo, SizeOf(LMemInfo)); - end; - {Check the readability of the memory address} - Result := (LMemInfo.RegionSize >= 4) - and (LMemInfo.State = MEM_COMMIT) - and (LMemInfo.Protect and (PAGE_READONLY or PAGE_READWRITE or PAGE_EXECUTE or PAGE_EXECUTE_READ or PAGE_EXECUTE_READWRITE or PAGE_EXECUTE_WRITECOPY) <> 0) - and (LMemInfo.Protect and PAGE_GUARD = 0); - end - else - Result := False; - end; - - {Returns true if AClassPointer points to a class VMT} - function InternalIsValidClass(AClassPointer: Pointer; ADepth: Integer = 0): Boolean; - var - LParentClassSelfPointer: PCardinal; - begin - {Check that the self pointer as well as parent class self pointer addresses - are valid} - if (ADepth < 1000) - and IsValidVMTAddress(Pointer(Integer(AClassPointer) + vmtSelfPtr)) - and IsValidVMTAddress(Pointer(Integer(AClassPointer) + vmtParent)) then - begin - {Get a pointer to the parent class' self pointer} - LParentClassSelfPointer := PPointer(Integer(AClassPointer) + vmtParent)^; - {Check that the self pointer as well as the parent class is valid} - Result := (PPointer(Integer(AClassPointer) + vmtSelfPtr)^ = AClassPointer) - and ((LParentClassSelfPointer = nil) - or (IsValidVMTAddress(LParentClassSelfPointer) - and InternalIsValidClass(PCardinal(LParentClassSelfPointer^), ADepth + 1))); - end - else - Result := False; - 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 (not InternalIsValidClass(Pointer(Result), 0)) -{$ifdef FullDebugMode} - or (Result = @FreedObjectVMT.VMTMethods[0]) -{$endif} - then - Result := nil; -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 -{$ifndef NeverSleepOnThreadContention} - Sleep(InitialSleepTime); - if LockCmpxchg(0, 1, @SmallBlockTypes[LInd].BlockTypeLocked) = 0 then - break; - Sleep(AdditionalSleepTime); -{$endif} - end; - end; - end; -end; - -{Gets the first and last block pointer for a small block pool} -procedure GetFirstAndLastSmallBlockInPool(APSmallBlockPool: PSmallBlockPoolHeader; - var AFirstPtr, ALastPtr: Pointer); -var - LBlockSize: 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. Note that if AsmVersion is defined that the routine - is assumed to preserve all registers except eax.} -{$ifndef AsmVersion} -procedure LockMediumBlocks; -begin - {Lock the medium blocks} -{$ifndef AssumeMultiThreaded} - if IsMultiThread then -{$endif} - begin - while LockCmpxchg(0, 1, @MediumBlocksLocked) <> 0 do - begin -{$ifndef NeverSleepOnThreadContention} - Sleep(InitialSleepTime); - if LockCmpxchg(0, 1, @MediumBlocksLocked) = 0 then - break; - Sleep(AdditionalSleepTime); -{$endif} - end; - end; -end; -{$else} -procedure LockMediumBlocks; -asm - {Note: This routine is assumed to preserve all registers except eax} -@MediumBlockLockLoop: - mov eax, $100 - {Attempt to lock the medium blocks} - lock cmpxchg MediumBlocksLocked, ah - je @Done -{$ifndef NeverSleepOnThreadContention} - {Couldn't lock the medium blocks - sleep and try again} - push ecx - push edx - push InitialSleepTime - call Sleep - pop edx - pop ecx - {Try again} - mov eax, $100 - {Attempt to grab the block type} - lock cmpxchg MediumBlocksLocked, ah - je @Done - {Couldn't lock the medium blocks - sleep and try again} - push ecx - push edx - push AdditionalSleepTime - call Sleep - pop edx - pop ecx - {Try again} - jmp @MediumBlockLockLoop -{$else} - {Pause instruction (improves performance on P4)} - rep nop - {Try again} - jmp @MediumBlockLockLoop -{$endif} -@Done: -end; -{$endif} - -{$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 -{$ifndef NeverSleepOnThreadContention} - Sleep(InitialSleepTime); - if LockCmpxchg(0, 1, @LargeBlocksLocked) = 0 then - break; - Sleep(AdditionalSleepTime); -{$endif} - end; - end; -end; - -{Allocates a Large block of at least ASize (actual size may be larger to - allow for alignment etc.). ASize must be the actual user requested size. This - procedure will pad it to the appropriate page boundary and also add the space - required by the header.} -function AllocateLargeBlock(ASize: 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 - {Get the size of the current segment} - VirtualQuery(LCurrentSegment, LMemInfo, SizeOf(LMemInfo)); - {Free the segment} - if not VirtualFree(LCurrentSegment, 0, MEM_RELEASE) then - begin - Result := -1; - break; - end; - {Done?} - if 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; - {Attempy to reserve the address range (which will fail if another - thread has just reserved it) and commit it immediately afterwards.} - if (VirtualAlloc(LNextSegmentPointer, LNewSegmentSize, MEM_RESERVE, PAGE_READWRITE) <> nil) - and (VirtualAlloc(LNextSegmentPointer, LNewSegmentSize, MEM_COMMIT, PAGE_READWRITE) <> nil) then - begin - {Update the requested size} - PLargeBlockHeader(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 it's a large block - store the actual user requested size (it may - not be if the block that is being reallocated from was previously - downsized)} - if LNewAllocSize > (MaximumMediumBlockSize - BlockHeaderSize) then - PLargeBlockHeader(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)); -{$ifndef NeverSleepOnThreadContention} - {Both this block type and the next is in use: sleep} - Sleep(InitialSleepTime); - {Try the lock again} - if LockCmpxchg(0, 1, @LPSmallBlockType.BlockTypeLocked) = 0 then - break; - {Sleep longer} - Sleep(AdditionalSleepTime); -{$endif} - end; - end; - {Get the first pool with free blocks} - LPSmallBlockPool := LPSmallBlockType.NextPartiallyFreePool; - {Is the pool valid?} - if 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 - 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) -{$ifndef NeverSleepOnThreadContention} - {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 -{$else} - {Pause instruction (improves performance on P4)} - rep nop - {Try again} - jmp @LockBlockTypeLoop - {Align branch target} - nop - nop -{$endif} -@AllocateSmallBlockPool: - {save additional registers} - push esi - push edi - {Do we need to lock the medium blocks?} -{$ifndef AssumeMultiThreaded} - cmp IsMultiThread, False - je @MediumBlocksLockedForPool -{$endif} - call LockMediumBlocks -@MediumBlocksLockedForPool: - {Are there any available blocks of a suitable size?} - movsx esi, TSmallBlockType[ebx].AllowedGroupsForBlockPoolBitmap - and esi, MediumBlockBinGroupBitmap - jz @NoSuitableMediumBlocks - {Get the bin group number with free blocks in eax} - bsf eax, esi - {Get the bin number in ecx} - lea esi, [eax * 8] - mov ecx, dword ptr [MediumBlockBinBitmaps + eax * 4] - bsf ecx, ecx - lea ecx, [ecx + esi * 4] - {Get a pointer to the bin in edi} - lea edi, [MediumBlockBins + ecx * 8] - {Get the free block in esi} - mov esi, TMediumFreeBlock[edi].NextFreeBlock - {Remove the first block from the linked list (LIFO)} - mov edx, TMediumFreeBlock[esi].NextFreeBlock - mov TMediumFreeBlock[edi].NextFreeBlock, edx - mov TMediumFreeBlock[edx].PreviousFreeBlock, edi - {Is this bin now empty?} - cmp edi, edx - jne @MediumBinNotEmpty - {eax = bin group number, ecx = bin number, edi = @bin, esi = free block, ebx = block type} - {Flag this bin as empty} - mov edx, -2 - rol edx, cl - and dword ptr [MediumBlockBinBitmaps + eax * 4], edx - jnz @MediumBinNotEmpty - {Flag the group as empty} - btr MediumBlockBinGroupBitmap, eax -@MediumBinNotEmpty: - {esi = free block, ebx = block type} - {Get the size of the available medium block in edi} - mov edi, DropMediumAndLargeFlagsMask - and edi, [esi - 4] - cmp edi, MaximumSmallBlockPoolSize - jb @UseWholeBlock - {Split the block: get the size of the second part, new block size is the - optimal size} - mov edx, edi - movzx edi, TSmallBlockType[ebx].OptimalBlockPoolSize - sub edx, edi - {Split the block in two} - lea eax, [esi + edi] - lea ecx, [edx + IsMediumBlockFlag + IsFreeBlockFlag] - mov [eax - 4], ecx - {Store the size of the second split as the second last dword} - mov [eax + edx - 8], edx - {Put the remainder in a bin (it will be big enough)} - call InsertMediumBlockIntoBin - jmp @GotMediumBlock - {Align branch target} -{$ifdef AssumeMultiThreaded} - nop -{$endif} -@NoSuitableMediumBlocks: - {Check the sequential feed medium block pool for space} - movzx ecx, TSmallBlockType[ebx].MinimumBlockPoolSize - mov edi, MediumSequentialFeedBytesLeft - cmp edi, ecx - jb @AllocateNewSequentialFeed - {Get the address of the last block that was fed} - mov esi, LastSequentiallyFedMediumBlock - {Enough sequential feed space: Will the remainder be usable?} - movzx ecx, TSmallBlockType[ebx].OptimalBlockPoolSize - lea edx, [ecx + MinimumMediumBlockSize] - cmp edi, edx - jb @NotMuchSpace - mov edi, ecx -@NotMuchSpace: - sub esi, edi - {Update the sequential feed parameters} - sub MediumSequentialFeedBytesLeft, edi - mov LastSequentiallyFedMediumBlock, esi - {Get the block pointer} - jmp @GotMediumBlock - {Align branch target} -@AllocateNewSequentialFeed: - {Need to allocate a new sequential feed medium block pool: use the - optimal size for this small block pool} - movzx eax, TSmallBlockType[ebx].OptimalBlockPoolSize - mov edi, eax - {Allocate the medium block pool} - call AllocNewSequentialFeedMediumPool - mov esi, eax - test eax, eax - jnz @GotMediumBlock - mov MediumBlocksLocked, al - mov TSmallBlockType[ebx].BlockTypeLocked, al - pop edi - pop esi - pop ebx - ret - {Align branch target} -@UseWholeBlock: - {esi = free block, ebx = block type, edi = block size} - {Mark this block as used in the block following it} - and byte ptr [esi + edi - 4], not PreviousMediumBlockIsFreeFlag -@GotMediumBlock: - {esi = free block, ebx = block type, edi = block size} - {Set the size and flags for this block} - lea ecx, [edi + IsMediumBlockFlag + IsSmallBlockPoolInUseFlag] - mov [esi - 4], ecx - {Unlock medium blocks} - xor eax, eax - mov MediumBlocksLocked, al - {Set up the block pool} - mov TSmallBlockPoolHeader[esi].BlockType, ebx - mov TSmallBlockPoolHeader[esi].FirstFreeBlock, eax - mov TSmallBlockPoolHeader[esi].BlocksInUse, 1 - {Set it up for sequential block serving} - mov TSmallBlockType[ebx].CurrentSequentialFeedPool, esi - {Return the pointer to the first block} - lea eax, [esi + SmallBlockPoolHeaderSize] - movzx ecx, TSmallBlockType[ebx].BlockSize - lea edx, [eax + ecx] - mov TSmallBlockType[ebx].NextSequentialFeedBlockAddress, edx - add edi, esi - sub edi, ecx - mov TSmallBlockType[ebx].MaxSequentialFeedBlockAddress, edi - {Unlock the small block type} - mov TSmallBlockType[ebx].BlockTypeLocked, False - {Set the small block header} - mov [eax - 4], esi - {Restore registers} - pop edi - pop esi - pop ebx - {Done} - ret -{-------------------Medium block allocation-------------------} - {Align branch target} - nop -@NotASmallBlock: - cmp eax, (MaximumMediumBlockSize - BlockHeaderSize) - ja @IsALargeBlockRequest - {Get the bin size for this block size. Block sizes are - rounded up to the next bin size.} - lea ebx, [eax + MediumBlockGranularity - 1 + BlockHeaderSize - MediumBlockSizeOffset] - and ebx, -MediumBlockGranularity - add ebx, MediumBlockSizeOffset - {Do we need to lock the medium blocks?} -{$ifndef AssumeMultiThreaded} - test cl, cl - jz @MediumBlocksLocked -{$endif} - call LockMediumBlocks -@MediumBlocksLocked: - {Get the bin number in ecx and the group number in edx} - lea edx, [ebx - MinimumMediumBlockSize] - mov ecx, edx - shr edx, 8 + 5 - shr ecx, 8 - {Is there a suitable block inside this group?} - mov eax, -1 - shl eax, cl - and eax, dword ptr [MediumBlockBinBitmaps + edx * 4] - jz @GroupIsEmpty - {Get the actual bin number} - and ecx, -32 - bsf eax, eax - or ecx, eax - jmp @GotBinAndGroup - {Align branch target} - nop -@GroupIsEmpty: - {Try all groups greater than this group} - mov eax, -2 - mov ecx, edx - shl eax, cl - and eax, MediumBlockBinGroupBitmap - jz @TrySequentialFeedMedium - {There is a suitable group with space: get the bin number} - bsf edx, eax - {Get the bin in the group with free blocks} - mov eax, dword ptr [MediumBlockBinBitmaps + edx * 4] - bsf ecx, eax - mov eax, edx - shl eax, 5 - or ecx, eax - jmp @GotBinAndGroup - {Align branch target} - nop -@TrySequentialFeedMedium: - mov ecx, MediumSequentialFeedBytesLeft - {Block can be fed sequentially?} - sub ecx, ebx - jc @AllocateNewSequentialFeedForMedium - {Get the block address} - mov eax, LastSequentiallyFedMediumBlock - sub eax, ebx - mov LastSequentiallyFedMediumBlock, eax - {Store the remaining bytes} - mov MediumSequentialFeedBytesLeft, ecx - {Set the flags for the block} - or ebx, IsMediumBlockFlag - mov [eax - 4], ebx - jmp @MediumBlockGetDone - {Align branch target} -@AllocateNewSequentialFeedForMedium: - mov eax, ebx - call AllocNewSequentialFeedMediumPool -@MediumBlockGetDone: - mov MediumBlocksLocked, False - pop ebx - ret - {Align branch target} -@GotBinAndGroup: - {ebx = block size, ecx = bin number, edx = group number} - push esi - push edi - {Get a pointer to the bin in edi} - lea edi, [MediumBlockBins + ecx * 8] - {Get the free block in esi} - mov esi, TMediumFreeBlock[edi].NextFreeBlock - {Remove the first block from the linked list (LIFO)} - mov eax, TMediumFreeBlock[esi].NextFreeBlock - mov TMediumFreeBlock[edi].NextFreeBlock, eax - mov TMediumFreeBlock[eax].PreviousFreeBlock, edi - {Is this bin now empty?} - cmp edi, eax - jne @MediumBinNotEmptyForMedium - {eax = bin group number, ecx = bin number, edi = @bin, esi = free block, ebx = block size} - {Flag this bin as empty} - mov eax, -2 - rol eax, cl - and dword ptr [MediumBlockBinBitmaps + edx * 4], eax - jnz @MediumBinNotEmptyForMedium - {Flag the group as empty} - btr MediumBlockBinGroupBitmap, edx -@MediumBinNotEmptyForMedium: - {esi = free block, ebx = block size} - {Get the size of the available medium block in edi} - mov edi, DropMediumAndLargeFlagsMask - and edi, [esi - 4] - {Get the size of the second split in edx} - mov edx, edi - sub edx, ebx - jz @UseWholeBlockForMedium - {Split the block in two} - lea eax, [esi + ebx] - lea ecx, [edx + IsMediumBlockFlag + IsFreeBlockFlag] - mov [eax - 4], ecx - {Store the size of the second split as the second last dword} - mov [eax + edx - 8], edx - {Put the remainder in a bin} - cmp edx, MinimumMediumBlockSize - jb @GotMediumBlockForMedium - call InsertMediumBlockIntoBin - jmp @GotMediumBlockForMedium - {Align branch target} - nop - nop - nop -@UseWholeBlockForMedium: - {Mark this block as used in the block following it} - and byte ptr [esi + edi - 4], not PreviousMediumBlockIsFreeFlag -@GotMediumBlockForMedium: - {Set the size and flags for this block} - lea ecx, [ebx + IsMediumBlockFlag] - mov [esi - 4], ecx - {Unlock medium blocks} - mov MediumBlocksLocked, False - mov eax, esi - pop edi - pop esi - pop ebx - ret -{-------------------Large block allocation-------------------} - {Align branch target} -@IsALargeBlockRequest: - pop ebx - test eax, eax - jns AllocateLargeBlock - xor eax, eax -end; -{$endif} - -{$ifndef ASMVersion} -{Frees a medium block, returning 0 on success, -1 otherwise} -function FreeMediumBlock(APointer: Pointer): Integer; -var - LNextMediumBlock{$ifndef FullDebugMode}, LPreviousMediumBlock{$endif}: PMediumFreeBlock; - LNextMediumBlockSizeAndFlags: Cardinal; - LBlockSize{$ifndef FullDebugMode}, LPreviousMediumBlockSize{$endif}: Cardinal; -{$ifndef FullDebugMode} - LPPreviousMediumBlockPoolHeader, LPNextMediumBlockPoolHeader: PMediumBlockPoolHeader; -{$endif} - LBlockHeader: Cardinal; -begin - {Get the block header} - LBlockHeader := PCardinal(Cardinal(APointer) - BlockHeaderSize)^; - {Get the medium block size} - LBlockSize := LBlockHeader and DropMediumAndLargeFlagsMask; - {Lock the medium blocks} - LockMediumBlocks; - {Can we combine this block with the next free block?} - LNextMediumBlock := PMediumFreeBlock(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; -{Replacement for SysFreeMem (pascal version)} -function FastFreeMem(APointer: Pointer): Integer; -var - LPSmallBlockPool{$ifndef FullDebugMode}, LPPreviousPool, LPNextPool{$endif}, - LPOldFirstPool: PSmallBlockPoolHeader; - LPSmallBlockType: PSmallBlockType; - LOldFirstFreeBlock: Pointer; - LBlockHeader: Cardinal; -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 -{$ifndef NeverSleepOnThreadContention} - Sleep(InitialSleepTime); - if LockCmpxchg(0, 1, @LPSmallBlockType.BlockTypeLocked) = 0 then - break; - Sleep(AdditionalSleepTime); -{$endif} - end; - end; - {Get the old first free block} - LOldFirstFreeBlock := LPSmallBlockPool.FirstFreeBlock; - {Was the pool manager previously full?} - if LOldFirstFreeBlock = nil then - begin - {Insert this as the first partially free pool for the block size} - LPOldFirstPool := LPSmallBlockType.NextPartiallyFreePool; - LPSmallBlockPool.NextPartiallyFreePool := LPOldFirstPool; - LPOldFirstPool.PreviousPartiallyFreePool := LPSmallBlockPool; - LPSmallBlockPool.PreviousPartiallyFreePool := PSmallBlockPoolHeader(LPSmallBlockType); - LPSmallBlockType.NextPartiallyFreePool := LPSmallBlockPool; - end; - {Store the old first free block} - 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; - {Free the block pool} - FreeMediumBlock(LPSmallBlockPool); - end - else - begin -{$endif} - {Unlock this block type} - LPSmallBlockType.BlockTypeLocked := False; -{$ifndef FullDebugMode} - end; -{$endif} - {No error} - Result := 0; - end - else - begin - {Is this a medium block or a large block?} - if LBlockHeader and (IsFreeBlockFlag or IsLargeBlockFlag) = 0 then - begin - Result := FreeMediumBlock(APointer); - end - else - begin - {Validate: Is this actually a Large block, or is it an attempt to free an - already freed small block?} - if LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag) = 0 then - Result := FreeLargeBlock(APointer) - else - Result := -1; - end; - end; -end; -{$else} -{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 -{$ifndef NeverSleepOnThreadContention} - {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 -{$else} - {Pause instruction (improves performance on P4)} - rep nop - {Try again} - jmp @LockBlockTypeLoop - {Align branch target} - nop -{$endif} - {---------------------Medium blocks------------------------------} - {Align branch target} -@NotSmallBlockInUse: - {Not a small block in use: is it a medium or large block?} - test dl, IsFreeBlockFlag + IsLargeBlockFlag - jnz @NotASmallOrMediumBlock -@FreeMediumBlock: - {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} - jz @MediumBlocksLocked -{$endif} - call LockMediumBlocks -@MediumBlocksLocked: - {Can we combine this block with the next free block?} - test dword ptr [esi + ebx - 4], IsFreeBlockFlag - {Get the next block size and flags in ecx} - mov ecx, [esi + ebx - 4] - jnz @NextBlockIsFree - {Set the "PreviousIsFree" flag in the next block} - or ecx, PreviousMediumBlockIsFreeFlag - mov [esi + ebx - 4], ecx -@NextBlockChecked: - {Can we combine this block with the previous free block? We need to - re-read the flags since it could have changed before we could lock the - medium blocks.} - test byte ptr [esi - 4], PreviousMediumBlockIsFreeFlag - jnz @PreviousBlockIsFree -@PreviousBlockChecked: - {Is the entire medium block pool free, and there are other free blocks - that can fit the largest possible medium block -> free it.} - cmp ebx, (MediumBlockPoolSize - MediumBlockPoolHeaderSize) - je @EntireMediumPoolFree -@BinFreeMediumBlock: - {Store the size of the block as well as the flags} - lea eax, [ebx + IsMediumBlockFlag + IsFreeBlockFlag] - mov [esi - 4], eax - {Store the trailing size marker} - mov [esi + ebx - 8], ebx - {Insert this block back into the bins: Size check not required here, - since medium blocks that are in use are not allowed to be - shrunk smaller than MinimumMediumBlockSize} - mov eax, esi - mov edx, ebx - {Insert into bin} - call InsertMediumBlockIntoBin - {Unlock medium blocks} - mov MediumBlocksLocked, False; - {All OK} - xor eax, eax - {Restore registers} - pop esi - pop ebx - {Return} - ret - {Align branch target} -@NextBlockIsFree: - {Get the next block address in eax} - lea eax, [esi + ebx] - {Increase the size of this block} - and ecx, DropMediumAndLargeFlagsMask - add ebx, ecx - {Was the block binned?} - cmp ecx, MinimumMediumBlockSize - jb @NextBlockChecked - call RemoveMediumFreeBlock - jmp @NextBlockChecked - {Align branch target} - nop -@PreviousBlockIsFree: - {Get the size of the free block just before this one} - mov ecx, [esi - 8] - {Include the previous block} - sub esi, ecx - {Set the new block size} - add ebx, ecx - {Remove the previous block from the linked list} - cmp ecx, MinimumMediumBlockSize - jb @PreviousBlockChecked - mov eax, esi - call RemoveMediumFreeBlock - jmp @PreviousBlockChecked - {Align branch target} -@EntireMediumPoolFree: - {Should we make this the new sequential feed medium block pool? If the - current sequential feed pool is not entirely free, we make this the new - sequential feed pool.} - cmp MediumSequentialFeedBytesLeft, MediumBlockPoolSize - MediumBlockPoolHeaderSize - jne @MakeEmptyMediumPoolSequentialFeed - {Point esi to the medium block pool header} - sub esi, MediumBlockPoolHeaderSize - {Remove this medium block pool from the linked list} - mov eax, TMediumBlockPoolHeader[esi].PreviousMediumBlockPoolHeader - mov edx, TMediumBlockPoolHeader[esi].NextMediumBlockPoolHeader - mov TMediumBlockPoolHeader[eax].NextMediumBlockPoolHeader, edx - mov TMediumBlockPoolHeader[edx].PreviousMediumBlockPoolHeader, eax - {Unlock medium blocks} - mov MediumBlocksLocked, False; - {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: probably an 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} -@DoMediumLockForDownsize: - {Lock the medium blocks (ecx *must* be preserved)} - call LockMediumBlocks - {Reread the flags - they may have changed before medium blocks could be - locked.} - mov ebx, ExtractMediumAndLargeFlagsMask - and ebx, [esi - 4] -@DoMediumInPlaceDownsize: - {Set the new size} - or ebx, ebp - mov [esi - 4], ebx - {Get the second split size in ebx} - mov ebx, ecx - {Is the next block in use?} - mov edx, [edi - 4] - test dl, IsFreeBlockFlag - jnz @MediumDownsizeNextBlockFree - {The next block is in use: flag its previous block as free} - or edx, PreviousMediumBlockIsFreeFlag - mov [edi - 4], edx - jmp @MediumDownsizeDoSplit - {Align branch target} - nop - nop -{$ifdef AssumeMultiThreaded} - nop -{$endif} -@MediumDownsizeNextBlockFree: - {The next block is free: combine it} - mov eax, edi - and edx, DropMediumAndLargeFlagsMask - add ebx, edx - add edi, edx - cmp edx, MinimumMediumBlockSize - jb @MediumDownsizeDoSplit - call RemoveMediumFreeBlock -@MediumDownsizeDoSplit: - {Store the trailing size field} - mov [edi - 8], ebx - {Store the free part's header} - lea eax, [ebx + IsMediumBlockFlag + IsFreeBlockFlag]; - mov [esi + ebp - 4], eax - {Bin this free block} - cmp ebx, MinimumMediumBlockSize - jb @MediumBlockDownsizeDone - lea eax, [esi + ebp] - mov edx, ebx - call InsertMediumBlockIntoBin -@MediumBlockDownsizeDone: - {Unlock the medium blocks} - mov MediumBlocksLocked, False - {Result = old pointer} - mov eax, esi - {Restore registers} - pop ebp - pop edi - pop esi - pop ebx - {Return} - ret - {Align branch target} -@MediumDownsizeRealloc: - {Save the requested size} - mov edi, edx - mov eax, edx - {Allocate the new block} - call FastGetMem - test eax, eax - jz @MediumBlockDownsizeExit - {Save the result} - mov ebp, eax - mov edx, eax - mov eax, esi - mov ecx, edi - {Move the data across} -{$ifdef UseCustomVariableSizeMoveRoutines} - {$ifdef Align16Bytes} - call 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 (ecx and edx *must* be preserved} - call LockMediumBlocks - {Re-read the info for this block (since it may have changed before the medium - blocks could be locked)} - mov ebx, ExtractMediumAndLargeFlagsMask - and ebx, [esi - 4] - {Re-read the info for the next block} - mov eax, [edi - 4] - {Next block still free?} - test al, IsFreeBlockFlag - jz @NextMediumBlockChanged - {Recalculate the next block size} - and eax, DropMediumAndLargeFlagsMask - {The available size including the next block} - lea ebp, [eax + ecx] - {Can the block still fit?} - cmp edx, ebp - ja @NextMediumBlockChanged -@DoMediumInPlaceUpsize: - {Is the next block binnable?} - cmp eax, MinimumMediumBlockSize - {Remove the next block} - jb @MediumInPlaceNoNextRemove - mov eax, edi - push ecx - push edx - call RemoveMediumFreeBlock - pop edx - pop ecx -@MediumInPlaceNoNextRemove: - {Medium blocks grow a minimum of 25% in in-place upsizes} - mov eax, ecx - shr eax, 2 - add eax, ecx - {Get the maximum of the requested size and the minimum growth size} - xor edi, edi - sub eax, edx - adc edi, -1 - and eax, edi - {Round up to the nearest block size granularity} - lea eax, [eax + edx + BlockHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset] - and eax, -MediumBlockGranularity - add eax, MediumBlockSizeOffset - {Calculate the size of the second split} - lea edx, [ebp + BlockHeaderSize] - sub edx, eax - {Does it fit?} - ja @MediumInPlaceUpsizeSplit - {Grab the whole block: Mark it as used in the block following it} - and dword ptr [esi + ebp], not PreviousMediumBlockIsFreeFlag - {The block size is the full available size plus header} - add ebp, 4 - {Upsize done} - jmp @MediumUpsizeInPlaceDone - {Align branch target} -{$ifndef AssumeMultiThreaded} - nop - nop - nop -{$endif} -@MediumInPlaceUpsizeSplit: - {Store the size of the second split as the second last dword} - mov [esi + ebp - 4], edx - {Set the second split header} - lea edi, [edx + IsMediumBlockFlag + IsFreeBlockFlag] - mov [esi + eax - 4], edi - mov ebp, eax - cmp edx, MinimumMediumBlockSize - jb @MediumUpsizeInPlaceDone - add eax, esi - call InsertMediumBlockIntoBin -@MediumUpsizeInPlaceDone: - {Set the size and flags for this block} - or ebp, ebx - mov [esi - 4], ebp - {Unlock the medium blocks} - mov MediumBlocksLocked, False - {Result = old pointer} - mov eax, esi -@MediumBlockResizeDone2: - {Restore registers} - pop ebp - pop edi - pop esi - pop ebx - {Return} - ret - {Align branch target for "@CannotUpsizeMediumBlockInPlace"} - nop - nop -@NextMediumBlockChanged: - {The next medium block changed while the medium blocks were being locked} - mov MediumBlocksLocked, False -@CannotUpsizeMediumBlockInPlace: - {Couldn't upsize in place. Grab a new block and move the data across: - If we have to reallocate and move medium blocks, we grow by at - least 25%} - mov eax, ecx - shr eax, 2 - add eax, ecx - {Get the maximum of the requested size and the minimum growth size} - xor edi, edi - sub eax, edx - adc edi, -1 - and eax, edi - add eax, edx - {Save the size to allocate} - mov ebp, eax - {Save the size to move across} - mov edi, ecx - {Get the block} - push edx - call FastGetMem - pop edx - {Success?} - test eax, eax - jz @MediumBlockResizeDone2 - {If it's a Large block - store the actual user requested size} - cmp ebp, MaximumMediumBlockSize - BlockHeaderSize - jbe @MediumUpsizeNotLarge - mov [eax - 8], edx -@MediumUpsizeNotLarge: - {Save the result} - mov ebp, eax - {Move the data across} - mov edx, eax - mov eax, esi - mov ecx, edi -{$ifdef UseCustomVariableSizeMoveRoutines} - call 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); - ShowMessageBox(InvalidGetMemMsg, LErrorMessageTitle); -{$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); - ShowMessageBox(InvalidFreeMemMsg, LErrorMessageTitle); -{$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); - ShowMessageBox(InvalidReallocMemMsg, LErrorMessageTitle); -{$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); - ShowMessageBox(InvalidAllocMemMsg, LErrorMessageTitle); -{$endif} - Result := nil; -end; - -function InvalidRegisterAndUnRegisterMemoryLeak(APointer: Pointer): Boolean; -begin - Result := False; -end; - -{$endif} - -{-----------------Full Debug Mode Memory Manager Interface--------------------} - -{$ifdef FullDebugMode} - -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 := AppendModuleFileName(@MMLogFileName[0]); - {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 ecx, 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); - ShowMessageBox(LErrorMessage, LErrorMessageTitle); -{$endif} -end; - -{Logs the stack traces for a memory leak to file} -procedure LogMemoryLeakOrAllocatedBlock(APointer: PFullDebugBlockHeader; IsALeak: Boolean); -var - LHeaderValid: boolean; - LMsgPtr: 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); - {Clear the block} - if Result <> nil 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); - ShowMessageBox(LErrorMessage, LErrorMessageTitle); -{$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); - ShowMessageBox(LErrorMessage, LErrorMessageTitle); -{$endif} - {Raise an access violation} - RaiseException(EXCEPTION_ACCESS_VIOLATION, 0, 0, nil); -end; -{$endif} - -{$endif} - -{----------------------------Memory Leak Checking-----------------------------} - -{$ifdef EnableMemoryLeakReporting} - -{Adds a leak to the specified list} -function UpdateExpectedLeakList(APLeakList: PPExpectedMemoryLeak; - APNewEntry: PExpectedMemoryLeak; AExactSizeMatch: Boolean = True): boolean; -var - LPInsertAfter, LPNewEntry: PExpectedMemoryLeak; -begin - {Default to error} - Result := False; - {Find the insertion spot} - LPInsertAfter := APLeakList^; - while (LPInsertAfter <> nil) do - begin - {Too big?} - if (LPInsertAfter.LeakSize > APNewEntry.LeakSize) then - begin - LPInsertAfter := LPInsertAfter.PreviousLeak; - break; - end; - {Find a matching entry. If an exact size match is not required and the leak - is larger than the current entry, use it if the expected size of the next - entry is too large.} - if (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; - if LPNewEntry.NextLeak <> nil then - LPNewEntry.NextLeak.PreviousLeak := LPNewEntry; - LPInsertAfter.NextLeak := LPNewEntry; - end - else - begin - LPNewEntry.NextLeak := APLeakList^; - if LPNewEntry.NextLeak <> nil then - LPNewEntry.NextLeak.PreviousLeak := LPNewEntry; - APLeakList^ := LPNewEntry; - end; - Result := True; - end; -end; - -{Locks the expected leaks. Returns false if the list could not be allocated.} -function LockExpectedMemoryLeaksList: Boolean; -begin - {Lock the expected leaks list} -{$ifndef AssumeMultiThreaded} - if IsMultiThread then -{$endif} - begin - while LockCmpxchg(0, 1, @ExpectedMemoryLeaksListLocked) <> 0 do - begin -{$ifndef NeverSleepOnThreadContention} - Sleep(InitialSleepTime); - if LockCmpxchg(0, 1, @ExpectedMemoryLeaksListLocked) = 0 then - break; - Sleep(AdditionalSleepTime); -{$endif} - end; - end; - {Allocate the list if it does not exist} - if ExpectedMemoryLeaks = nil then - ExpectedMemoryLeaks := VirtualAlloc(nil, ExpectedMemoryLeaksListSize, MEM_COMMIT, PAGE_READWRITE); - {Done} - Result := ExpectedMemoryLeaks <> nil; -end; - -{Registers expected memory leaks. Returns true on success. The list of leaked - blocks is limited, so failure is possible if the list is full.} -function RegisterExpectedMemoryLeak(ALeakedPointer: Pointer): boolean; overload; -var - LNewEntry: TExpectedMemoryLeak; -begin - {Fill out the structure} -{$ifndef FullDebugMode} - LNewEntry.LeakAddress := ALeakedPointer; -{$else} - LNewEntry.LeakAddress := Pointer(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); - ShowMessageBox(LLeakMessage, LMessageTitleBuffer); - {$endif} - end; - end; -{$endif} -end; - -{Returns statistics about the current state of the memory manager} -procedure GetMemoryManagerState(var AMemoryManagerState: TMemoryManagerState); -var - LPMediumBlockPoolHeader: PMediumBlockPoolHeader; - LPMediumBlock: Pointer; - LInd: Integer; - LBlockTypeIndex, LMediumBlockSize, 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); - ShowMessageBox(AlreadyInstalledMsg, LErrorMessageTitle); -{$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); - ShowMessageBox(OtherMMInstalledMsg, LErrorMessageTitle); - {$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); - ShowMessageBox(MemoryAllocatedMsg, LErrorMessageTitle); - {$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 FullDebugMode} - {$ifdef LoadDebugDLLDynamically} - {Attempt to load the FullDebugMode DLL dynamically.} - FullDebugModeDLL := LoadLibrary(FullDebugModeLibraryName); - if FullDebugModeDLL <> 0 then - begin - GetStackTrace := GetProcAddress(FullDebugModeDLL, - {$ifdef RawStackTraces}'GetRawStackTrace'{$else}'GetFrameBasedStackTrace'{$endif}); - LogStackTrace := GetProcAddress(FullDebugModeDLL, 'LogStackTrace'); - end; - {$endif} -{$endif} -{$ifdef EnableMMX} - {$ifndef ForceMMX} - UseMMX := MMX_Supported; - {$endif} -{$endif} - {Initialize the memory manager} - {-------------Set up the small block types-------------} - LPreviousBlockSize := 0; - for 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; -{$ifdef MMSharingEnabled} -var - i, LCurrentProcessID: Cardinal; -{$endif} -begin - if not FastMMIsInstalled then - begin -{$ifdef FullDebugMode} - {Try to reserve the 64K block} - ReservedBlock := VirtualAlloc(Pointer(DebugReservedAddress), 65536, MEM_RESERVE, PAGE_NOACCESS); -{$endif} -{$ifdef MMSharingEnabled} - {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. diff --git a/components/fastmm/FastMM4Messages.pas b/components/fastmm/FastMM4Messages.pas deleted file mode 100644 index 600f2e7..0000000 --- a/components/fastmm/FastMM4Messages.pas +++ /dev/null @@ -1,140 +0,0 @@ -{ - -Fast Memory Manager: Messages - -English translation by Pierre le Riche. - -} - -unit FastMM4Messages; - -interface - -{$Include FastMM4Options.inc} - -const - {The name of the debug info support DLL} - FullDebugModeLibraryName = 'FastMM_FullDebugMode.dll'; - {Event log strings} - LogFileExtension = '_MemoryManager_EventLog.txt'#0; - CRLF = #13#10; - EventSeparator = '--------------------------------'; - {Class name messages} - UnknownClassNameMsg = 'Unknown'; - {Stack trace Message} - CurrentStackTraceMsg = #13#10#13#10'The current stack trace leading to this error (return addresses): '; - {Memory dump message} - MemoryDumpMsg = #13#10#13#10'Current memory dump of 256 bytes starting at pointer address '; - {Block Error Messages} - BlockScanLogHeader = 'Allocated block logged by LogAllocatedBlocksToFile. The size is: '; - ErrorMsgHeader = 'FastMM has detected an error during a '; - GetMemMsg = 'GetMem'; - FreeMemMsg = 'FreeMem'; - ReallocMemMsg = 'ReallocMem'; - BlockCheckMsg = 'free block scan'; - OperationMsg = ' operation. '; - BlockHeaderCorruptedMsg = 'The block header has been corrupted. '; - BlockFooterCorruptedMsg = 'The block footer has been corrupted. '; - FreeModifiedErrorMsg = 'FastMM detected that a block has been modified after being freed. '; - DoubleFreeErrorMsg = 'An attempt has been made to free/reallocate an unallocated block.'; - PreviousBlockSizeMsg = #13#10#13#10'The previous block size was: '; - CurrentBlockSizeMsg = #13#10#13#10'The block size is: '; - StackTraceAtPrevAllocMsg = #13#10#13#10'Stack trace of when this block was previously allocated (return addresses):'; - StackTraceAtAllocMsg = #13#10#13#10'Stack trace of when this block was allocated (return addresses):'; - PreviousObjectClassMsg = #13#10#13#10'The block was previously used for an object of class: '; - CurrentObjectClassMsg = #13#10#13#10'The block is currently used for an object of class: '; - PreviousAllocationGroupMsg = #13#10#13#10'The allocation group was: '; - PreviousAllocationNumberMsg = #13#10#13#10'The allocation number was: '; - CurrentAllocationGroupMsg = #13#10#13#10'The allocation group is: '; - CurrentAllocationNumberMsg = #13#10#13#10'The allocation number is: '; - StackTraceAtFreeMsg = #13#10#13#10'Stack trace of when the block was previously freed (return addresses):'; - BlockErrorMsgTitle = 'Memory Error Detected'; - {Virtual Method Called On Freed Object Errors} - StandardVirtualMethodNames: array[1 + vmtParent div 4 .. -1] of PChar = ( - 'SafeCallException', - 'AfterConstruction', - 'BeforeDestruction', - 'Dispatch', - 'DefaultHandler', - 'NewInstance', - 'FreeInstance', - 'Destroy'); - VirtualMethodErrorHeader = 'FastMM has detected an attempt to call a virtual method on a freed object. An access violation will now be raised in order to abort the current operation.'; - InterfaceErrorHeader = 'FastMM has detected an attempt to use an interface of a freed object. An access violation will now be raised in order to abort the current operation.'; - BlockHeaderCorruptedNoHistoryMsg = ' Unfortunately the block header has been corrupted so no history is available.'; - FreedObjectClassMsg = #13#10#13#10'Freed object class: '; - VirtualMethodName = #13#10#13#10'Virtual method: '; - VirtualMethodOffset = 'Offset +'; - VirtualMethodAddress = #13#10#13#10'Virtual method address: '; - StackTraceAtObjectAllocMsg = #13#10#13#10'Stack trace of when the object was allocated (return addresses):'; - StackTraceAtObjectFreeMsg = #13#10#13#10'Stack trace of when the object was subsequently freed (return addresses):'; - {Installation Messages} - AlreadyInstalledMsg = 'FastMM4 is already installed.'; - AlreadyInstalledTitle = 'Already installed.'; - OtherMMInstalledMsg = 'FastMM4 cannot be installed since another third party memory ' - + 'manager has already installed itself.'#13#10'If you want to use FastMM4, ' - + 'please make sure that FastMM4.pas is the very first unit in the "uses"' - + #13#10'section of your project''s .dpr file.'; - OtherMMInstalledTitle = 'Cannot install FastMM4 - Another memory manager is already installed'; - MemoryAllocatedMsg = 'FastMM4 cannot install since memory has already been ' - + 'allocated through the default memory manager.'#13#10'FastMM4.pas MUST ' - + 'be the first unit in your project''s .dpr file, otherwise memory may ' - + 'be allocated'#13#10'through the default memory manager before FastMM4 ' - + 'gains control. '#13#10#13#10'If you are using an exception trapper ' - + 'like MadExcept (or any tool that modifies the unit initialization ' - + 'order),'#13#10'go into its configuration page and ensure that the ' - + 'FastMM4.pas unit is initialized before any other unit.'; - MemoryAllocatedTitle = 'Cannot install FastMM4 - Memory has already been allocated'; - {Leak checking messages} - LeakLogHeader = 'A memory block has been leaked. The size is: '; - LeakMessageHeader = 'This application has leaked memory. '; - SmallLeakDetail = 'The small block leaks are' -{$ifdef HideExpectedLeaksRegisteredByPointer} - + ' (excluding expected leaks registered by pointer)' -{$endif} - + ':'#13#10; - LargeLeakDetail = 'The sizes of leaked medium and large blocks are' -{$ifdef HideExpectedLeaksRegisteredByPointer} - + ' (excluding expected leaks registered by pointer)' -{$endif} - + ': '; - BytesMessage = ' bytes: '; - StringBlockMessage = 'String'; - LeakMessageFooter = #13#10 -{$ifndef HideMemoryLeakHintMessage} - + #13#10'Note: ' - {$ifdef RequireIDEPresenceForLeakReporting} - + 'This memory leak check is only performed if Delphi is currently running on the same computer. ' - {$endif} - {$ifdef FullDebugMode} - {$ifdef LogMemoryLeakDetailToFile} - + 'Memory leak detail is logged to a text file in the same folder as this application. ' - {$else} - + 'Enable the "LogMemoryLeakDetailToFile" to obtain a log file containing detail on memory leaks. ' - {$endif} - {$else} - + 'To obtain a log file containing detail on memory leaks, enable the "FullDebugMode" and "LogMemoryLeakDetailToFile" conditional defines. ' - {$endif} - + 'To disable this memory leak check, undefine "EnableMemoryLeakReporting".'#13#10 -{$endif} - + #0; - LeakMessageTitle = 'Memory Leak Detected'; -{$ifdef UseOutputDebugString} - FastMMInstallMsg = 'FastMM has been installed.'; - FastMMInstallSharedMsg = 'Sharing an existing instance of FastMM.'; - FastMMUninstallMsg = 'FastMM has been uninstalled.'; - FastMMUninstallSharedMsg = 'Stopped sharing an existing instance of FastMM.'; -{$endif} -{$ifdef DetectMMOperationsAfterUninstall} - InvalidOperationTitle = 'MM Operation after uninstall.'; - InvalidGetMemMsg = 'FastMM has detected a GetMem call after FastMM was uninstalled.'; - InvalidFreeMemMsg = 'FastMM has detected a FreeMem call after FastMM was uninstalled.'; - InvalidReallocMemMsg = 'FastMM has detected a ReallocMem call after FastMM was uninstalled.'; - InvalidAllocMemMsg = 'FastMM has detected an AllocMem call after FastMM was uninstalled.'; -{$endif} - -implementation - -end. - - diff --git a/components/fastmm/FastMM4Options.inc b/components/fastmm/FastMM4Options.inc deleted file mode 100644 index 481f2d6..0000000 --- a/components/fastmm/FastMM4Options.inc +++ /dev/null @@ -1,303 +0,0 @@ -{ - -Fast Memory Manager: Options Include File - -Set the default options for FastMM here. - -} - -{---------------------------Miscellaneous Options-----------------------------} - -{Enable this define to align all blocks on 16 byte boundaries so aligned SSE - instructions can be used safely. If this option is disabled then some of the - smallest block sizes will be 8-byte aligned instead which may result in a - reduction in memory usage. Medium and large blocks are always 16-byte aligned - irrespective of this setting.} -{.$define Align16Bytes} - -{Enable to use faster fixed-size move routines when upsizing small blocks. - These routines are much faster than the Borland RTL move procedure since they - are optimized to move a fixed number of bytes. This option may be used - together with the FastMove library for even better performance.} -{$define UseCustomFixedSizeMoveRoutines} - -{Enable this option to use an optimized procedure for moving a memory block of - an arbitrary size. Disable this option when using the Fastcode move - ("FastMove") library. Using the Fastcode move library allows your whole - application to gain from faster move routines, not just the memory manager. It - is thus recommended that you use the Fastcode move library in conjunction with - this memory manager and disable this option.} -{$define UseCustomVariableSizeMoveRoutines} - -{Enable to always assume that the application is multithreaded. Enabling this - option will cause a significant performance hit with single threaded - applications. Enable if you are using multi-threaded third party tools that do - not properly set the IsMultiThread variable. Also set this option if you are - going to share this memory manager between a single threaded application and a - multi-threaded DLL.} -{.$define AssumeMultiThreaded} - -{Enable this option to never put a thread to sleep if a thread contention - occurs. This option will improve performance if the ratio of the number of - active threads to the number of CPU cores is low (typically < 2). With this - option set a thread will enter a "busy waiting" loop instead of relinquishing - its timeslice when a thread contention occurs.} -{.$define NeverSleepOnThreadContention} - -{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. Setting this option will - circumvent this problem by never uninstalling the memory manager.} -{.$define NeverUninstall} - -{Set this option when you use runtime packages in this application or library. - This will automatically set the "AssumeMultiThreaded" option. Note that you - have to ensure that FastMM is finalized after all live pointers have been - freed - failure to do so will result in a large leak report followed by a lot - of A/Vs. (See the FAQ for more detail.) You may have to combine this option - with the NeverUninstall option.} -{.$define UseRuntimePackages} - -{-----------------------------Debugging Options-------------------------------} - -{Enable this option to suppress the generation of debug info for the - FastMM4.pas unit. This will prevent the integrated debugger from stepping into - the memory manager code.} -{$define NoDebugInfo} - -{Enable this option to suppress the display of all message dialogs. This is - useful in service applications that should not be interrupted.} -{.$define NoMessageBoxes} - -{Set this option to use the Windows API OutputDebugString procedure to output - debug strings on startup/shutdown and when errors occur.} -{.$define UseOutputDebugString} - -{Set this option to use the assembly language version which is faster than the - pascal version. Disable only for debugging purposes. Setting the - CheckHeapForCorruption option automatically disables this option.} -{$define ASMVersion} - -{FastMM always catches attempts to free the same memory block twice, however it - can also check for corruption of the memory heap (typically due to the user - program overwriting the bounds of allocated memory). These checks are - expensive, and this option should thus only be used for debugging purposes. - If this option is set then the ASMVersion option is automatically disabled.} -{.$define CheckHeapForCorruption} - -{Enable this option to catch attempts to perform MM operations after FastMM has - been uninstalled. With this option set when FastMM is uninstalled it will not - install the previous MM, but instead a dummy MM handler that throws an error - if any MM operation is attempted. This will catch attempts to use the MM - after FastMM has been uninstalled.} -{$define DetectMMOperationsAfterUninstall} - -{Set the following option to do extensive checking of all memory blocks. All - blocks are padded with both a header and trailer that are used to verify the - integrity of the heap. Freed blocks are also cleared to to ensure that they - cannot be reused after being freed. This option slows down memory operations - dramatically and should only be used to debug an application that is - overwriting memory or reusing freed pointers. Setting this option - automatically enables CheckHeapForCorruption and disables ASMVersion. - Very important: If you enable this option your application will require the - FastMM_FullDebugMode.dll library. If this library is not available you will - get an error on startup.} -{.$define FullDebugMode} - - {Set this option to perform "raw" stack traces, i.e. check all entries on the - stack for valid return addresses. Note that this is significantly slower - than using the stack frame tracing method, but is usually more complete. Has - no effect unless FullDebugMode is enabled} - {$define RawStackTraces} - - {Set this option to check for user code that uses an interface of a freed - object. Note that this will disable the checking of blocks modified after - being freed (the two are not compatible). This option has no effect if - FullDebugMode is not also enabled.} - {.$define CatchUseOfFreedInterfaces} - - {Set this option to log all errors to a text file in the same folder as the - application. Memory errors (with the FullDebugMode option set) will be - appended to the log file. Has no effect if "FullDebugMode" is not set.} - {$define LogErrorsToFile} - - {Set this option to log all memory leaks to a text file in the same folder as - the application. Memory leak reports (with the FullDebugMode option set) - will be appended to the log file. Has no effect if "LogErrorsToFile" and - "FullDebugMode" are not also set. Note that usually all leaks are always - logged, even if they are "expected" leaks registered through - AddExpectedMemoryLeaks. Expected leaks registered by pointer may be excluded - through the HideExpectedLeaksRegisteredByPointer option.} - {$define LogMemoryLeakDetailToFile} - - {Deletes the error log file on startup. No effect if LogErrorsToFile is not - also set.} - {.$define ClearLogFileOnStartup} - - {Loads the FASTMM_FullDebugMode.dll dynamically. If the DLL cannot be found - then stack traces will not be available. Note that this may cause problems - due to a changed DLL unload order when sharing the memory manager. Use with - care.} - {.$define LoadDebugDLLDynamically} - -{---------------------------Memory Leak Reporting-----------------------------} - -{Set this option to enable reporting of memory leaks. Combine it with the two - options below for further fine-tuning.} -{$define EnableMemoryLeakReporting} - - {Set this option to suppress the display and logging of expected memory leaks - that were registered by pointer. Leaks registered by size or class are often - ambiguous, so these expected leaks are always logged to file (in - FullDebugMode with the LogMemoryLeakDetailToFile option set) and are never - hidden from the leak display if there are more leaks than are expected.} - {$define HideExpectedLeaksRegisteredByPointer} - - {Set this option to require the presence of the Delphi IDE to report memory - leaks. This option has no effect if the option "EnableMemoryLeakReporting" - is not also set.} - {.$define RequireIDEPresenceForLeakReporting} - - {Set this option to require the program to be run inside the IDE debugger to - report memory leaks. This option has no effect if the option - "EnableMemoryLeakReporting" is not also set.} - {$define RequireDebuggerPresenceForLeakReporting} - - {Set this option to require the presence of debug info ($D+ option) in the - compiled unit to perform memory leak checking. This option has no effect if - the option "EnableMemoryLeakReporting" is not also set.} - {.$define RequireDebugInfoForLeakReporting} - - {Set this option to enable manual control of the memory leak report. When - this option is set the ReportMemoryLeaksOnShutdown variable (default = false) - may be changed to select whether leak reporting should be done or not. When - this option is selected then both the variable must be set to true and the - other leak checking options must be applicable for the leak checking to be - done.} - {.$define ManualLeakReportingControl} - - {Set this option to disable the display of the hint below the memory leak - message.} - {.$define HideMemoryLeakHintMessage} - -{--------------------------Instruction Set Options----------------------------} - -{Set this option to enable the use of MMX instructions. Disabling this option - will result in a slight performance hit, but will enable compatibility with - AMD K5, Pentium I and earlier CPUs. MMX is currently only used in the variable - size move routines, so if UseCustomVariableSizeMoveRoutines is not set then - this option has no effect.} -{$define EnableMMX} - - {Set this option to force the use of MMX instructions without checking - whether the CPU supports it. If this option is disabled then the CPU will be - checked for compatibility first, and if MMX is not supported it will fall - back to the FPU move code. Has no effect unless EnableMMX is also set.} - {$define ForceMMX} - -{-----------------------Memory Manager Sharing Options------------------------} - -{Allow sharing of the memory manager between a main application and DLLs that - were also compiled with FastMM. This allows you to pass dynamic arrays and - long strings to DLL functions provided both are compiled to use FastMM. - Sharing will only work if the library that is supposed to share the memory - manager was compiled with the "AttemptToUseSharedMM" option set. Note that if - the main application is single threaded and the DLL is multi-threaded that you - have to set the IsMultiThread variable in the main application to true or it - will crash when a thread contention occurs. Note that statically linked DLL - files are initialized before the main application, so the main application may - well end up sharing a statically loaded DLL's memory manager and not the other - way around. } -{.$define ShareMM} - - {Allow sharing of the memory manager by a DLL with other DLLs (or the main - application if this is a statically loaded DLL) that were also compiled with - FastMM. Set this option with care in dynamically loaded DLLs, because if the - DLL that is sharing its MM is unloaded and any other DLL is still sharing - the MM then the application will crash. This setting is only relevant for - DLL libraries and requires ShareMM to also be set to have any effect. - Sharing will only work if the library that is supposed to share the memory - manager was compiled with the "AttemptToUseSharedMM" option set. Note that - if DLLs are statically linked then they will be initialized before the main - application and then the DLL will in fact share its MM with the main - application. This option has no effect unless ShareMM is also set.} - {.$define ShareMMIfLibrary} - - {Define this option to allow sharing between the default memory manager and - FastMM. This option only works together with the memory manager of BDS2006. - With this option enabled FastMM can be shared with applications using the - Delphi 2006 MM and vice versa. (You may have to add SimpleShareMem.pas to the - project using the Delphi 2006 memory manager to enable sharing.)} - {$define EnableSharingWithDefaultMM} - -{Define this to attempt to share the MM of the main application or other loaded - DLLs in the same process that were compiled with ShareMM set. When sharing a - memory manager, memory leaks caused by the sharer will not be freed - automatically. Take into account that statically linked DLLs are initialized - before the main application, so set the sharing options accordingly.} -{.$define AttemptToUseSharedMM} - -{--------------------------------Option Grouping------------------------------} - -{Group the options you use for release and debug versions below} -{$ifdef Release} - {Specify the options you use for release versions below} - {.$undef FullDebugMode} - {.$undef CheckHeapForCorruption} - {.$define ASMVersion} - {.$undef EnableMemoryLeakReporting} - {.$undef UseOutputDebugString} -{$else} - {Specify the options you use for debugging below} - {.$define FullDebugMode} - {.$define EnableMemoryLeakReporting} - {.$define UseOutputDebugString} -{$endif} - -{--------------------Compilation Options For borlndmm.dll---------------------} -{If you're compiling the replacement borlndmm.dll, set the defines below - for the kind of dll you require.} - -{Set this option when compiling the borlndmm.dll} -{.$define borlndmmdll} - -{Set this option if the dll will be used by the Delphi IDE} -{.$define dllforide} - -{Set this option if you're compiling a debug dll} -{.$define debugdll} - -{Do not change anything below this line} -{$ifdef borlndmmdll} - {$define AssumeMultiThreaded} - {$undef HideExpectedLeaksRegisteredByPointer} - {$undef RequireDebuggerPresenceForLeakReporting} - {$undef RequireDebugInfoForLeakReporting} - {$define DetectMMOperationsAfterUninstall} - {$undef ManualLeakReportingControl} - {$undef ShareMM} - {$undef AttemptToUseSharedMM} - {$ifdef dllforide} - {$define NeverUninstall} - {$define HideMemoryLeakHintMessage} - {$undef RequireIDEPresenceForLeakReporting} - {$ifndef debugdll} - {$undef EnableMemoryLeakReporting} - {$endif} - {$else} - {$define EnableMemoryLeakReporting} - {$undef NeverUninstall} - {$undef HideMemoryLeakHintMessage} - {$define RequireIDEPresenceForLeakReporting} - {$endif} - {$ifdef debugdll} - {$define FullDebugMode} - {$define RawStackTraces} - {$undef CatchUseOfFreedInterfaces} - {$define LogErrorsToFile} - {$define LogMemoryLeakDetailToFile} - {$undef ClearLogFileOnStartup} - {$else} - {$undef FullDebugMode} - {$endif} -{$endif} diff --git a/components/fastmm/FastMM4_FAQ.txt b/components/fastmm/FastMM4_FAQ.txt deleted file mode 100644 index d717dd1..0000000 --- a/components/fastmm/FastMM4_FAQ.txt +++ /dev/null @@ -1,77 +0,0 @@ -Frequently Asked Questions --------------------------- - -Q: When my program shuts down FastMM reports that it has leaked memory. Is it possible that FastMM is wrong? -A: Unfortunately, no. If FastMM reports that a block has been leaked, then it means that a block was allocated but never freed - thus leaked. Use a utility like Memproof to pinpoint the source of the problem. - -Q: When I enable the FullDebugMode option my application crashes with an access violation during startup. What's wrong? -A: The FastMM_FullDebugMode.dll library is required for FullDebugMode. Please make sure it is either in the same folder as the application, or it is accessible on the path. - -Q: I have enabled FullDebugMode, but I don't get any unit or line number information in the stack traces. Why? -A: For the FastMM_FullDebugMode.dll library to determine unit/line number information for stack traces any one of the following has to be available: TD32 debug info, a .map file, a .jdbg file or embedded JCL debug info. If none of these are available you will only get addresses in stack traces. For line numbers to be shown you also need to enable "Debug Information", "Reference Info" and "Use Debug DCUs". - -Q: I have enable FullDebugMode and get a log file containing stack traces of memory leaks, but no line numbers. Why? -A: To get line numbers you also need to enable "Debug Information", "Reference Info" and "Use Debug DCUs" on the "Compiler" tab of the "Project Options" dialog. - -Q: My program used to work fine with the Borland memory manager, but I get an "Invalid Pointer Operation" or "Access Violation" with FastMM. Is there a bug in FastMM? -A: Highly unlikely. The memory manager is such a critical part of any program and is subjected to such a large amount of traffic that it is rare that a bug of this nature will make it through testing. FastMM works differently than the default memory manager and does more pointer checking, so it will catch more errors. For example: The default MM may allow you to free the same pointer twice while FastMM will immediately raise an "Invalid Pointer Operation" if you try to do so. Compile your application with the "CheckHeapForCorruption" option set in FastMM4.pas - this should raise an error closer to the source of the problem. - -Q: My program used to work with replacement memory manager X, but I get an access violation when I try to use FastMM. Why? -A: There may still be a reference to the old memory manager somewhere in the source. Do a "find in files" and check that the old memory manager is not referenced in any "uses" clause. FastMM checks that it is the first memory manager that is being installed, but many other memory managers don't, so it's quite possible that another MM may be installing itself after FastMM. - -Q: FastMM doesn't make my program any faster. What's wrong? -A: If your program does not spend much time allocating and freeing memory, then there is little that FastMM can do to speed it up. For example: If your application spends only 1% of its time allocating memory using the default memory manager, a blazingly fast memory manager can at best make it 1% faster. FastMM is much faster than the default MM, but if the bottleneck in your program is not memory management then your gains may not be as great as you had hoped. - -Q: I have added FastMM4.pas as the very first unit in my project's .dpr file, but when I try to run my program it still complains that it is not the first unit. Why? -A: If you are using an exception handler that modifies the unit initialization order (like MadExcept or EurekaLog), you have to change its configuration so that FastMM is initialized first. - -Q: Delphi 2005 crashes with an error message "Class 'TApplication', already if class map" (sic) when I replace the default borlndmm.dll with the FastMM DLL. Why? -A: It is due to a bug in Delphi 2005 (QC#14007). There is an unofficial patch available that fixes this. Refer to FastMM4_Readme.txt for details. - -Q: I am using the replacement borlndmm.dll together with the Delphi IDE. When I open up two copies of Delphi and then close one down I get a memory leak report. Why? -A: When compiling the DLL you should set the "NeverUninstall" option. - -Q: I am using the replacement borlndmm.dll together with the Delphi 2005 IDE. When I close the IDE it remains in task manager. Why? -A: This is due to a bug (QC#14070). When compiling the DLL you should set the "NeverUninstall" option to work around it. - -Q: When a memory error pops up in "FullDebugMode" there is no debug info in the stack traces, only addresses. Why? -A: To be able to get unit/line number info there must be debug info available for the application - this can be in the form of a map file, a .jdbg file or embedded jcl debug info. Also, if the addresses are inside a dynamically loaded DLL that was unloaded before shutdown then FastMM will not be able to determine unit/line number info for them. - -Q: My program used to work fine, but if I enable "FullDebugMode" and run it I get an access violation at address $8080xxxx. Why? -A: You are attempting to access properties of a freed object. When you free a block in "FullDebugMode", FastMM fills the freed memory area with a pattern of $80 bytes. If there were any pointers, long strings or object references inside the freed object they will now point to $80808080 which is in a reserved address space. - -Q: In "FullDebugMode" when an error occurs the stack traces are very incomplete. Why? -A: You have probably disabled the "RawStackTraces" option. Without that option set, FastMM can only do a stack trace for routines that set up a stack frame. In the "Project Options" window on the "Compiler" tab, enable the "Stack Frames" option to create stack frames for all procedures. Note that the "RawStackTraces" option usually results in more complete stack traces, but may also introduce more (unavoidable) "false alarm" entries in the stack traces. - -Q: How do I get my DLL and main application to share FastMM so I can safely pass long strings and dynamic arrays between them? -A: The easiest way is to define ShareMM, ShareMMIfLibrary and AttemptToUseSharedMM in FastMM4.pas and add FastMM4.pas to the top of the uses section of the .dpr for both the main application and the DLL. - -Q: I am using Windows x64 edition. How do I enable my applications to address more than 2GB RAM? -A: Add a line containing {$SetPEFlags $20} to the .dpr file. This will set the LARGE_ADDRESS_AWARE flag in the executable and Windows x64 will consequently give the process a full 4GB user address space instead of the usual 2GB. - -Q: I get the following error when I try to use FastMM with an application compiled to use packages: "[Error] Need imported data reference ($G) to access 'IsMultiThread' from unit 'FastMM4'". How do I get it to work? -A: Enable the "UseRuntimePackages" option in FastMM4Options.inc. - -Q: I use runtime packages, and when my application shuts down I get a huge memory leak report followed by lots of access violations. Why? -A: This is most likely a package unload order problem: FastMM is uninstalled (and does the leak check) before all live pointers have been freed, and when the application subsequently tries to free the remaining live pointers the A/Vs occur. Either ensure that FastMM is unloaded last (using sharemem together with the replacement borlndmm.dll is one way), or use the "NeverUninstall" option and disable the memory leak report. - -Q: Since version 4.29 "FullDebugMode" is really slow. Why? -A: It is because of the new "RawStackTraces" option. Switch it off and performance will be on par with previous versions, but stack traces will be less complete. - -Q: I notice there is a precompiled debug borlndmm.dll for the IDE. Why would I need that? -A: You most likely won't. It's for hunting bugs in the IDE. - -Q: If I replace the borlndmm.dll used by the IDE, how does this affect the memory manager used by my applications? -A: It doesn't. If your application has sharemem.pas as the first unit in the project's .dpr file then it will use the first borlndmm.dll it finds on the path. It does not have to be the same one that the IDE uses. - -Q: Does enabling memory leak checking make my application slower? -A: No. Leak checking is only performed when the application shuts down. - -Q: With both the FullDebugMode and RawStackTraces options enabled I sometimes get stack traces with entries in them that cannot possibly be correct. Why? -A: This is an unfortunate side-effect of doing a raw stack trace. While raw stack traces are usually more complete than the alternate frame-based tracing (used when the RawStackTraces option is disabled), it does sometimes raise false alarms when data entries on the stack happen to correspond to valid return addresses in program code. While the raw stack trace code does extensive tests to differentiate between data and return addresses, it does get it wrong sometimes and these incorrect entries are the result. - -Q: I am trying to use FastMM inside a Kylix library, but I get a segmentation fault. Why? -A: Linux requires the code inside libraries to be position independent (with the base address indicated by ebx). The assembler code inside FastMM uses the ebx register for other purposes and is thus not position independent. If you want to use FastMM inside a Kylix library you have to disable the "ASMVersion" option in FastMM4Options.inc. - -Q: How can I share the memory manager between BDS2006 applications that don't use FastMM and libraries that use FastMM (or vice versa)? -A: Add the SimpleShareMem.pas file as the first unit in the uses section of projects that use the default Delphi 2006 MM, and make sure that the sharing mechanism of FastMM ("ShareMM" and "AttemptToUseSharedMM" options) is enabled for projects that use FastMM, but also enable the "EnableSharingWithDefaultMM" option. diff --git a/components/fastmm/FastMM4_Readme.txt b/components/fastmm/FastMM4_Readme.txt deleted file mode 100644 index 9292b00..0000000 --- a/components/fastmm/FastMM4_Readme.txt +++ /dev/null @@ -1,125 +0,0 @@ -Fast Memory Manager - Readme ----------------------------- - -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 - - - -Usage: ------- - -Delphi: Place this unit as the very first unit under the "uses" section in your project's .dpr file. When sharing memory between an application and a DLL (e.g. when passing a long string or dynamic array to a DLL function), both the main application and the DLL must be compiled using this memory manager (with the required conditional defines set). There are some conditional defines (inside FastMM4Options.inc) that may be used to tweak the memory manager. To enable support for a user mode address space greater than 2GB you will have to use the EditBin* tool to set the LARGE_ADDRESS_AWARE flag in the EXE header. This informs Windows x64 or Windows 32-bit (with the /3GB option set) that the application supports an address space larger than 2GB (up to 4GB). In Delphi 6 and later you can also specify this flag through the compiler directive {$SetPEFlags $20} -*The EditBin tool ships with the MS Visual C compiler. -C++ Builder 6: Refer to the instructions inside FastMM4BCB.cpp. - - - -License: --------- - -This work is copyright Professional Software Development / Pierre le Riche. It is released under a dual license, and you may choose to use it under either the Mozilla Public License 1.1 (MPL 1.1, available from http://www.mozilla.org/MPL/MPL-1.1.html) or the GNU Lesser General Public License 2.1 (LGPL 2.1, available from http://www.opensource.org/licenses/lgpl-license.php). If you find FastMM useful or you would like to support further development, a donation would be much appreciated. My banking details are: - Country: South Africa - Bank: ABSA Bank Ltd - Branch: Somerset West - Branch Code: 334-712 - Account Name: PSD (Distribution) - Account No.: 4041827693 - Swift Code: ABSAZAJJ -My PayPal account is: - bof@psd.co.za - - - -Contact Details: ----------------- - -My contact details are shown below if you would like to get in touch with me. If you use this memory manager I would like to hear from you: please e-mail me your comments - good and bad. - -Snailmail: - PO Box 2514 - Somerset West - 7129 - South Africa - -E-mail: - plr@psd.co.za - - - -Support: --------- - -If you have trouble using FastMM, you are welcome to drop me an e-mail at the address above, or you may post your questions in the BASM newsgroup on the 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. - - - -This archive contains: ----------------------- - -1) FastMM4.pas - The replacement memory manager (to speed up your applications) - -2) CPP Builder Support\FastMM4BCB.cpp - The Borland C++ Builder 6 support unit for FastMM4 - -3) Replacement BorlndMM DLL\BorlndMM.dpr - The project to build a replacement borlndmm.dll (to speed up the Delphi IDE) - -4) FullDebugMode DLL\FastMM_FullDebugMode.dpr - The project to build the FastMM_FullDebugMode.dll. This support DLL is required only when using "FullDebugMode". - -5) Usage Tracker\FastMMUsageTracker.pas - The address space and memory manager state monitoring utility for FastMM. (A demo is included in the same folder.) - -6) Translations - This folder contains FastMM4Messages.pas files translated to various languages. The default FastMM4Messages.pas (in this folder) is the English version. - -Documentation for each part is available inside its folder and also as comments inside the source. Refer to the FAQ if you have any questions, or contact me via e-mail. - - -FastMM Optional Features (FastMM4Options.Inc): ----------------------------------------------- - -The default options in FastMM4Options.Inc are configured for optimal performance when FastMM4.pas is added as the first unit in the uses clause of the .dpr. There are various other options available that control the sharing of the memory manager between libraries and the main application, as well as the debugging features of FastMM. There is a short description for each option inside the FastMM4Options.inc file that explains what the option does. - -By default, memory leak checking is enabled only if the application is being run inside the debugger, and on shutdown FastMM will report all unexpected memory leaks. (Expected memory leaks can be registered beforehand.) - -"FullDebugMode" is a special mode that radically changes the way in which FastMM works, and is intended as an aid in debugging applications. When the "FullDebugMode" define is set, FastMM places a header and footer around every memory block in order to catch memory overwrite bugs. It also stores a stack trace whenever a block is allocated or freed, and these stack traces are displayed if FastMM detects an error involving the block. When blocks are freed they are filled with a special byte pattern that allows FastMM to detect blocks that were modified after being freed (blocks are checked before being reused, and also on shutdown), and also to detect when a virtual method of a freed object is called. FastMM can also be set to detect the use of an interface of a freed object, but this facility is mutually exclusive to the detection of invalid virtual method calls. When "FullDebugMode" is enabled then the FastMM_FullDebugMode.dll library will be required by the application, otherwise not. - - -FastMM Technical Details: -------------------------- - -FastMM is actually three memory managers in one: small (<2.5K), medium (< 260K) and large (> 260K) blocks are managed separately. - -Requests for large blocks are passed through to the operating system (VirtualAlloc) to be allocated from the top of the address space. (Medium and small blocks are allocated from the bottom of the address space - keeping them separate improves fragmentation behaviour). - -The medium block manager obtains memory from the OS in 1.25MB chunks. These chunks are called "medium block pools" and are subdivided into medium blocks as the application requests them. Unused medium blocks are kept in double-linked lists. There are 1024 such lists, and since the medium block granularity is 256 bytes that means there is a bin for every possible medium block size. FastMM maintains a two-level "bitmap" of these lists, so there is never any need to step through them to find a suitable unused block - a few bitwise operations on the "bitmaps" is all that is required. Whenever a medium block is freed, FastMM checks the neighbouring blocks to determine whether they are unused and can thus be combined with the block that is being freed. (There may never be two neighbouring medium blocks that are both unused.) FastMM has no background "clean-up" thread, so everything must be done as part of the freemem/getmem/reallocmem call. - -In an object oriented programming language like Delphi, most memory allocations and frees are usually for small objects. In practical tests with various Delphi applications it was found that, on average, over 99% of all memory operations involve blocks <2K. It thus makes sense to optimize specifically for these small blocks. Small blocks are allocated from "small block pools". Small block pools are actually medium blocks that are subdivided into equal sized small blocks. Since a particular small block pool contains only equal sized blocks, and adjacent free small blocks are never combined, it allows the small block allocator to be greatly simplified and thus much faster. FastMM maintains a double-linked list of pools with available blocks for every small block size, so finding an available block for the requested size when servicing a getmem request is very speedy. - -Moving data around in memory is typically a very expensive operation. Consequently, FastMM thus an intelligent reallocation algorithm to avoid moving memory as much as possible. When a block is upsized FastMM adjusts the block size in anticipation of future upsizes, thus improving the odds that the next reallocation can be done in place. When a pointer is resized to a smaller size, FastMM requires the new size to be significantly smaller than the old size otherwise the block will not be moved. - -Speed is further improved by an improved locking mechanism: Every small block size, the medium blocks and large blocks are locked individually. If, when servicing a getmem request, the optimal block type is locked by another thread, then FastMM will try up to three larger block sizes. This design drastically reduces the number of thread contentions and improves performance for multi-threaded applications. - - -Important Notes Regarding Delphi 2005: --------------------------------------- - -Presently the latest service pack for Delphi 2005 is SP3, but unfortunately there are still bugs that prevent a replacement borlndmm.dll from working stably with the Delphi 2005 IDE. There is a collection of unofficial patches that need to be installed before you can use the replacement borlndmm.dll with the Delphi 2005 IDE. You can get it from: - -http://cc.borland.com/item.aspx?id=23618 - -Installing these patches together with the replacement borlndmm.dll should provide you with a faster and more stable Delphi 2005 IDE. - diff --git a/components/fastmm/FullDebugMode DLL/FastMM_FullDebugMode.bdsproj b/components/fastmm/FullDebugMode DLL/FastMM_FullDebugMode.bdsproj deleted file mode 100644 index 178bb94..0000000 --- a/components/fastmm/FullDebugMode DLL/FastMM_FullDebugMode.bdsproj +++ /dev/null @@ -1,182 +0,0 @@ - - - - - - - - - - - - FastMM_FullDebugMode.dpr - - - 7.0 - - - 8 - 0 - 1 - 1 - 0 - 0 - 1 - 1 - 1 - 0 - 0 - 1 - 0 - 1 - 1 - 1 - 0 - 0 - 0 - 0 - 0 - 1 - 0 - 1 - 1 - 1 - True - True - WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; - - False - - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - False - False - False - True - True - True - True - True - True - - True - True - True - True - True - True - True - True - - - 3 - 0 - False - 1 - False - False - False - 16384 - 1048576 - 4194304 - - - - - - - - - - - - False - - - - - - False - - - True - False - - - True - False - 1 - 44 - 0 - 4 - False - False - False - False - False - 7177 - 1252 - - - PSD / Pierre le Riche - FastMM FullDebugMode Support DLL - 1.44.0.4 - - (c) Professional Software Development - Licence: MPL 1.1 - FastMM_FullDebugMode.dll - FastMM FullDebugMode Support DLL - 1.42 - - - - $00000000 - - - - diff --git a/components/fastmm/FullDebugMode DLL/FastMM_FullDebugMode.dpr b/components/fastmm/FullDebugMode DLL/FastMM_FullDebugMode.dpr deleted file mode 100644 index 6fe0d3d..0000000 --- a/components/fastmm/FullDebugMode DLL/FastMM_FullDebugMode.dpr +++ /dev/null @@ -1,516 +0,0 @@ -{ - -Fast Memory Manager: FullDebugMode Support DLL 1.42 - -Description: - Support DLL for FastMM. With this DLL available, FastMM will report debug info - (unit name, line numbers, etc.) for stack traces. - -Usage: - 1) To compile you will need the JCL library (http://sourceforge.net/projects/jcl/) - 2) Place in the same location as the replacement borlndmm.dll or your - application's executable module. - -Change log: - Version 1.00 (9 July 2005): - - Initial release. - Version 1.01 (13 July 2005): - - Added the option to use madExcept instead of the JCL Debug library. (Thanks - to Martin Aignesberger.) - Version 1.02 (30 September 2005): - - Changed options to display detail for addresses inside libraries as well. - Version 1.03 (13 October 2005): - - Added a raw stack trace procedure that implements raw stack traces. - Version 1.10 (14 October 2005): - - Improved the program logic behind the skipping of stack levels to cause - less incorrect entries in raw stack traces. (Thanks to Craig Peterson.) - Version 1.20 (17 October 2005): - - Improved support for madExcept stack traces. (Thanks to Mathias Rauen.) - Version 1.30 (26 October 2005): - - Changed name to FastMM_FullDebugMode to reflect the fact that there is now - a static dependency on this DLL for FullDebugMode. The static dependency - solves a DLL unload order issue. (Thanks to Bart van der Werf.) - Version 1.40 (31 October 2005): - - Added support for EurekaLog. (Thanks to Fabio Dell'Aria.) - Version 1.42 (23 June 2006): - - Fixed a bug in the RawStackTraces code that may have caused an A/V in some - rare circumstances. (Thanks to Primoz Gabrijelcic.) - Version 1.44 (16 November 2006): - - Changed the RawStackTraces code to prevent it from modifying the Windows - "GetLastError" error code. (Thanks to Primoz Gabrijelcic.) - -} - -{--------------------Start of options block-------------------------} - -{Select the stack tracing library to use. The JCL, madExcept and EurekaLog are - supported. Only one can be used at a time.} -{$define JCLDebug} -{.$define madExcept} -{.$define EurekaLog} - -{--------------------End of options block-------------------------} - -library FastMM_FullDebugMode; - -uses - {$ifdef JCLDebug}JCLDebug{$endif} - {$ifdef madExcept}madStackTrace{$endif} - {$ifdef EurekaLog}ExceptionLog{$endif}, - SysUtils, Windows; - -{$R *.res} - -{$STACKFRAMES ON} - -{--------------------------Frame Based Stack Tracing--------------------------} - -{Dumps the call stack trace to the given address. Fills the list with the - addresses where the called addresses can be found. This is the fast stack - frame based tracing routine.} -procedure GetFrameBasedStackTrace(AReturnAddresses: PCardinal; AMaxDepth, ASkipFrames: Cardinal); -var - LStackTop, LStackBottom, LCurrentFrame: Cardinal; -begin - {Get the call stack top and current bottom} - asm - mov eax, FS:[4] - sub eax, 3 - mov LStackTop, eax - mov LStackBottom, ebp - end; - {Get the current frame start} - LCurrentFrame := LStackBottom; - {Fill the call stack} - while (AMaxDepth > 0) - and (LCurrentFrame >= LStackBottom) - and (LCurrentFrame < LStackTop) do - begin - {Ignore the requested number of levels} - if ASkipFrames = 0 then - begin - AReturnAddresses^ := PCardinal(LCurrentFrame + 4)^; - Inc(AReturnAddresses); - Dec(AMaxDepth); - end - else - Dec(ASkipFrames); - {Get the next frame} - LCurrentFrame := PCardinal(LCurrentFrame)^; - end; - {Clear the remaining dwords} - while (AMaxDepth > 0) do - begin - AReturnAddresses^ := 0; - Inc(AReturnAddresses); - Dec(AMaxDepth); - end; -end; - -{-----------------------------Raw Stack Tracing-----------------------------} - -const - {Hexadecimal characters} - HexTable: array[0..15] of char = '0123456789ABCDEF'; - -type - {The state of a memory page. Used by the raw stack tracing mechanism to - determine whether an address is a valid call site or not.} - TMemoryPageAccess = (mpaUnknown, mpaNotExecutable, mpaExecutable); - -var - {There are a total of 1M x 4K pages in the 4GB address space} - MemoryPageAccessMap: array[0..1024 * 1024 - 1] of TMemoryPageAccess; - -{Updates the memory page} -procedure UpdateMemoryPageAccessMap(AAddress: Cardinal); -var - LMemInfo: TMemoryBasicInformation; - LAccess: TMemoryPageAccess; - LStartPage, LPageCount: Cardinal; -begin - {Query the page} - if VirtualQuery(Pointer(AAddress), LMemInfo, SizeOf(LMemInfo)) <> 0 then - begin - {Get access type} - if (LMemInfo.State = MEM_COMMIT) - and (LMemInfo.Protect and (PAGE_EXECUTE_READ or PAGE_EXECUTE_READWRITE - or PAGE_EXECUTE_WRITECOPY or PAGE_EXECUTE) <> 0) - and (LMemInfo.Protect and PAGE_GUARD = 0) then - begin - LAccess := mpaExecutable - end - else - LAccess := mpaNotExecutable; - {Update the map} - LStartPage := Cardinal(LMemInfo.BaseAddress) div 4096; - LPageCount := LMemInfo.RegionSize div 4096; - if (LStartPage + LPageCount) < Cardinal(length(MemoryPageAccessMap)) then - FillChar(MemoryPageAccessMap[LStartPage], LPageCount, ord(LAccess)); - end - else - begin - {Invalid address} - MemoryPageAccessMap[AAddress div 4096] := mpaNotExecutable; - end; -end; - -{Returns true if the return address is a valid call site. This function is only - safe to call while exceptions are being handled.} -function IsValidCallSite(AReturnAddress: Cardinal): boolean; -var - LCallAddress, LCode8Back, LCode4Back: Cardinal; -begin - if (AReturnAddress and $ffff0000 <> 0) then - begin - {The call address is up to 8 bytes before the return address} - LCallAddress := AReturnAddress - 8; - {Update the page map} - if MemoryPageAccessMap[LCallAddress div 4096] = mpaUnknown then - UpdateMemoryPageAccessMap(LCallAddress); - {Check the page access} - if (MemoryPageAccessMap[LCallAddress div 4096] = mpaExecutable) - and (MemoryPageAccessMap[(LCallAddress + 8) div 4096] = mpaExecutable) then - begin - {Read the previous 8 bytes} - try - LCode8Back := PCardinal(LCallAddress)^; - LCode4Back := PCardinal(LCallAddress + 4)^; - {Is it a valid "call" instruction?} - Result := - {5-byte, CALL [-$1234567]} - ((LCode8Back and $FF000000) = $E8000000) - {2 byte, CALL EAX} - or ((LCode4Back and $38FF0000) = $10FF0000) - {3 byte, CALL [EBP+0x8]} - or ((LCode4Back and $0038FF00) = $0010FF00) - {4 byte, CALL ??} - or ((LCode4Back and $000038FF) = $000010FF) - {6-byte, CALL ??} - or ((LCode8Back and $38FF0000) = $10FF0000) - {7-byte, CALL [ESP-0x1234567]} - or ((LCode8Back and $0038FF00) = $0010FF00); - except - {The access has changed} - UpdateMemoryPageAccessMap(LCallAddress); - {Not executable} - Result := False; - end; - end - else - Result := False; - end - else - Result := False; -end; - -{Dumps the call stack trace to the given address. Fills the list with the - addresses where the called addresses can be found. This is the "raw" stack - tracing routine.} -procedure GetRawStackTrace(AReturnAddresses: PCardinal; AMaxDepth, ASkipFrames: Cardinal); -var - LStackTop, LStackBottom, LCurrentFrame, LNextFrame, LReturnAddress, - LStackAddress, LLastOSError: Cardinal; -begin - {Are exceptions being handled? Can only do a raw stack trace if the possible - access violations are going to be handled.} - if Assigned(ExceptObjProc) then - begin - {Save the last Windows error code} - LLastOSError := GetLastError; - {Get the call stack top and current bottom} - asm - mov eax, FS:[4] - sub eax, 3 - mov LStackTop, eax - mov LStackBottom, ebp - end; - {Get the current frame start} - LCurrentFrame := LStackBottom; - {Fill the call stack} - while (AMaxDepth > 0) - and (LCurrentFrame < LStackTop) do - begin - {Get the next frame} - LNextFrame := PCardinal(LCurrentFrame)^; - {Is it a valid stack frame address?} - if (LNextFrame < LStackTop) - and (LNextFrame > LCurrentFrame) then - begin - {The pointer to the next stack frame appears valid: Get the return - address of the current frame} - LReturnAddress := PCardinal(LCurrentFrame + 4)^; - {Does this appear to be a valid return address} - if (LReturnAddress and $ffff0000) <> 0 then - begin - {Is the map for this return address incorrect? If may be unknown or marked - as unexecutable because a library was previously not yet loaded, or - perhaps this is not a valid stack frame.} - if MemoryPageAccessMap[(LReturnAddress - 8) div 4096] <> mpaExecutable then - UpdateMemoryPageAccessMap(LReturnAddress - 8); - {Is this return address actually valid?} - if IsValidCallSite(LReturnAddress) then - begin - {Ignore the requested number of levels} - if ASkipFrames = 0 then - begin - AReturnAddresses^ := LReturnAddress; - Inc(AReturnAddresses); - Dec(AMaxDepth); - end; - end - else - begin - {If the return address is invalid it implies this stack frame is - invalid after all.} - LNextFrame := LStackTop; - end; - end - else - begin - {The return address is bad - this is not a valid stack frame} - LNextFrame := LStackTop; - end; - end - else - begin - {This is not a valid stack frame} - LNextFrame := LStackTop; - end; - {Do not check intermediate entries if there are still frames to skip} - if ASkipFrames <> 0 then - begin - Dec(ASkipFrames); - end - else - begin - {Check all stack entries up to the next stack frame} - LStackAddress := LCurrentFrame + 8; - while (AMaxDepth > 0) - and (LStackAddress < LNextFrame) do - begin - {Get the return address} - LReturnAddress := PCardinal(LStackAddress)^; - {Is this a valid call site?} - if IsValidCallSite(LReturnAddress) then - begin - AReturnAddresses^ := LReturnAddress; - Inc(AReturnAddresses); - Dec(AMaxDepth); - end; - {Check the next stack address} - Inc(LStackAddress, 4); - end; - end; - {Do the next stack frame} - LCurrentFrame := LNextFrame; - end; - {Clear the remaining dwords} - while (AMaxDepth > 0) do - begin - AReturnAddresses^ := 0; - Inc(AReturnAddresses); - Dec(AMaxDepth); - end; - {Restore the last Windows error code, since a VirtualQuery call may have - modified it.} - SetLastError(LLastOSError); - end - else - begin - {Exception handling is not available - do a frame based stack trace} - GetFrameBasedStackTrace(AReturnAddresses, AMaxDepth, ASkipFrames); - end; -end; - -{-----------------------------Stack Trace Logging----------------------------} - -{Gets the textual representation of the stack trace into ABuffer and returns - a pointer to the position just after the last character.} -{$ifdef JCLDebug} -{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; - -function LogStackTrace(AReturnAddresses: PCardinal; - AMaxDepth: Cardinal; ABuffer: PChar): PChar; -var - LInd, LAddress: Cardinal; - LNumChars: Integer; - LInfo: TJCLLocationInfo; - LTempStr: string; -begin - Result := ABuffer; - for LInd := 0 to AMaxDepth - 1 do - begin - LAddress := AReturnAddresses^; - if LAddress = 0 then - exit; - Result^ := #13; - Inc(Result); - Result^ := #10; - Inc(Result); - Result := CardinalToHexBuf(LAddress, Result); - {Get location info for the caller (at least one byte before the return - address).} - GetLocationInfo(Pointer(Cardinal(LAddress) - 1), LInfo); - {Build the result string} - LTempStr := ' '; - if LInfo.SourceName <> '' then - LTempStr := LTempStr + '[' + LInfo.SourceName + ']'; - if LInfo.UnitName <> '' then - LTempStr := LTempStr + '[' + LInfo.UnitName + ']'; - if LInfo.ProcedureName <> '' then - LTempStr := LTempStr + '[' + LInfo.ProcedureName + ']'; - if LInfo.LineNumber <> 0 then - LTempStr := LTempStr + '[' + IntToStr(LInfo.LineNumber) + ']'; - {Return the result} - if length(LTempStr) < 256 then - LNumChars := length(LTempStr) - else - LNumChars := 255; - StrLCopy(Result, PChar(LTempStr), LNumChars); - Inc(Result, LNumChars); - {Next address} - Inc(AReturnAddresses); - end; -end; -{$endif} - -{$ifdef madExcept} -function LogStackTrace(AReturnAddresses: PCardinal; - AMaxDepth: Cardinal; ABuffer: PChar): PChar; -begin - {Needs madExcept 2.7i or madExcept 3.0a or a newer build} - Result := madStackTrace.FastMM_LogStackTrace( - AReturnAddresses, - AMaxDepth, - ABuffer, - {madExcept stack trace fine tuning} - false, //hide items which have no line number information? - true, //show relative address offset to procedure entrypoint? - true, //show relative line number offset to procedure entry point? - false //skip special noise reduction processing? - ); -end; -{$endif} - -{$ifdef EurekaLog} -function LogStackTrace(AReturnAddresses: PCardinal; AMaxDepth: Cardinal; ABuffer: PChar): PChar; -begin - {Needs EurekaLog 5.0.5 or a newer build} - Result := ExceptionLog.FastMM_LogStackTrace( - AReturnAddresses, AMaxDepth, ABuffer, - {EurekaLog stack trace fine tuning} - False, // Show the DLLs functions call. <--| - // |-- See the note below! - False, // Show the BPLs functions call. <--| - True // Show relative line no. offset to procedure start point. - ); -// NOTE: -// ----- -// With these values set both to "False", EurekaLog try to returns the best -// call-stack available. -// -// To do this EurekaLog execute the following points: -// -------------------------------------------------- -// 1)...try to fill all call-stack items using only debug data with line no. -// 2)...if remains some empty call-stack items from the previous process (1), -// EurekaLog try to fill these with the BPLs functions calls; -// 3)...if remains some empty call-stack items from the previous process (2), -// EurekaLog try to fill these with the DLLs functions calls; -end; -{$endif} - -{-----------------------------Exported Functions----------------------------} - -exports - GetFrameBasedStackTrace, - GetRawStackTrace, - LogStackTrace; - -begin -{$ifdef JCLDebug} - JclStackTrackingOptions := JclStackTrackingOptions + [stAllModules]; -{$endif} -end. diff --git a/components/fastmm/FullDebugMode DLL/FastMM_FullDebugMode.res b/components/fastmm/FullDebugMode DLL/FastMM_FullDebugMode.res deleted file mode 100644 index 84fd520..0000000 Binary files a/components/fastmm/FullDebugMode DLL/FastMM_FullDebugMode.res and /dev/null differ diff --git a/components/fastmm/FullDebugMode DLL/Precompiled/FastMM_FullDebugMode.dll b/components/fastmm/FullDebugMode DLL/Precompiled/FastMM_FullDebugMode.dll deleted file mode 100644 index 7f42270..0000000 Binary files a/components/fastmm/FullDebugMode DLL/Precompiled/FastMM_FullDebugMode.dll and /dev/null differ diff --git a/components/fastmm/Replacement BorlndMM DLL/BorlndMM.bdsproj b/components/fastmm/Replacement BorlndMM DLL/BorlndMM.bdsproj deleted file mode 100644 index ecfca4d..0000000 --- a/components/fastmm/Replacement BorlndMM DLL/BorlndMM.bdsproj +++ /dev/null @@ -1,174 +0,0 @@ - - - - - - - - - - - - BorlndMM.dpr - - - 7.0 - - - 8 - 0 - 1 - 1 - 0 - 0 - 1 - 1 - 1 - 0 - 0 - 1 - 0 - 1 - 1 - 1 - 0 - 0 - 0 - 0 - 0 - 1 - 0 - 1 - 1 - 1 - True - True - WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; - - False - - True - True - False - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - False - False - False - True - True - True - True - True - True - - - - 3 - 0 - False - 1 - False - False - False - 16384 - 1048576 - 13762560 - - - - - - - - - - borlndmmdll;debugdll;dllforide - - False - - - - - - False - - - True - False - - - - $00000000 - - - - True - True - 4 - 76 - 0 - 179 - False - False - False - False - False - 7177 - 1252 - - - Pierre le Riche / Professional Software Development - Replacement Memory Manager for Delphi IDE and Applications - 4.76.0.179 - Fast Memory Manager - License: MPL 1.1 - - BorlndMM.DLL - FastMM - 4 - - - diff --git a/components/fastmm/Replacement BorlndMM DLL/BorlndMM.cfg b/components/fastmm/Replacement BorlndMM DLL/BorlndMM.cfg deleted file mode 100644 index 6db1c32..0000000 --- a/components/fastmm/Replacement BorlndMM DLL/BorlndMM.cfg +++ /dev/null @@ -1,41 +0,0 @@ --$A8 --$B- --$C+ --$D+ --$E- --$F- --$G+ --$H+ --$I+ --$J- --$K- --$L+ --$M- --$N+ --$O+ --$P+ --$Q- --$R- --$S- --$T- --$U- --$V+ --$W- --$X+ --$YD --$Z1 --GD --cg --AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; --H+ --W+ --M --$M16384,1048576 --K$00D20000 --LE"C:\Documents and Settings\Administrator\My Documents\Borland Studio Projects\Bpl" --LN"C:\Documents and Settings\Administrator\My Documents\Borland Studio Projects\Bpl" --Dborlndmmdll;debugdll;dllforide --w-SYMBOL_PLATFORM --w-UNSAFE_TYPE --w-UNSAFE_CODE --w-UNSAFE_CAST diff --git a/components/fastmm/Replacement BorlndMM DLL/BorlndMM.dpr b/components/fastmm/Replacement BorlndMM DLL/BorlndMM.dpr deleted file mode 100644 index 572486b..0000000 --- a/components/fastmm/Replacement BorlndMM DLL/BorlndMM.dpr +++ /dev/null @@ -1,180 +0,0 @@ -{ - -Fast Memory Manager: Replacement BorlndMM.DLL 1.05 - -Description: - A replacement borlndmm.dll using FastMM instead of the RTL MM. This DLL may be - used instead of the default DLL together with your own applications or the - Delphi IDE, making the benefits of FastMM available to them. - -Usage: - 1) Make sure the "NeverUninstall" conditional define is set in FastMM4.pas if - you intend to use the DLL with the Delphi IDE, otherwise it must be off. - 2) Compile this DLL - 3) Ship it with your existing applications that currently uses the borlndmm.dll - file that ships with Delphi for an improvement in speed. - 4) Copy it over the current borlndmm.dll in the Delphi \Bin\ directory (after - renaming the old one) to speed up the IDE.* - -Acknowledgements: - - Arthur Hoornweg for notifying me of the image base being incorrect for - borlndmm.dll. - - Cord Schneider for notifying me of the compilation error under Delphi 5. - -Change log: - Version 1.00 (28 June 2005): - - Initial release. - Version 1.01 (30 June 2005): - - Added an unofficial patch for QC#14007 that prevented a replacement - borlndmm.dll from working together with Delphi 2005. - - Added the "NeverUninstall" option in FastMM4.pas to circumvent QC#14070, - which causes an A/V on shutdown of Delphi if FastMM uninstalls itself in the - finalization code of FastMM4.pas. - Version 1.02 (19 July 2005): - - Set the imagebase to $00D20000 to avoid relocation on load (and thus allow - sharing of the DLL between processes). (Thanks to Arthur Hoornweg.) - Version 1.03 (10 November 2005): - - Added exports for AllocMem and leak (un)registration - Version 1.04 (22 December 2005): - - Fixed the compilation error under Delphi 5. (Thanks to Cord Schneider.) - Version 1.05 (23 February 2006): - - Added some exports to allow access to the extended FullDebugMode - functionality in FastMM. - -*For this replacement borlndmm.dll to work together with Delphi 2005, you will - need to apply the unofficial patch for QC#14007. To compile a replacement - borlndmm.dll for use with the Delphi IDE the "NeverUninstall" option must be - set (to circumvent QC#14070). For other uses the "NeverUninstall" option - should be disabled. For a list of unofficial patches for Delphi 2005 (and - where to get them), refer to the FastMM4_Readme.txt file. - -} - -{--------------------Start of options block-------------------------} - -{Set the following option to use the RTL MM instead of FastMM. Setting this - option makes this replacement DLL almost identical to the default - borlndmm.dll, unless the "FullDebugMode" option is also set.} -{.$define UseRTLMM} - -{--------------------End of options block-------------------------} - -{$Include FastMM4Options.inc} - -{Cannot use the RTL MM with full debug mode} -{$ifdef FullDebugMode} - {$undef UseRTLMM} -{$endif} - -{Set the correct image base} -{$IMAGEBASE $00D20000} - -library BorlndMM; - -{$ifndef UseRTLMM} -uses - FastMM4; -{$endif} - -{$R *.RES} - -function GetAllocMemCount: integer; -begin - {Return stats for the RTL MM only} -{$ifdef UseRTLMM} - Result := System.AllocMemCount; -{$else} - Result := 0; -{$endif} -end; - -function GetAllocMemSize: integer; -begin - {Return stats for the RTL MM only} -{$ifdef UseRTLMM} - Result := System.AllocMemSize; -{$else} - Result := 0; -{$endif} -end; - -procedure DumpBlocks; -begin - {Do nothing} -end; - -function HeapRelease: Integer; -begin - {Do nothing} - Result := 2; -end; - -function HeapAddRef: Integer; -begin - {Do nothing} - Result := 2; -end; - -function DummyRegisterAndUnregisterExpectedMemoryLeak(ALeakedPointer: Pointer): boolean; -begin - Result := False; -end; - -exports - GetAllocMemSize name 'GetAllocMemSize', - GetAllocMemCount name 'GetAllocMemCount', -{$ifndef UseRTLMM} - FastGetHeapStatus name 'GetHeapStatus', -{$else} - System.GetHeapStatus name 'GetHeapStatus', -{$endif} - DumpBlocks name 'DumpBlocks', - System.ReallocMemory name 'ReallocMemory', - System.FreeMemory name 'FreeMemory', - System.GetMemory name 'GetMemory', -{$ifndef UseRTLMM} - {$ifndef FullDebugMode} - FastReallocMem name '@Borlndmm@SysReallocMem$qqrpvi', - FastFreeMem name '@Borlndmm@SysFreeMem$qqrpv', - FastGetMem name '@Borlndmm@SysGetMem$qqri', - FastAllocMem name '@Borlndmm@SysAllocMem$qqri', - {$else} - DebugReallocMem name '@Borlndmm@SysReallocMem$qqrpvi', - DebugFreeMem name '@Borlndmm@SysFreeMem$qqrpv', - DebugGetMem name '@Borlndmm@SysGetMem$qqri', - DebugAllocMem name '@Borlndmm@SysAllocMem$qqri', - {$endif} - {$ifdef EnableMemoryLeakReporting} - RegisterExpectedMemoryLeak(ALeakedPointer: Pointer) name '@Borlndmm@SysRegisterExpectedMemoryLeak$qqrpi', - UnregisterExpectedMemoryLeak(ALeakedPointer: Pointer) name '@Borlndmm@SysUnregisterExpectedMemoryLeak$qqrpi', - {$else} - DummyRegisterAndUnregisterExpectedMemoryLeak name '@Borlndmm@SysRegisterExpectedMemoryLeak$qqrpi', - DummyRegisterAndUnregisterExpectedMemoryLeak name '@Borlndmm@SysUnregisterExpectedMemoryLeak$qqrpi', - {$endif} -{$else} - System.SysReallocMem name '@Borlndmm@SysReallocMem$qqrpvi', - System.SysFreeMem name '@Borlndmm@SysFreeMem$qqrpv', - System.SysGetMem name '@Borlndmm@SysGetMem$qqri', - {$ifdef VER180}; - System.SysAllocMem name '@Borlndmm@SysAllocMem$qqri', - System.SysRegisterExpectedMemoryLeak name '@Borlndmm@SysRegisterExpectedMemoryLeak$qqrpi', - System.SysUnregisterExpectedMemoryLeak name '@Borlndmm@SysUnregisterExpectedMemoryLeak$qqrpi', - {$else} - System.AllocMem name '@Borlndmm@SysAllocMem$qqri', - DummyRegisterAndUnregisterExpectedMemoryLeak name '@Borlndmm@SysRegisterExpectedMemoryLeak$qqrpi', - DummyRegisterAndUnregisterExpectedMemoryLeak name '@Borlndmm@SysUnregisterExpectedMemoryLeak$qqrpi', - {$endif} -{$endif} - {$ifdef FullDebugMode} - SetMMLogFileName, - GetCurrentAllocationGroup, - PushAllocationGroup, - PopAllocationGroup, - LogAllocatedBlocksToFile, - {$endif} - HeapRelease name '@Borlndmm@HeapRelease$qqrv', - HeapAddRef name '@Borlndmm@HeapAddRef$qqrv'; - -begin - IsMultiThread := True; -end. diff --git a/components/fastmm/Replacement BorlndMM DLL/BorlndMM.res b/components/fastmm/Replacement BorlndMM DLL/BorlndMM.res deleted file mode 100644 index 9477f4a..0000000 Binary files a/components/fastmm/Replacement BorlndMM DLL/BorlndMM.res and /dev/null differ diff --git a/components/fastmm/Replacement BorlndMM DLL/FastMMDebugSupport.pas b/components/fastmm/Replacement BorlndMM DLL/FastMMDebugSupport.pas deleted file mode 100644 index f09a80e..0000000 --- a/components/fastmm/Replacement BorlndMM DLL/FastMMDebugSupport.pas +++ /dev/null @@ -1,50 +0,0 @@ -{ - -Fast Memory Manager: FullDebugMode Borlndmm.dll support unit - -If you use the replacement Borlndmm.dll compiled in FullDebugMode, and you need - access to some of the extended functionality that is not imported by - sharemem.pas, then you may use this unit to get access to it. Please note that - you will still need to add sharemem.pas as the first unit in the "uses" - section of the .dpr, and the FastMM_FullDebugMode.dll must be available on the - path. Also, the borlndmm.dll that you will be using *must* be compiled using - FullDebugMode.} - -unit FastMMDebugSupport; - -interface - -{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); - -implementation - -const - borlndmm = 'borlndmm.dll'; - -procedure SetMMLogFileName; external borlndmm; -function GetCurrentAllocationGroup; external borlndmm; -procedure PushAllocationGroup; external borlndmm; -procedure PopAllocationGroup; external borlndmm; -procedure LogAllocatedBlocksToFile; external borlndmm; - -end. diff --git a/components/fastmm/Replacement BorlndMM DLL/Precompiled/for Applications/Debug/BorlndMM.dll b/components/fastmm/Replacement BorlndMM DLL/Precompiled/for Applications/Debug/BorlndMM.dll deleted file mode 100644 index 3bb233a..0000000 Binary files a/components/fastmm/Replacement BorlndMM DLL/Precompiled/for Applications/Debug/BorlndMM.dll and /dev/null differ diff --git a/components/fastmm/Replacement BorlndMM DLL/Precompiled/for Applications/Performance/BorlndMM.dll b/components/fastmm/Replacement BorlndMM DLL/Precompiled/for Applications/Performance/BorlndMM.dll deleted file mode 100644 index c7127e6..0000000 Binary files a/components/fastmm/Replacement BorlndMM DLL/Precompiled/for Applications/Performance/BorlndMM.dll and /dev/null differ diff --git a/components/fastmm/Replacement BorlndMM DLL/Precompiled/for Delphi IDE/Debug/BorlndMM.dll b/components/fastmm/Replacement BorlndMM DLL/Precompiled/for Delphi IDE/Debug/BorlndMM.dll deleted file mode 100644 index ae14530..0000000 Binary files a/components/fastmm/Replacement BorlndMM DLL/Precompiled/for Delphi IDE/Debug/BorlndMM.dll and /dev/null differ diff --git a/components/fastmm/Replacement BorlndMM DLL/Precompiled/for Delphi IDE/Performance/BorlndMM.dll b/components/fastmm/Replacement BorlndMM DLL/Precompiled/for Delphi IDE/Performance/BorlndMM.dll deleted file mode 100644 index b91eea2..0000000 Binary files a/components/fastmm/Replacement BorlndMM DLL/Precompiled/for Delphi IDE/Performance/BorlndMM.dll and /dev/null differ diff --git a/components/fastmm/Translations/Afrikaans/FastMM4Messages.pas b/components/fastmm/Translations/Afrikaans/FastMM4Messages.pas deleted file mode 100644 index 279275e..0000000 --- a/components/fastmm/Translations/Afrikaans/FastMM4Messages.pas +++ /dev/null @@ -1,138 +0,0 @@ -{ - -Fast Memory Manager: Messages - -Afrikaans translation by Pierre le Riche. - -} - -unit FastMM4Messages; - -interface - -{$Include FastMM4Options.inc} - -const - {The name of the debug info support DLL} - FullDebugModeLibraryName = 'FastMM_FullDebugMode.dll'; - {Event log strings} - LogFileExtension = '_MemoryManager_EventLog.txt'#0; - CRLF = #13#10; - EventSeparator = '--------------------------------'; - {Class name messages} - UnknownClassNameMsg = 'Onbekend'; - {Stack trace Message} - CurrentStackTraceMsg = #13#10#13#10'Die huidige stapel spoor wat aanleiding gegee het tot hierdie fout (terugkeer adresse): '; - {Memory dump message} - MemoryDumpMsg = #13#10#13#10'Huidige geheue inhoud: 256 grepe vanaf adres '; - {Block Error Messages} - BlockScanLogHeader = 'Geallokeerde blok gelys deur LogAllocatedBlocksToFile. The grootte is: '; - ErrorMsgHeader = 'FastMM het ''n fout teegekom in die uitvoer van ''n '; - GetMemMsg = 'GetMem'; - FreeMemMsg = 'FreeMem'; - ReallocMemMsg = 'ReallocMem'; - BlockCheckMsg = 'ongebruikte blok toets'; - OperationMsg = ' proses. '; - BlockHeaderCorruptedMsg = 'Die merker voor die blok is beskadig. '; - BlockFooterCorruptedMsg = 'Die merker na die blok is beskadig. '; - FreeModifiedErrorMsg = 'FastMM het gevind dat ''n blok verander is sedert dit vrygestel is. '; - DoubleFreeErrorMsg = '''n Poging is aangewend om ongebruikte ''blok vry te stel of te herallokeer.'; - PreviousBlockSizeMsg = #13#10#13#10'Die vorige blok grootte was: '; - CurrentBlockSizeMsg = #13#10#13#10'Die blok grootte is: '; - StackTraceAtPrevAllocMsg = #13#10#13#10'Stapel spoor van toe die blok voorheen geallokeer is (terugkeer adresse):'; - StackTraceAtAllocMsg = #13#10#13#10'Stapel spoor van toe die blok geallokeer is (terugkeer adresse):'; - PreviousObjectClassMsg = #13#10#13#10'Die blok is voorheen gebruik vir ''n objek van die klas: '; - CurrentObjectClassMsg = #13#10#13#10'Die blok word huidiglik gebruik vir ''n objek van die klas: '; - PreviousAllocationGroupMsg = #13#10#13#10'Die allokasie groep was: '; - PreviousAllocationNumberMsg = #13#10#13#10'Die allokasie nommer was: '; - CurrentAllocationGroupMsg = #13#10#13#10'Die allokasie groep is: '; - CurrentAllocationNumberMsg = #13#10#13#10'Die allokasie nommer is: '; - StackTraceAtFreeMsg = #13#10#13#10'Stapel spoor van toe die blok voorheen vrygestel is (terugkeer adresse):'; - BlockErrorMsgTitle = 'Geheue Fout'; - {Virtual Method Called On Freed Object Errors} - StandardVirtualMethodNames: array[1 + vmtParent div 4 .. -1] of PChar = ( - 'SafeCallException', - 'AfterConstruction', - 'BeforeDestruction', - 'Dispatch', - 'DefaultHandler', - 'NewInstance', - 'FreeInstance', - 'Destroy'); - VirtualMethodErrorHeader = 'FastMM het ''n poging onderskep om ''n virtuele funksie of prosedure van ''n vrygestelde objek te roep. ''n Toegangsfout sal nou veroorsaak word om die proses te onderbreek.'; - InterfaceErrorHeader = 'FastMM het ''n poging onderskep om ''n koppelvlak van ''n vrygestelde objek te gebruik. ''n Toegangsfout sal nou veroorsaak word om die proses te onderbreek.'; - BlockHeaderCorruptedNoHistoryMsg = ' Ongelukkig is die merker voor die blok beskadig en dus is geen blok geskiedenis beskikbaar nie.'; - FreedObjectClassMsg = #13#10#13#10'Vrygestelde objek klas: '; - VirtualMethodName = #13#10#13#10'Virtuele funksie/prosedure: '; - VirtualMethodOffset = 'VMT Adres +'; - VirtualMethodAddress = #13#10#13#10'Virtuele funksie/prosedure address: '; - StackTraceAtObjectAllocMsg = #13#10#13#10'Stapel spoor van toe die blok geallokeer is (terugkeer adresse):'; - StackTraceAtObjectFreeMsg = #13#10#13#10'Stapel spoor van toe die blok vrygestel is (terugkeer adresse):'; - {Installation Messages} - AlreadyInstalledMsg = 'FastMM4 is alreeds genstalleer.'; - AlreadyInstalledTitle = 'Alreeds genstalleer.'; - OtherMMInstalledMsg = 'FastMM4 kan nie genstalleer word nie, want ''n ander ' - + 'derde party geheuebestuurder is alreeds genstalleer.'#13#10'Indien jy FastMM4 wil gebruik, ' - + 'verseker asb. dat FastMM4.pas die eerste ler is in die "uses"' - + #13#10'afdeling van jou projek se .dpr ler.'; - OtherMMInstalledTitle = 'FastMM4 kan nie genstalleer word nie - ''n ander geheue bestuurder is alreeds genstalleer'; - MemoryAllocatedMsg = 'FastMM4 kan nie genstalleer word nie aangesien geheue reeds ' - + 'geallokeer is deur die verstek geheue bestuurder.'#13#10'FastMM4.pas MOET ' - + 'die eerste ler wees in jou projek se .dpr ler, andersins mag geheie geallokeer word' - + ''#13#10'deur die verstek geheue bestuurder voordat FastMM4 ' - + 'beheer verkry. '#13#10#13#10'As jy ''n foutvanger soos MadExcept gebruik ' - + '(of enigiets wat die peuter met die inisialiseringsvolgorder van eenhede),' - + #13#10' gaan in sy opstelling bladsy in en verseker dat FastMM4.pas eerste genisialiseer word.'; - MemoryAllocatedTitle = 'FastMM4 kan nie genstalleer word nie - geheue is alreeds geallokeer'; - {Leak checking messages} - LeakLogHeader = '''n Geheue blok het gelek. Die grootte is: '; - LeakMessageHeader = 'Hierdie program het geheue gelek. '; - SmallLeakDetail = 'Die klein blok lekkasies is' -{$ifdef HideExpectedLeaksRegisteredByPointer} - + ' (verwagte lekkasies geregistreer deur wyser is uitgesluit)' -{$endif} - + ':'#13#10; - LargeLeakDetail = 'Die groottes van medium en groot blok lekkasies is' -{$ifdef HideExpectedLeaksRegisteredByPointer} - + ' (verwagte lekkasies geregistreer deur wyser is uitgesluit)' -{$endif} - + ': '; - BytesMessage = ' grepe: '; - StringBlockMessage = 'String'; - LeakMessageFooter = #13#10 -{$ifndef HideMemoryLeakHintMessage} - + #13#10'Nota: ' - {$ifdef RequireIDEPresenceForLeakReporting} - + 'Die geheie lekkasie toets word slegs gedoen indien Delphi op daardie tydstip op die masjien loop. ' - {$endif} - {$ifdef FullDebugMode} - {$ifdef LogMemoryLeakDetailToFile} - + 'Lekkasie detail word gelog na ''n teks ler in dieselfde gids as hierdie program. ' - {$else} - + 'Sit "LogMemoryLeakDetailToFile" aan om ''n gedetailleerde verslag oor al die geheue lekkasies na teksler te skryf. ' - {$endif} - {$else} - + 'Sit die "FullDebugMode" en "LogMemoryLeakDetailToFile" opsies aan om ''n gedetailleerde verslag oor al die geheue lekkasies na teksler te skryf. ' - {$endif} - + 'Om die lekkasie toets te deaktiveer, sit die "EnableMemoryLeakReporting" opsie af.'#13#10 -{$endif} - + #0; - LeakMessageTitle = 'Geheue Lekkasie'; -{$ifdef UseOutputDebugString} - FastMMInstallMsg = 'FastMM has been installed.'; - FastMMInstallSharedMsg = 'Sharing an existing instance of FastMM.'; - FastMMUninstallMsg = 'FastMM has been uninstalled.'; - FastMMUninstallSharedMsg = 'Stopped sharing an existing instance of FastMM.'; -{$endif} -{$ifdef DetectMMOperationsAfterUninstall} - InvalidOperationTitle = 'MM Operation after uninstall.'; - InvalidGetMemMsg = 'FastMM has detected a GetMem call after FastMM was uninstalled.'; - InvalidFreeMemMsg = 'FastMM has detected a FreeMem call after FastMM was uninstalled.'; - InvalidReallocMemMsg = 'FastMM has detected a ReallocMem call after FastMM was uninstalled.'; - InvalidAllocMemMsg = 'FastMM has detected an AllocMem call after FastMM was uninstalled.'; -{$endif} - -implementation - -end. - diff --git a/components/fastmm/Translations/Belarussian/FastMM4Messages.pas b/components/fastmm/Translations/Belarussian/FastMM4Messages.pas deleted file mode 100644 index ab83560..0000000 --- a/components/fastmm/Translations/Belarussian/FastMM4Messages.pas +++ /dev/null @@ -1,140 +0,0 @@ -{ - -Fast Memory Manager: Messages - -belarussian translation by dzmitry[li] -mailto:dzmitry@biz.by - ˳ - - -} - -unit FastMM4Messages; - -interface - -{$Include FastMM4Options.inc} - -const - {The name of the debug info support DLL} - FullDebugModeLibraryName = 'FastMM_FullDebugMode.dll'; - {Event log strings} - LogFileExtension = '_MemoryManager_EventLog.txt'#0; - CRLF = #13#10; - EventSeparator = '--------------------------------'; - {Class name messages} - UnknownClassNameMsg = 'Unknown'; - {Stack trace Message} - CurrentStackTraceMsg = #13#10#13#10' (): '; - {Memory dump message} - MemoryDumpMsg = #13#10#13#10' 256 '; - {Block Error Messages} - BlockScanLogHeader = 'Allocated block logged by LogAllocatedBlocksToFile. The size is: '; - ErrorMsgHeader = 'FastMM Ⳣ '; - GetMemMsg = 'GetMem'; - FreeMemMsg = 'FreeMem'; - ReallocMemMsg = 'ReallocMem'; - BlockCheckMsg = ' '; - OperationMsg = ' . '; - BlockHeaderCorruptedMsg = ' . '; - BlockFooterCorruptedMsg = 'ͳ . '; - FreeModifiedErrorMsg = 'FastMM Ⳣ . '; - DoubleFreeErrorMsg = ' / .'; - PreviousBlockSizeMsg = #13#10#13#10' : '; - CurrentBlockSizeMsg = #13#10#13#10' : '; - StackTraceAtPrevAllocMsg = #13#10#13#10' ():'; - StackTraceAtAllocMsg = #13#10#13#10' ():'; - PreviousObjectClassMsg = #13#10#13#10' '' : '; - CurrentObjectClassMsg = #13#10#13#10' '' : '; - PreviousAllocationGroupMsg = #13#10#13#10'The allocation group was: '; - PreviousAllocationNumberMsg = #13#10#13#10'The allocation number was: '; - CurrentAllocationGroupMsg = #13#10#13#10'The allocation group is: '; - CurrentAllocationNumberMsg = #13#10#13#10'The allocation number is: '; - StackTraceAtFreeMsg = #13#10#13#10' ():'; - BlockErrorMsgTitle = ' .'; - {Virtual Method Called On Freed Object Errors} - StandardVirtualMethodNames: array[1 + vmtParent div 4 .. -1] of PChar = ( - 'SafeCallException', - 'AfterConstruction', - 'BeforeDestruction', - 'Dispatch', - 'DefaultHandler', - 'NewInstance', - 'FreeInstance', - 'Destroy'); - VirtualMethodErrorHeader = 'FastMM Ⳣ ''. .'; - InterfaceErrorHeader = 'FastMM Ⳣ ''. .'; - BlockHeaderCorruptedNoHistoryMsg = ' .'; - FreedObjectClassMsg = #13#10#13#10' '': '; - VirtualMethodName = #13#10#13#10'³ : '; - VirtualMethodOffset = ' +'; - VirtualMethodAddress = #13#10#13#10' : '; - StackTraceAtObjectAllocMsg = #13#10#13#10' '' ():'; - StackTraceAtObjectFreeMsg = #13#10#13#10' '' ():'; - {Installation Messages} - AlreadyInstalledMsg = 'FastMM4 .'; - AlreadyInstalledTitle = ' .'; - OtherMMInstalledMsg = 'FastMM4 .' - + #13#10' FastMM4, FastMM4.pas '' ' - + #13#10' "uses" ''s .dpr .'; - OtherMMInstalledTitle = ' FastMM4 - .'; - MemoryAllocatedMsg = 'FastMM4 ' - + ' .'#13#10'FastMM4.pas ² ' - + ' ''s .dpr , ' - + ' '#13#10' FastMM4 ' - + ' . '#13#10#13#10' ' - + ' MadExcept ( , ' - + '),'#13#10' , ' - + 'FastMM4.pas .'; - MemoryAllocatedTitle = ' FastMM4 - '; - {Leak checking messages} - LeakLogHeader = ' . : '; - LeakMessageHeader = ' . '; - SmallLeakDetail = ' ' -{$ifdef HideExpectedLeaksRegisteredByPointer} - + ' ( )' -{$endif} - + ':'#13#10; - LargeLeakDetail = ' ' -{$ifdef HideExpectedLeaksRegisteredByPointer} - + ' ( )' -{$endif} - + ': '; - BytesMessage = ' : '; - StringBlockMessage = 'String'; - LeakMessageFooter = #13#10 -{$ifndef HideMemoryLeakHintMessage} - + #13#10'Note: ' - {$ifdef RequireIDEPresenceForLeakReporting} - + ' Delphi . ' - {$endif} - {$ifdef FullDebugMode} - {$ifdef LogMemoryLeakDetailToFile} - + ' , . ' - {$else} - + ' "LogMemoryLeakDetailToFile" , . ' - {$endif} - {$else} - + ' , , "FullDebugMode" "LogMemoryLeakDetailToFile". ' - {$endif} - + ' , "EnableMemoryLeakReporting".'#13#10 -{$endif} - + #0; - LeakMessageTitle = ' '; -{$ifdef UseOutputDebugString} - FastMMInstallMsg = 'FastMM .'; - FastMMInstallSharedMsg = 'Sharing an existing instance of FastMM.'; - FastMMUninstallMsg = 'FastMM .'; - FastMMUninstallSharedMsg = 'Stopped sharing an existing instance of FastMM.'; -{$endif} -{$ifdef DetectMMOperationsAfterUninstall} - InvalidOperationTitle = 'MM .'; - InvalidGetMemMsg = 'FastMM , GetMem FastMM .'; - InvalidFreeMemMsg = 'FastMM , FreeMem FastMM .'; - InvalidReallocMemMsg = 'FastMM , ReallocMem FastMM .'; - InvalidAllocMemMsg = 'FastMM , ReallocMem FastMM .'; -{$endif} - -implementation - -end. diff --git a/components/fastmm/Translations/Chinese (Simplified)/FastMM4Messages.pas b/components/fastmm/Translations/Chinese (Simplified)/FastMM4Messages.pas deleted file mode 100644 index f90b973..0000000 --- a/components/fastmm/Translations/Chinese (Simplified)/FastMM4Messages.pas +++ /dev/null @@ -1,135 +0,0 @@ -{ - -Fast Memory Manager: Messages - -Simplified Chinese translation by JiYuan Xie. - -} - -unit FastMM4Messages; - -interface - -{$Include FastMM4Options.inc} - -const - {The name of the debug info support DLL} - FullDebugModeLibraryName = 'FastMM_FullDebugMode.dll'; - {Event log strings} - LogFileExtension = '_MemoryManager_EventLog.txt'#0; - CRLF = #13#10; - EventSeparator = '--------------------------------'; - {Class name messages} - UnknownClassNameMsg = 'δ֪'; - {Stack trace Message} - CurrentStackTraceMsg = #13#10#13#10'¸ôĵǰջ(÷صַ): '; - {Memory dump message} - MemoryDumpMsg = #13#10#13#10'ַָָʼ, 256ֽڵڴ浱ǰ '; - {Block Error Messages} - BlockScanLogHeader = ' LogAllocatedBlocksToFile ¼ѷڴ. С: '; - ErrorMsgHeader = 'FastMM Ѽ⵽һ, ʱڽ '; - GetMemMsg = 'GetMem'; - FreeMemMsg = 'FreeMem'; - ReallocMemMsg = 'ReallocMem'; - BlockCheckMsg = 'ɨڴ'; - OperationMsg = ' . '; - BlockHeaderCorruptedMsg = 'ڴͷѱƻ. '; - BlockFooterCorruptedMsg = 'ڴβѱƻ. '; - FreeModifiedErrorMsg = 'FastMM ⵽ͷڴݵ޸. '; - DoubleFreeErrorMsg = 'ͼͷ/·һδڴ.'; - PreviousBlockSizeMsg = #13#10#13#10'ϴʹʱڴС: '; - CurrentBlockSizeMsg = #13#10#13#10'ڴĴС: '; - StackTraceAtPrevAllocMsg = #13#10#13#10'ڴϴαʱĶջ(÷صַ):'; - StackTraceAtAllocMsg = #13#10#13#10'ڴ鱾αʱĶջ(÷صַ):'; - PreviousObjectClassMsg = #13#10#13#10'ڴϴαһĶ: '; - CurrentObjectClassMsg = #13#10#13#10'ڴ鵱ǰһĶ: '; - PreviousAllocationGroupMsg = #13#10#13#10': '; - PreviousAllocationNumberMsg = #13#10#13#10': '; - CurrentAllocationGroupMsg = #13#10#13#10': '; - CurrentAllocationNumberMsg = #13#10#13#10': '; - StackTraceAtFreeMsg = #13#10#13#10'ڴϴαͷʱĶջ(÷صַ):'; - BlockErrorMsgTitle = '⵽ڴ'; - {Virtual Method Called On Freed Object Errors} - StandardVirtualMethodNames: array[1 + vmtParent div 4 .. -1] of PChar = ( - 'SafeCallException', - 'AfterConstruction', - 'BeforeDestruction', - 'Dispatch', - 'DefaultHandler', - 'NewInstance', - 'FreeInstance', - 'Destroy'); - VirtualMethodErrorHeader = 'FastMM ⵽ͷŶ鷽ĵ. һʳͻ쳣ڽֹǰIJ.'; - InterfaceErrorHeader = 'FastMM ⵽ͷŶĽӿڵʹ. һʳͻ쳣ڽֹǰIJ.'; - BlockHeaderCorruptedNoHistoryMsg = ' ҵ, ڴͷѱƻ, ޷õڴʹʷ.'; - FreedObjectClassMsg = #13#10#13#10'ͷŵĶ: '; - VirtualMethodName = #13#10#13#10'鷽: '; - VirtualMethodOffset = 'ƫƵַ +'; - VirtualMethodAddress = #13#10#13#10'鷽ĵַ: '; - StackTraceAtObjectAllocMsg = #13#10#13#10'ö󱻷ʱĶջ(÷صַ):'; - StackTraceAtObjectFreeMsg = #13#10#13#10'öͷʱĶջ(÷صַ):'; - {Installation Messages} - AlreadyInstalledMsg = 'FastMM4 Ѿװ'; - AlreadyInstalledTitle = 'Ѿ'; - OtherMMInstalledMsg = 'FastMM4 ޷װ, Ϊڴаװ.' - + #13#10'ʹFastMM4, ȷĿ .dpr ļ "uses" , ' - + #13#10'FastMM4.pas ǵһʹõĵԪ.'; - OtherMMInstalledTitle = '޷װFastMM4 - ڴȱװ'; - MemoryAllocatedMsg = 'FastMM4 ޷װ, ΪǰͨĬڴڴ.' - + #13#10'FastMM4.pas Ŀ .dpr ļеһʹõĵԪ, ' - + #13#10'FastMM4 õȨ֮ǰ, ӦóѾͨĬڴڴ.' - + #13#10#13#10'ʹ쳣׽, MadExcept(κν޸ĵԪʼ˳Ĺ),' - + #13#10'뵽ҳ,ȷ FastMM4.pas ԪκԪ֮ǰʼ.'; - MemoryAllocatedTitle = '޷װ FastMM4 - ֮ǰѾڴ'; - {Leak checking messages} - LeakLogHeader = 'һڴй¶. С: '; - LeakMessageHeader = 'Ӧóڴй¶. '; - SmallLeakDetail = 'Сڴй¶' -{$ifdef HideExpectedLeaksRegisteredByPointer} - + ' (ѰָעԤ֪й¶)' -{$endif} - + ':'#13#10; - LargeLeakDetail = 'й¶еȼڴĴС' -{$ifdef HideExpectedLeaksRegisteredByPointer} - + ' (ѰָעԤ֪й¶)' -{$endif} - + ': '; - BytesMessage = ' ֽ: '; - StringBlockMessage = 'ַ'; - LeakMessageFooter = #13#10 -{$ifndef HideMemoryLeakHintMessage} - + #13#10'ע: ' - {$ifdef RequireIDEPresenceForLeakReporting} - + 'ֻе Delphi ͬʱͬһʱŻڴй¶. ' - {$endif} - {$ifdef FullDebugMode} - {$ifdef LogMemoryLeakDetailToFile} - + 'ڴй¶ϸϢѾ¼뱾ӦóͬһĿ¼µһıļ. ' - {$else} - + ' "LogMemoryLeakDetailToFile" 뿪Եõһڴй¶ϸϢ־ļ. ' - {$endif} - {$else} - + 'Ҫõһڴй¶ϸϢ־ļ, "FullDebugMode" "LogMemoryLeakDetailToFile" 뿪. ' - {$endif} - + 'Ҫֹڴй¶, ر "EnableMemoryLeakReporting" 뿪.'#13#10 -{$endif} - + #0; - LeakMessageTitle = '⵽ڴй¶'; -{$ifdef UseOutputDebugString} - FastMMInstallMsg = 'FastMM ѱװ.'; - FastMMInstallSharedMsg = 'һѴڵ FastMM ʵ.'; - FastMMUninstallMsg = 'FastMM ѱж.'; - FastMMUninstallSharedMsg = 'ֹͣһѴڵ FastMM ʵ.'; -{$endif} -{$ifdef DetectMMOperationsAfterUninstall} - InvalidOperationTitle = 'ж֮ MM .'; - InvalidGetMemMsg = 'FastMM ⵽ FastMM ж֮ GetMem.'; - InvalidFreeMemMsg = 'FastMM ⵽ FastMM ж֮ FreeMem.'; - InvalidReallocMemMsg = 'FastMM ⵽ FastMM ж֮ ReallocMem.'; - InvalidAllocMemMsg = 'FastMM ⵽ FastMM ж֮ AllocMem.'; -{$endif} - -implementation - -end. - diff --git a/components/fastmm/Translations/Czech/FastMM4Messages.pas b/components/fastmm/Translations/Czech/FastMM4Messages.pas deleted file mode 100644 index cb7f22c..0000000 --- a/components/fastmm/Translations/Czech/FastMM4Messages.pas +++ /dev/null @@ -1,140 +0,0 @@ -{ - -Fast Memory Manager: Messages - -Czech translation by Rene Mihula. - -Modifications: -25.04.2005 rm Added resource strings for FastMM v4.64 compilability -01.03.2007 rm Corrections of keying mistakes -} - -unit FastMM4Messages; - -interface - -{$Include FastMM4Options.inc} - -const - {The name of the debug info support DLL} - FullDebugModeLibraryName = 'FastMM_FullDebugMode.dll'; - {Event log strings} - LogFileExtension = '_MemoryManager_EventLog.txt'#0; - CRLF = #13#10; - EventSeparator = '--------------------------------'; - {Class name messages} - UnknownClassNameMsg = 'Neznm tda'; - {Stack trace Message} - CurrentStackTraceMsg = #13#10#13#10'Stav zsobnku voln vedouc k tto chyb (nvratov adresy): '; - {Memory dump message} - MemoryDumpMsg = #13#10#13#10'Vpis prvnch 256 byt pamti, kter zanaj na adrese '; - {Block Error Messages} - BlockScanLogHeader = 'Alokovan bloky byly zalogovny pomoc LogAllocatedBlocksToFile. Velikost je: '; - ErrorMsgHeader = 'FastMM detekoval chyby bhem operace '; - GetMemMsg = 'GetMem'; - FreeMemMsg = 'FreeMem'; - ReallocMemMsg = 'ReallocMem'; - BlockCheckMsg = 'hledn przdnch blok'; - OperationMsg = ' . '; - BlockHeaderCorruptedMsg = 'Hlavika bloku byla pokozena. '; - BlockFooterCorruptedMsg = 'Patika bloku byla pokozena. '; - FreeModifiedErrorMsg = 'FastMM detekoval modifikaci bloku po jeho uvolnn. '; - DoubleFreeErrorMsg = 'Probhl pokus o uvolnn / realokaci ji uvolnnho bloku.'; - PreviousBlockSizeMsg = #13#10#13#10'Pedchoz velikost bloku: '; - CurrentBlockSizeMsg = #13#10#13#10'Velikost bloku: '; - StackTraceAtPrevAllocMsg = #13#10#13#10'Zsobnk voln pi pedchoz alokaci bloku (nvratov adresy):'; - StackTraceAtAllocMsg = #13#10#13#10'Zsobnk voln pi alokaci bloku (nvratov adresy):'; - PreviousObjectClassMsg = #13#10#13#10'Blok byl ji vyuit pro objekt typu: '; - CurrentObjectClassMsg = #13#10#13#10'Blok je aktuln vyuvn pro objekt typu: '; - PreviousAllocationGroupMsg = #13#10#13#10'Alokan skupina byla: '; // - PreviousAllocationNumberMsg = #13#10#13#10'Alokan slo bylo: '; - CurrentAllocationGroupMsg = #13#10#13#10'Alokan skupina je: '; - CurrentAllocationNumberMsg = #13#10#13#10'Alokan slo je: '; - StackTraceAtFreeMsg = #13#10#13#10'Zsobnk voln pi pedchozm uvolnn bloku (nvratov adresy):'; - BlockErrorMsgTitle = 'Detekovna chyba pamti'; - {Virtual Method Called On Freed Object Errors} - StandardVirtualMethodNames: array[1 + vmtParent div 4 .. -1] of PChar = ( - 'SafeCallException', - 'AfterConstruction', - 'BeforeDestruction', - 'Dispatch', - 'DefaultHandler', - 'NewInstance', - 'FreeInstance', - 'Destroy'); - VirtualMethodErrorHeader = 'FastMM detekoval pokus o voln virtuln metody ji uvolnnho objektu. Pro ukonen tto operace bude nyn vyhozena vyjmka (access violation).'; - InterfaceErrorHeader = 'FastMM detekoval pokus o pstup k interface ji uvolnnho objektu. Pro ukonen tto operace bude nyn vyhozena vyjmka (access violation).'; - BlockHeaderCorruptedNoHistoryMsg = ' Historie je nedostupn z dvodu pokozen hlaviky bloku.'; - FreedObjectClassMsg = #13#10#13#10'Typ uvolovanho objektu: '; - VirtualMethodName = #13#10#13#10'Nzev virtuln metody: '; - VirtualMethodOffset = 'Offset +'; - VirtualMethodAddress = #13#10#13#10'Adresa virtuln metody: '; - StackTraceAtObjectAllocMsg = #13#10#13#10'Zsobnk voln pi alokaci objektu (nvratov adresy):'; - StackTraceAtObjectFreeMsg = #13#10#13#10'Zsobnk voln pi dodatenm uvolnn objektu (nvratov adresy):'; - {Installation Messages} - AlreadyInstalledMsg = 'FastMM4 ji byl nainstalovn.'; - AlreadyInstalledTitle = 'Nainstalovno.'; - OtherMMInstalledMsg = 'FastMM4 nemohl bt nainstalovn, protoe jin memory ' - + 'manager (MM tet strany) ji byl nainstalovn.'#13#10'Pro pouit FastMM4 ' - + 'zkontrolujte, zda je unita FastMM4.pas prvn unitou v sekci "uses" tohoto ' - + 'projektu (.dpr soubor).'; - OtherMMInstalledTitle = 'Nelze nainstalovat FastMM4 - Jin memory manager je ji nainstalovn'; - MemoryAllocatedMsg = 'FastMM4 nemohl bt nainstalovn, protoe jin memory ' - + 'manager (standardn MM) ji byl nainstalovn.'#13#10'Pro pouit FastMM4 ' - + 'zkontrolujte, zda je unita FastMM4.pas prvn unitou v sekci "uses" tohoto ' - + 'projektu (.dpr soubor).'#13#10#13#10 - + 'Pokud pouvte njak exception trapper (nap. MadExcept) nebo libovoln ' - + 'jin nstroj, kter modifikuje poad sekc initialization, nakonfigurujte ' - + 'jej tak, aby unita FastMM4.pas byla inicializovna ped vemi ostatnmi unitami.'; - MemoryAllocatedTitle = 'Nelze nainstalovat FastMM4 - Pam ji byla alokovna'; - {Leak checking messages} - LeakLogHeader = 'Blok pamti zstal neuvolnn. Velikost(i): '; - LeakMessageHeader = 'Aplikace neuvolnila pouvanou pam. '; - SmallLeakDetail = 'Bloky mal velikosti' -{$ifdef HideExpectedLeaksRegisteredByPointer} - + ' (vyjma chyb registrovanch pomoc ukazatel)' -{$endif} - + ':'#13#10; - LargeLeakDetail = 'Bloky stedn a velk velikosti' -{$ifdef HideExpectedLeaksRegisteredByPointer} - + ' (vyjma chyb registrovanch pomoc ukazatel)' -{$endif} - + ': '; - BytesMessage = ' byt: '; - StringBlockMessage = 'String'; - LeakMessageFooter = #13#10 -{$ifndef HideMemoryLeakHintMessage} - + #13#10'Poznmka: ' - {$ifdef RequireIDEPresenceForLeakReporting} - + 'Kontrola neuvolnn pamti je provdna pouze pokud je prosted Delphi aktivn na tomt systmu. ' - {$endif} - {$ifdef FullDebugMode} - {$ifdef LogMemoryLeakDetailToFile} - + 'Detailn informace o neuvolnn pamti jsou zapsny do textovho souboru v adresi aplikace. ' - {$else} - + 'Povolenm direktivy "LogMemoryLeakDetailToFile" lze do souboru logu zapsat detailn informace o neuvolnn pamti. ' - {$endif} - {$else} - + 'Pro zskn logu s detailnmi informacemi o neuvolnn pamti je poteba povolit direktivy "FullDebugMode" a "LogMemoryLeakDetailToFile". ' - {$endif} - + 'Vypnutm direktivy "EnableMemoryLeakReporting" lze deaktivovat tuto kontrolu neuvolnn pamti.'#13#10 -{$endif} - + #0; - LeakMessageTitle = 'Byla detekovna neuvolnn pam (Memory Leak)'; -{$ifdef UseOutputDebugString} - FastMMInstallMsg = 'FastMM byl nataen.'; - FastMMInstallSharedMsg = 'Sdlen existujc instance FastMM.'; - FastMMUninstallMsg = 'FastMM byl odinstalovn.'; - FastMMUninstallSharedMsg = 'Zastaveno sdlen existujc instance FastMM.'; -{$endif} -{$ifdef DetectMMOperationsAfterUninstall} - InvalidOperationTitle = 'Detekce MM voln po odinstalovn FastMM.'; - InvalidGetMemMsg = 'FastMM detekoval voln GetMem, kter probhlo po odinstalaci FastMM.'; - InvalidFreeMemMsg = 'FastMM detekoval voln FreeMem, kter probhlo po odinstalaci FastMM.'; - InvalidReallocMemMsg = 'FastMM detekoval voln ReallocMem, kter probhlo po odinstalaci FastMM.'; - InvalidAllocMemMsg = 'FastMM detekoval voln ReallocMem, kter probhlo po odinstalaci FastMM.'; -{$endif} - -implementation -end. - diff --git a/components/fastmm/Translations/English/FastMM4Messages.pas b/components/fastmm/Translations/English/FastMM4Messages.pas deleted file mode 100644 index a0f76f0..0000000 --- a/components/fastmm/Translations/English/FastMM4Messages.pas +++ /dev/null @@ -1,139 +0,0 @@ -{ - -Fast Memory Manager: Messages - -English translation by Pierre le Riche. - -} - -unit FastMM4Messages; - -interface - -{$Include FastMM4Options.inc} - -const - {The name of the debug info support DLL} - FullDebugModeLibraryName = 'FastMM_FullDebugMode.dll'; - {Event log strings} - LogFileExtension = '_MemoryManager_EventLog.txt'#0; - CRLF = #13#10; - EventSeparator = '--------------------------------'; - {Class name messages} - UnknownClassNameMsg = 'Unknown'; - {Stack trace Message} - CurrentStackTraceMsg = #13#10#13#10'The current stack trace leading to this error (return addresses): '; - {Memory dump message} - MemoryDumpMsg = #13#10#13#10'Current memory dump of 256 bytes starting at pointer address '; - {Block Error Messages} - BlockScanLogHeader = 'Allocated block logged by LogAllocatedBlocksToFile. The size is: '; - ErrorMsgHeader = 'FastMM has detected an error during a '; - GetMemMsg = 'GetMem'; - FreeMemMsg = 'FreeMem'; - ReallocMemMsg = 'ReallocMem'; - BlockCheckMsg = 'free block scan'; - OperationMsg = ' operation. '; - BlockHeaderCorruptedMsg = 'The block header has been corrupted. '; - BlockFooterCorruptedMsg = 'The block footer has been corrupted. '; - FreeModifiedErrorMsg = 'FastMM detected that a block has been modified after being freed. '; - DoubleFreeErrorMsg = 'An attempt has been made to free/reallocate an unallocated block.'; - PreviousBlockSizeMsg = #13#10#13#10'The previous block size was: '; - CurrentBlockSizeMsg = #13#10#13#10'The block size is: '; - StackTraceAtPrevAllocMsg = #13#10#13#10'Stack trace of when this block was previously allocated (return addresses):'; - StackTraceAtAllocMsg = #13#10#13#10'Stack trace of when this block was allocated (return addresses):'; - PreviousObjectClassMsg = #13#10#13#10'The block was previously used for an object of class: '; - CurrentObjectClassMsg = #13#10#13#10'The block is currently used for an object of class: '; - PreviousAllocationGroupMsg = #13#10#13#10'The allocation group was: '; - PreviousAllocationNumberMsg = #13#10#13#10'The allocation number was: '; - CurrentAllocationGroupMsg = #13#10#13#10'The allocation group is: '; - CurrentAllocationNumberMsg = #13#10#13#10'The allocation number is: '; - StackTraceAtFreeMsg = #13#10#13#10'Stack trace of when the block was previously freed (return addresses):'; - BlockErrorMsgTitle = 'Memory Error Detected'; - {Virtual Method Called On Freed Object Errors} - StandardVirtualMethodNames: array[1 + vmtParent div 4 .. -1] of PChar = ( - 'SafeCallException', - 'AfterConstruction', - 'BeforeDestruction', - 'Dispatch', - 'DefaultHandler', - 'NewInstance', - 'FreeInstance', - 'Destroy'); - VirtualMethodErrorHeader = 'FastMM has detected an attempt to call a virtual method on a freed object. An access violation will now be raised in order to abort the current operation.'; - InterfaceErrorHeader = 'FastMM has detected an attempt to use an interface of a freed object. An access violation will now be raised in order to abort the current operation.'; - BlockHeaderCorruptedNoHistoryMsg = ' Unfortunately the block header has been corrupted so no history is available.'; - FreedObjectClassMsg = #13#10#13#10'Freed object class: '; - VirtualMethodName = #13#10#13#10'Virtual method: '; - VirtualMethodOffset = 'Offset +'; - VirtualMethodAddress = #13#10#13#10'Virtual method address: '; - StackTraceAtObjectAllocMsg = #13#10#13#10'Stack trace of when the object was allocated (return addresses):'; - StackTraceAtObjectFreeMsg = #13#10#13#10'Stack trace of when the object was subsequently freed (return addresses):'; - {Installation Messages} - AlreadyInstalledMsg = 'FastMM4 is already installed.'; - AlreadyInstalledTitle = 'Already installed.'; - OtherMMInstalledMsg = 'FastMM4 cannot be installed since another third party memory ' - + 'manager has already installed itself.'#13#10'If you want to use FastMM4, ' - + 'please make sure that FastMM4.pas is the very first unit in the "uses"' - + #13#10'section of your project''s .dpr file.'; - OtherMMInstalledTitle = 'Cannot install FastMM4 - Another memory manager is already installed'; - MemoryAllocatedMsg = 'FastMM4 cannot install since memory has already been ' - + 'allocated through the default memory manager.'#13#10'FastMM4.pas MUST ' - + 'be the first unit in your project''s .dpr file, otherwise memory may ' - + 'be allocated'#13#10'through the default memory manager before FastMM4 ' - + 'gains control. '#13#10#13#10'If you are using an exception trapper ' - + 'like MadExcept (or any tool that modifies the unit initialization ' - + 'order),'#13#10'go into its configuration page and ensure that the ' - + 'FastMM4.pas unit is initialized before any other unit.'; - MemoryAllocatedTitle = 'Cannot install FastMM4 - Memory has already been allocated'; - {Leak checking messages} - LeakLogHeader = 'A memory block has been leaked. The size is: '; - LeakMessageHeader = 'This application has leaked memory. '; - SmallLeakDetail = 'The small block leaks are' -{$ifdef HideExpectedLeaksRegisteredByPointer} - + ' (excluding expected leaks registered by pointer)' -{$endif} - + ':'#13#10; - LargeLeakDetail = 'The sizes of leaked medium and large blocks are' -{$ifdef HideExpectedLeaksRegisteredByPointer} - + ' (excluding expected leaks registered by pointer)' -{$endif} - + ': '; - BytesMessage = ' bytes: '; - StringBlockMessage = 'String'; - LeakMessageFooter = #13#10 -{$ifndef HideMemoryLeakHintMessage} - + #13#10'Note: ' - {$ifdef RequireIDEPresenceForLeakReporting} - + 'This memory leak check is only performed if Delphi is currently running on the same computer. ' - {$endif} - {$ifdef FullDebugMode} - {$ifdef LogMemoryLeakDetailToFile} - + 'Memory leak detail is logged to a text file in the same folder as this application. ' - {$else} - + 'Enable the "LogMemoryLeakDetailToFile" to obtain a log file containing detail on memory leaks. ' - {$endif} - {$else} - + 'To obtain a log file containing detail on memory leaks, enable the "FullDebugMode" and "LogMemoryLeakDetailToFile" conditional defines. ' - {$endif} - + 'To disable this memory leak check, undefine "EnableMemoryLeakReporting".'#13#10 -{$endif} - + #0; - LeakMessageTitle = 'Memory Leak Detected'; -{$ifdef UseOutputDebugString} - FastMMInstallMsg = 'FastMM has been installed.'; - FastMMInstallSharedMsg = 'Sharing an existing instance of FastMM.'; - FastMMUninstallMsg = 'FastMM has been uninstalled.'; - FastMMUninstallSharedMsg = 'Stopped sharing an existing instance of FastMM.'; -{$endif} -{$ifdef DetectMMOperationsAfterUninstall} - InvalidOperationTitle = 'MM Operation after uninstall.'; - InvalidGetMemMsg = 'FastMM has detected a GetMem call after FastMM was uninstalled.'; - InvalidFreeMemMsg = 'FastMM has detected a FreeMem call after FastMM was uninstalled.'; - InvalidReallocMemMsg = 'FastMM has detected a ReallocMem call after FastMM was uninstalled.'; - InvalidAllocMemMsg = 'FastMM has detected an AllocMem call after FastMM was uninstalled.'; -{$endif} - -implementation - -end. - diff --git a/components/fastmm/Translations/German/by Thomas Speck/FastMM4Messages.pas b/components/fastmm/Translations/German/by Thomas Speck/FastMM4Messages.pas deleted file mode 100644 index e4938e3..0000000 --- a/components/fastmm/Translations/German/by Thomas Speck/FastMM4Messages.pas +++ /dev/null @@ -1,139 +0,0 @@ -{ - -Fast Memory Manager: Messages - -German Translation by Thomas Speck (thomas.speck@tssoft.de). - -} - -unit FastMM4Messages; - -interface - -{$Include FastMM4Options.inc} - -const - {The name of the debug info support DLL} - FullDebugModeLibraryName = 'FastMM_FullDebugMode.dll'; - {Event log strings} - LogFileExtension = '_MemoryManager_EventLog.txt'#0; - CRLF = #13#10; - EventSeparator = '--------------------------------'; - {Class name messages} - UnknownClassNameMsg = 'Unbekannt'; - {Stack trace Message} - CurrentStackTraceMsg = #13#10#13#10'Der aktuelle Aufrufstack, der zu diesem Fehler gefhrt hat (Rcksprungadressen): '; - {Memory dump message} - MemoryDumpMsg = #13#10#13#10'Aktueller Speicherauszug von 256 Bytes, beginnend ab Zeigeradresse '; - {Block Error Messages} - BlockScanLogHeader = 'Allocated block logged by LogAllocatedBlocksToFile. The size is: '; - ErrorMsgHeader = 'FastMM hat einen Fehler entdeckt whrend einem / einer'; - GetMemMsg = 'GetMem'; - FreeMemMsg = 'FreeMem'; - ReallocMemMsg = 'ReallocMem'; - BlockCheckMsg = 'Freien Block-Scan'; - OperationMsg = ' Operation. '; - BlockHeaderCorruptedMsg = 'Der Block-Beginn ist defekt. '; - BlockFooterCorruptedMsg = 'Das Block-Ende ist defekt. '; - FreeModifiedErrorMsg = 'FastMM entdeckte einen Block, der nach der Freigabe verndert wurde. '; - DoubleFreeErrorMsg = 'Es wurde versucht, einen unbelegten Block freizugeben bzw. zu belegen.'; - PreviousBlockSizeMsg = #13#10#13#10'Die vorherige Blockgre war: '; - CurrentBlockSizeMsg = #13#10#13#10'Die Blockgre ist: '; - StackTraceAtPrevAllocMsg = #13#10#13#10'Aufrufstack, von wem der Block vorher belegt wurde (Rcksprungadressen):'; - StackTraceAtAllocMsg = #13#10#13#10'Aufrufstack, von wem der Block momentan belegt wird (Rcksprungadressen):'; - PreviousObjectClassMsg = #13#10#13#10'Der Block wurde vorher fr eine Objektklasse benutzt: '; - CurrentObjectClassMsg = #13#10#13#10'Der Block wird momentan fr eine Objektklasse benutzt '; - PreviousAllocationGroupMsg = #13#10#13#10'The allocation group was: '; - PreviousAllocationNumberMsg = #13#10#13#10'The allocation number was: '; - CurrentAllocationGroupMsg = #13#10#13#10'The allocation group is: '; - CurrentAllocationNumberMsg = #13#10#13#10'The allocation number is: '; - StackTraceAtFreeMsg = #13#10#13#10'Aufrufstack, von wem der Block vorher freigegeben wurde (Rcksprungadressen):'; - BlockErrorMsgTitle = 'Speicherfehler entdeckt'; - {Virtual Method Called On Freed Object Errors} - StandardVirtualMethodNames: array[1 + vmtParent div 4 .. -1] of PChar = ( - 'SafeCallException', - 'AfterConstruction', - 'BeforeDestruction', - 'Dispatch', - 'DefaultHandler', - 'NewInstance', - 'FreeInstance', - 'Destroy'); - VirtualMethodErrorHeader = 'FastMM hat einen Versuch entdeckt, eine virtuelle Methode eines freigegebenen Objektes aufzurufen. Eine Schutzverletzung wird nun aufgerufen, um die aktuelle Operation abzubrechen.'; - InterfaceErrorHeader = 'FastMM hat einen Versuch entdeckt, ein Interface eines freigegebenen Objektes aufzurufen. Eine Schutzverletzung wird nun aufgerufen, um die aktuelle Operation abzubrechen.'; - BlockHeaderCorruptedNoHistoryMsg = ' Unglcklicherweise wurde der Block-Beginn beschdigt, so da keine Historie verfgbar ist.'; - FreedObjectClassMsg = #13#10#13#10'Freigegebene Objekt-Klasse: '; - VirtualMethodName = #13#10#13#10'Virtuelle Methode: '; - VirtualMethodOffset = 'Offset +'; - VirtualMethodAddress = #13#10#13#10'Adresse der virtuellen Methode: '; - StackTraceAtObjectAllocMsg = #13#10#13#10'Aufrufstack, wann das Objekt belegt wurde (Rcksprungadressen):'; - StackTraceAtObjectFreeMsg = #13#10#13#10'Aufrufstack, wann das Objekt freigegeben wurde (Rcksprungadressen):'; - {Installation Messages} - AlreadyInstalledMsg = 'FastMM4 ist installiert.'; - AlreadyInstalledTitle = 'Schon installiert.'; - OtherMMInstalledMsg = 'FastMM4 kann nicht installiert werden, weil ein schon ein anderer ' - + 'Memory Manager installiert wurde.'#13#10'Wenn Sie FastMM4 benutzen wollen, ' - + 'dann vergewissern Sie sich, da FastMM4.pas die allererste Unit in der "uses"' - + #13#10'Sektion Ihrer Projektdatei ist.'; - OtherMMInstalledTitle = 'Kann FastMM4 nicht installieren - Ein anderer Memory Manager ist schon installiert.'; - MemoryAllocatedMsg = 'FastMM4 kann nicht installiert werden, weil schon Speicher' - + 'durch den Default Memory Manager belegt wurde.'#13#10'FastMM4.pas MUSS ' - + 'die allererste Unit in Ihrer Projektdatei sein, sonst wird der Speicher ' - + 'durch den Default Memory Manager belegt, bevor FastMM4 die Kontrolle bernimmt. ' - + #13#10#13#10'Wenn Sie ein Programm benutzen, welches Exceptions abfngt ' - + 'z.B. MadExcept (oder ein anderes Tool, das die Reihenfolge der Unit Initialisierung ' - + 'verndert),'#13#10'dann gehen Sie in seine Konfiguration und stellen Sie sicher, da ' - + 'FastMM4.pas Unit vor jeder anderen Unit initialisiert wird.'; - MemoryAllocatedTitle = 'Kann FastMM4nicht installieren - Speicher wurde schon belegt.'; - {Leak checking messages} - LeakLogHeader = 'Ein Speicherblock hat Speicher verloren. Die Gre ist: '; - LeakMessageHeader = 'Diese Anwendung hat Speicher verloren. '; - SmallLeakDetail = 'Die Gren von kleinen Speicherblcken, die verlorengegangen sind, betragen' -{$ifdef HideExpectedLeaksRegisteredByPointer} - + ' (ausgenommen erwartete Speicherlecks, die durch Zeiger registriert wurden)' -{$endif} - + ':'#13#10; - LargeLeakDetail = 'Die Gren von mittleren und groen Speicherblcken, die verlorengegangen sind, betragen' -{$ifdef HideExpectedLeaksRegisteredByPointer} - + ' (ausgenommen erwartete Speicherlecks, die durch Zeiger registriert wurden)' -{$endif} - + ': '; - BytesMessage = ' Bytes: '; - StringBlockMessage = 'String'; - LeakMessageFooter = #13#10 -{$ifndef HideMemoryLeakHintMessage} - + #13#10'Notiz: ' - {$ifdef RequireIDEPresenceForLeakReporting} - + 'Diese berprfung auf Speicherlecks wird nur durchgefhrt, wenn Delphi auf dem selben Computer gestartet ist. ' - {$endif} - {$ifdef FullDebugMode} - {$ifdef LogMemoryLeakDetailToFile} - + 'Speicherleck-Details werden in eine Textdatei geschrieben, die sich im selben Verzeichnis wie diese Anwendung befindet. ' - {$else} - + 'Aktiviere "LogMemoryLeakDetailToFile", um eine detaillierte Log-Datei zu erhalten, die Details zu Speicherlecks enthlt. ' - {$endif} - {$else} - + 'Um eine Log-Datei zu erhalten, die Details zu Speicherlecks enthlt, aktivieren Sie "FullDebugMode" und "LogMemoryLeakDetailToFile" in der Options-Datei. ' - {$endif} - + 'Um diese Speicherleck-berprfung abzuschalten, kommentieren Sie "EnableMemoryLeakReporting" aus.'#13#10 -{$endif} - + #0; - LeakMessageTitle = 'Speicherleck entdeckt'; -{$ifdef UseOutputDebugString} - FastMMInstallMsg = 'FastMM wurde installiert.'; - FastMMInstallSharedMsg = 'Benutzung einer existierenden Instanz von FastMM wurde gestartet.'; - FastMMUninstallMsg = 'FastMM wurde deinstalliert.'; - FastMMUninstallSharedMsg = 'Benutzung einer existierenden Instanz von FastMM wurde gestoppt.'; -{$endif} -{$ifdef DetectMMOperationsAfterUninstall} - InvalidOperationTitle = 'MM Operation nach der Deinstallierung.'; - InvalidGetMemMsg = 'FastMM hat einen GetMem-Aufruf nach der Deinstallation von FastMM entdeckt.'; - InvalidFreeMemMsg = 'FastMM hat einen FreeMem-Aufruf nach der Deinstallation von FastMM entdeckt.'; - InvalidReallocMemMsg = 'FastMM hat einen ReAllocMem-Aufruf nach der Deinstallation von FastMM entdeckt.'; - InvalidAllocMemMsg = 'FastMM hat einen AllocMem-Aufruf nach der Deinstallation von FastMM entdeckt.'; -{$endif} - -implementation - -end. - diff --git a/components/fastmm/Translations/German/by Uwe Queisser/FastMM4Messages.pas b/components/fastmm/Translations/German/by Uwe Queisser/FastMM4Messages.pas deleted file mode 100644 index 7957b09..0000000 --- a/components/fastmm/Translations/German/by Uwe Queisser/FastMM4Messages.pas +++ /dev/null @@ -1,135 +0,0 @@ -{Fast Memory Manager: Meldungen - -Deutsche bersetzung von Uwe Queisser [uweq] - -} -unit FastMM4Messages; - -interface - -{$Include FastMM4Options.inc} - -const - {Der Name der Debug-Info-DLL} - FullDebugModeLibraryName = 'FastMM_FullDebugMode.dll'; - {Protokollaufzeichungs Erweiterung} - LogFileExtension = '_FastMM_Log.txt'#0; {*** (changed) geaendert 31.01.06 (to long) zu lang *** [uweq] ***} - CRLF = #13#10; - EventSeparator = '--------------------------------'; - {Klassenbezeichner Meldung} - UnknownClassNameMsg = 'Unbekannt'; - {Stackverlauf Nachricht} - CurrentStackTraceMsg = #13#10#13#10'Die aktuelle Stack ablaufverfolgung, die zu diesem Fehler fhrte (Rckgabeadresse): '; - {Speicherauszugsnachricht} - MemoryDumpMsg = #13#10#13#10'Aktueller Speicherauszug von 256 Byte, angefangen an der Zeigeradresse: '; - {Block Fehlermeldungen} - BlockScanLogHeader = 'Allocated block logged by LogAllocatedBlocksToFile. The size is: '; - ErrorMsgHeader = 'FastMM hat einen Fehler erkannt, whrend ein'; - GetMemMsg = ' GetMem'; - FreeMemMsg = ' FreeMem'; - ReallocMemMsg = ' ReallocMem'; - BlockCheckMsg = 'er freier SpeicherBlockberprfung'; - OperationMsg = ' Operation. '; - BlockHeaderCorruptedMsg = 'Der Block-Header ist fehlerhaft. '; - BlockFooterCorruptedMsg = 'Der Block-Footer (Line) ist fehlerhaft. '; - FreeModifiedErrorMsg = 'FastMM hat festgestellt, da ein Speicherblock modifiziert worden ist, nachdem er freigegeben wurde. '; - DoubleFreeErrorMsg = 'Es wurde ein Versuch unternommen, einen freigegebenen Speicherblock freizugeben / wiederzuverwenden.'; - PreviousBlockSizeMsg = #13#10#13#10'Die vorherige Speicherblockgre war: '; - CurrentBlockSizeMsg = #13#10#13#10'Die Speicherblockgre ist: '; - StackTraceAtPrevAllocMsg = #13#10#13#10'Stackverfolgung - Speicherblock wurde bereits zugeordnet (Rckgabeadresse):'; - StackTraceAtAllocMsg = #13#10#13#10'Stackverfolgung - Speicherpuffer wurde zugeordnet (Rckgabeadresse):'; - PreviousObjectClassMsg = #13#10#13#10'Der Speicherpuffer wurde zuvor fr ein Objekt der folgenden Klasse verwendet: '; - CurrentObjectClassMsg = #13#10#13#10'Der Speicherpuffer wird gegenwrtig fr ein Objekt der folgenden Klasse verwendet: '; - PreviousAllocationGroupMsg = #13#10#13#10'The allocation group was: '; - PreviousAllocationNumberMsg = #13#10#13#10'The allocation number was: '; - CurrentAllocationGroupMsg = #13#10#13#10'The allocation group is: '; - CurrentAllocationNumberMsg = #13#10#13#10'The allocation number is: '; - StackTraceAtFreeMsg = #13#10#13#10'Stackverfolgung des Speicherpuffers, wann der Speicherblock zuvor freigegeben wurde (Rckgabeadresse):'; - BlockErrorMsgTitle = 'Speicherfehler gefunden'; - {Freigegebene Objekt aufgerufene virtuelle Methoden} - StandardVirtualMethodNames: array[1 + vmtParent div 4 .. -1] of PChar = ( - 'SafeCallException', - 'AfterConstruction', - 'BeforeDestruction', - 'Dispatch', - 'DefaultHandler', - 'NewInstance', - 'FreeInstance', - 'Destroy'); - VirtualMethodErrorHeader = 'FastMM hat einen Versuch festgestellt, eine virtuelle Methode eines freigegebenen Objekts aufzurufen.'+CRLF - +'Es wird jetzt eine Zugriffsverletzung erzeugt, um den aktuellen Betrieb abzubrechen.'; - InterfaceErrorHeader = 'FastMM hat einen Versuch festgestellt, eine Schnittstelle eines freigegebenen Objekts zu verwenden.'+CRLF - +'Es wird jetzt eine Zugriffsverletzung erzeugt, um den aktuellen Betrieb abzubrechen.'; - BlockHeaderCorruptedNoHistoryMsg = ' Leider ist der Speicherbereich fehlerhaft, so da kein Protokoll verfgbar ist.'; - FreedObjectClassMsg = #13#10#13#10'Freigegebene Objektklasse: '; - VirtualMethodName = #13#10#13#10'Virtuelle Methode: '; - VirtualMethodOffset = 'Relative Position +'; - VirtualMethodAddress = #13#10#13#10'Virtuelle Methodenadresse: '; - StackTraceAtObjectAllocMsg = #13#10#13#10'Stackverfolgung des Speicherblocks, wann das Objekt zugeordnet wurde (Rckgabeadresse):'; - StackTraceAtObjectFreeMsg = #13#10#13#10'Stackverfolgung des Speicherpuffers, wann das Objekt anschlieend freigegeben wurde (Rckgabeadresse):'; - {Installationsmeldungen} - AlreadyInstalledMsg = 'FastMM4 ist bereits installiert.'; - AlreadyInstalledTitle = 'schon installiert.'; - OtherMMInstalledMsg = 'FastMM4 kann nicht noch einmal in den Speicher geladen werden. ' - + 'Manager hat sich bereits installiert.'#13#10'Wenn Sie FastMM4 verwenden wollen,' - + 'vergewissern sie sich, da FastMM4.pas die allererste Unit in der "uses"' - + #13#10'-Anweisung ihrer Projekt-.dpr Datei ist.'; - OtherMMInstalledTitle = 'Kann die Installation von FastMM4 nicht fortsetzen - da ein anderer Speichermanager bereits geladen wurde'; - MemoryAllocatedMsg = 'FastMM4 kann sich nicht installieren, da der Speicher schon' - + ' von einem anderen Speichermanager zugeordnet wurde.'#13#10'FastMM4.pas mu' - + ' die erste Unit in Ihrer Projekt-.dpr sein, sonst wird Speicher, ' - + 'vor Benutzung des FastMM4 '#13#10' durch den Standardspeichermanager zugeordnet' - + ' und bernommen. '#13#10#13#10'Wenn Sie eine Fehlerbehandlung benutzen ' - + 'mchten, sollten Sie MadExcept (oder ein anderes Hilfsprogramm, das die Unit-Initialisierung modifiziert' - + ' bestellen), '#13#10' und stellen in der Konfiguration sicher, da die ' - + 'FastMM4.pas Unit vor jeder anderen Unit initialisiert wird.'; - MemoryAllocatedTitle = 'Keine Installation von FastMM4 - Speicher ist bereits zugeordnet worden.'; - {Speicherleck Meldungen} - LeakLogHeader = 'Ein Speicher-Leck hat folgende Gre : '; - LeakMessageHeader = 'Diese Anwendung hat Speicher-Lecks. '; - SmallLeakDetail = 'Die kleineren Speicher-Lecks sind' -{$ifdef HideExpectedLeaksRegisteredByPointer} - + ' (ausschlielich von Zeigern registrierte Lecks)' -{$endif} - + ':'#13#10; - LargeLeakDetail = 'Die greren Speicher-Lecks sind' -{$ifdef HideExpectedLeaksRegisteredByPointer} - + ' (ausschlielich von Zeiger registrierte Lecks)' -{$endif} - + ': '; - BytesMessage = ' bytes: '; - StringBlockMessage = 'String'; - LeakMessageFooter = #13#10 -{$ifndef HideMemoryLeakHintMessage} - + #13#10'Hinweis: ' - {$ifdef RequireIDEPresenceForLeakReporting} - + 'Diese Speicherleckprfung wird nur ausgefhrt, wenn Delphi gegenwrtig auf demselben Computer luft. ' - {$endif} - {$ifdef FullDebugMode} - {$ifdef LogMemoryLeakDetailToFile} - + 'Speicherlecks werden in einer Textdatei im selben Ordner wie diese Anwendung protokolliert. ' - {$else} - + 'Wenn Sie "{$ LogMemoryLeakDetailToFile}" aktivieren, erhalten sie in der Protokolldatei die Details ber Speicherlecks. ' - {$endif} - {$else} - + 'Um eine Protokolldatei zu erhalten, die Details ber Speicherlecks enthlt, aktivieren Sie die "{$ FullDebugMode}" und "{$ LogMemoryLeakDetailToFile}" Definitionen. ' - {$endif} - + 'Um die Speicherleckprfung zu deaktivieren, deaktivieren sie die "{$ EnableMemoryLeakReporting} -Option".'#13#10 -{$endif} - + #0; - LeakMessageTitle = 'Speicherleck entdeckt'; -{$ifdef UseOutputDebugString} - FastMMInstallMsg = 'FastMM ist wurde geladen.'; - FastMMInstallSharedMsg = 'Eine bereits vorhandene Instanz von FastMM wird gemeinsam benutzt.'; - FastMMUninstallMsg = 'FastMM ist aus dem Speicher entladen worden.'; - FastMMUninstallSharedMsg = 'Eine gemeinsam benutzte Instanz von FastMM wurde angehalten.'; -{$endif} -{$ifdef DetectMMOperationsAfterUninstall} - InvalidOperationTitle = 'MM nach dem Betrieb der Installation.'; - InvalidGetMemMsg = 'FastMM hat einen GetMem Aufruf gefunden, nachdem FastMM deinstalliert wurde.'; - InvalidFreeMemMsg = 'FastMM hat einen FreeMem Aufruf gefunden, nachdem FastMM deinstalliert wurde.'; - InvalidReallocMemMsg = 'FastMM hat einen ReallocMem Aufruf gefunden, nachdem FastMM deinstalliert wurde.'; - InvalidAllocMemMsg = 'FastMM hat einen ReallocMem Aufruf gefunden, nachdem FastMM deinstalliert wurde.'; -{$endif} -implementation -end. \ No newline at end of file diff --git a/components/fastmm/Translations/Indonesian/FastMM4Messages.pas b/components/fastmm/Translations/Indonesian/FastMM4Messages.pas deleted file mode 100644 index 755f371..0000000 --- a/components/fastmm/Translations/Indonesian/FastMM4Messages.pas +++ /dev/null @@ -1,139 +0,0 @@ -{ - -Fast Memory Manager: Messages - -Indonesian translation by Zaenal Mutaqin. - -} - -unit FastMM4Messages; - -interface - -{$Include FastMM4Options.inc} - -const - {The name of the debug info support DLL} - FullDebugModeLibraryName = 'FastMM_FullDebugMode.dll'; - {Event log strings} - LogFileExtension = '_Laporan_ManajerMemori.txt'#0; - CRLF = #13#10; - EventSeparator = '--------------------------------'; - {Class name messages} - UnknownClassNameMsg = 'Tidak dikenal'; - {Stack trace Message} - CurrentStackTraceMsg = #13#10#13#10'Penelusuran stack saat ini membawa ke kesalahan ini (alamat balik): '; - {Memory dump message} - MemoryDumpMsg = #13#10#13#10'Dump memori saat ini dari 256 byte dimulai pada alamat pointer '; - {Block Error Messages} - BlockScanLogHeader = 'Allocated block logged by LogAllocatedBlocksToFile. The size is: '; - ErrorMsgHeader = 'FastMM mendeteksi terjadi kesalahan sewaktu '; - GetMemMsg = 'GetMem'; - FreeMemMsg = 'FreeMem'; - ReallocMemMsg = 'ReallocMem'; - BlockCheckMsg = 'membebaskan pemantauan blok'; - OperationMsg = ' operasi. '; - BlockHeaderCorruptedMsg = 'Kepala blok sudah terkorupsi. '; - BlockFooterCorruptedMsg = 'Kaki blok sudah terkorupsi. '; - FreeModifiedErrorMsg = 'FastMM mendeteksi bahwa blok sudah diubah setelah dibebaskan. '; - DoubleFreeErrorMsg = 'Percobaan dilakukan untuk membebaskan/realokasi blok yang tidak dialokasikan'; - PreviousBlockSizeMsg = #13#10#13#10'Besar blok sebelumnya adalah: '; - CurrentBlockSizeMsg = #13#10#13#10'Besar blok adalah: '; - StackTraceAtPrevAllocMsg = #13#10#13#10'Penelusuran stack ketika blok ini sebelumnya dialokasikan (alamat balik):'; - StackTraceAtAllocMsg = #13#10#13#10'Penelusuran stack ketika blok ini dialokasikan (alamat balik):'; - PreviousObjectClassMsg = #13#10#13#10'Blok yang sebelumnya digunakan untuk obyek dari kelas: '; - CurrentObjectClassMsg = #13#10#13#10'Blok yang digunakan saat ini untuk obyek dari kelas: '; - PreviousAllocationGroupMsg = #13#10#13#10'The allocation group was: '; - PreviousAllocationNumberMsg = #13#10#13#10'The allocation number was: '; - CurrentAllocationGroupMsg = #13#10#13#10'The allocation group is: '; - CurrentAllocationNumberMsg = #13#10#13#10'The allocation number is: '; - StackTraceAtFreeMsg = #13#10#13#10'Penelusuran stack ketika blok sebelumnya dibebaskan (alamat balik):'; - BlockErrorMsgTitle = 'Kesalahan Memori Terdeteksi'; - {Virtual Method Called On Freed Object Errors} - StandardVirtualMethodNames: array[1 + vmtParent div 4 .. -1] of PChar = ( - 'SafeCallException', - 'AfterConstruction', - 'BeforeDestruction', - 'Dispatch', - 'DefaultHandler', - 'NewInstance', - 'FreeInstance', - 'Destroy'); - VirtualMethodErrorHeader = 'FastMM mendeteksi percobaan pemanggilan metode virtual pada obyek yang dibebaskan. Pelanggaran akses akan ditampilkan sekarang untuk membatalkan operasi saat ini.'; - InterfaceErrorHeader = 'FastMM mendeteksi percobaan penggunaan antar muka dari obyek yang sudah dibebaskan. Pelanggaran akses akan ditampilkan sekarang untuk membatalkan operasi saat ini.'; - BlockHeaderCorruptedNoHistoryMsg = ' Kebetulan kepala blok sudah terkorupsi oleh karenanya tidak ada histori yang tersedia.'; - FreedObjectClassMsg = #13#10#13#10'Kelas obyek yang dibebaskan: '; - VirtualMethodName = #13#10#13#10'Metode virtual: '; - VirtualMethodOffset = 'Ofset +'; - VirtualMethodAddress = #13#10#13#10'Alamat metode virtual: '; - StackTraceAtObjectAllocMsg = #13#10#13#10'Penelusuran stack ketika obyek dialokasikan (alamat balik):'; - StackTraceAtObjectFreeMsg = #13#10#13#10'Penelusuran stack ketika obyek dibebaskan secara subsekuen (alamat balik):'; - {Installation Messages} - AlreadyInstalledMsg = 'FastMM4 sudah diinstalasi.'; - AlreadyInstalledTitle = 'Sudah terinstalasi.'; - OtherMMInstalledMsg = 'FastMM4 tidak bisa diinstalasi karena manajer memori pihak ketiga ' - + 'sudah menginstalasi dirinya sendiri.'#13#10'Jika anda ingin menggunakan FastMM4, ' - + 'pastikan bahwa FastMM4.pas adalah untit paling pertama dalam seksi "uses"' - + #13#10'dari file proyek .dpr anda.'; - OtherMMInstalledTitle = 'Tidak bisa menginstalasi FastMM4 - Manajer memori lain sudah diinstalasi'; - MemoryAllocatedMsg = 'FastMM4 tidak bisa menginstalasi karena memori sudah ' - + 'dialokasikan melalui manajer memori default.'#13#10'FastMM4.pas HARUS ' - + 'unit pertama dalam file proyek .dpr anda, sebaliknya memori bisa ' - + 'dialokasikan '#13#10'melalui manajer memori default sebelum FastMM4 ' - + 'mendapatkan kontrolnya. '#13#10#13#10'Jika anda menggunakan penjebak kekecualian ' - + 'seperti MadExcept (atau piranti lain yang mengubah urutan inisialiasai unit, ' - + #13#10'lihat ke dalam halaman konfigurasinya dan pastikan bahwa ' - + 'unit FastMM4.pas diinisialisasi sebelum unit lainnya.'; - MemoryAllocatedTitle = 'Tidak bisa menginstalasi FastMM4 - Memori sudah dialokasikan'; - {Leak checking messages} - LeakLogHeader = 'Blok memori sudah bocor. Besarnya adalah: '; - LeakMessageHeader = 'Aplikasi ini mempunyai kebocoran memori. '; - SmallLeakDetail = 'Blok kecil kebocoran adalah' -{$ifdef HideExpectedLeaksRegisteredByPointer} - + ' (tidak termasuk kebocoran yang didaftarkan oleh pointer)' -{$endif} - + ':'#13#10; - LargeLeakDetail = 'Besar dari kebocoran blok medium dan besar adalah' -{$ifdef HideExpectedLeaksRegisteredByPointer} - + ' (tidak termasuk kebocoran yang terdaftar oleh pointer)' -{$endif} - + ': '; - BytesMessage = ' byte: '; - StringBlockMessage = 'String'; - LeakMessageFooter = #13#10 -{$ifndef HideMemoryLeakHintMessage} - + #13#10'Catatan: ' - {$ifdef RequireIDEPresenceForLeakReporting} - + 'Kebocoran memori ini hanya ditampilkan jika Delphi saat ini berjalan pada komputer yang sama. ' - {$endif} - {$ifdef FullDebugMode} - {$ifdef LogMemoryLeakDetailToFile} - + 'Perincian kebocoran memori dicatat ke file teks dalam folder yang sama dengan aplikasi ini. ' - {$else} - + 'Hidupkan "LogMemoryLeakDetailToFile" untuk mendapatkan file log yang berisi perincian kebocoran memori. ' - {$endif} - {$else} - + 'Untuk mendapatkan file log yang berisi perincian kebocoran memori, hidupkan definisi kondisional "FullDebugMode" dan "LogMemoryLeakDetailToFile". ' - {$endif} - + 'Untuk mematikan pemeriksaan kebocoran, jangan definisikan "EnableMemoryLeakReporting".'#13#10 -{$endif} - + #0; - LeakMessageTitle = 'Kebocoran Memori Terdeteksi'; -{$ifdef UseOutputDebugString} - FastMMInstallMsg = 'FastMM sudah diinstalasi.'; - FastMMInstallSharedMsg = 'Membagi instan FastMM yang sudah ada.'; - FastMMUninstallMsg = 'FastMM sudah di deinstalasi.'; - FastMMUninstallSharedMsg = 'Pembagian instan FastMM yang ada dihentikan.'; -{$endif} -{$ifdef DetectMMOperationsAfterUninstall} - InvalidOperationTitle = 'Operasi MM setelah deinstalasi.'; - InvalidGetMemMsg = 'FastMM mendeteksi pemanggilan GetMem setelah FastMM di deinstalasi.'; - InvalidFreeMemMsg = 'FastMM mendeteksi pemanggilan FreeMem setelah FastMM di deinstalasi.'; - InvalidReallocMemMsg = 'FastMM mendeteksi pemanggilan ReallocMem setelah FastMM di deinstalasi.'; - InvalidAllocMemMsg = 'FastMM mendeteksi pemanggilan ReallocMem setelah FastMM di deinstalasi.'; -{$endif} - -implementation - -end. - diff --git a/components/fastmm/Translations/Italian/FastMM4Messages.pas b/components/fastmm/Translations/Italian/FastMM4Messages.pas deleted file mode 100644 index 7c4809b..0000000 --- a/components/fastmm/Translations/Italian/FastMM4Messages.pas +++ /dev/null @@ -1,140 +0,0 @@ -{ - -Fast Memory Manager: Messages - -Italian translation by Luigi D. Sandon. - -} - -unit FastMM4Messages; - -interface - -{$Include FastMM4Options.inc} - -const - {The name of the debug info support DLL} - FullDebugModeLibraryName = 'FastMM_FullDebugMode.dll'; - {Event log strings} - LogFileExtension = '_MemoryManager_EventLog.txt'#0; - CRLF = #13#10; - EventSeparator = '--------------------------------'; - {Class name messages} - UnknownClassNameMsg = 'Sconosciuta'; - {Stack trace Message} - CurrentStackTraceMsg = #13#10#13#10'La trama di stack corrente che ha condotto a questo errore (indirizzi di ritorno): '; - {Memory dump message} - MemoryDumpMsg = #13#10#13#10'Dump della memoria di 256 byte partendo dall''indirizzo del puntatore '; - {Block Error Messages} - BlockScanLogHeader = 'Blocco allocato registrato da LogAllocatedBlocksToFile. La dimensione : '; - ErrorMsgHeader = 'FastMM ha rilevato un errore durante '; - GetMemMsg = 'GetMem'; - FreeMemMsg = 'FreeMem'; - ReallocMemMsg = 'ReallocMem'; - BlockCheckMsg = 'scansione blocco libero'; - OperationMsg = ' operazione. '; - BlockHeaderCorruptedMsg = 'L''intestazione del blocco stata corrotta. '; - BlockFooterCorruptedMsg = 'Il terminatore del blocco stato corrotto. '; - FreeModifiedErrorMsg = 'FastMM ha rilevato che un blocco stato modificato dopo essere stato disallocato. '; - DoubleFreeErrorMsg = 'Tentativo di disallocare/reallocare un blocco non allocato.'; - PreviousBlockSizeMsg = #13#10#13#10'La dimensione precedente del blocco era: '; - CurrentBlockSizeMsg = #13#10#13#10'La dimensione del blocco : '; - StackTraceAtPrevAllocMsg = #13#10#13#10'Trama di stack quando il blocco stato precedentemente allocato (indirizzi di ritorno):'; - StackTraceAtAllocMsg = #13#10#13#10'Trama di stack quando il blocco stato allocato (indirizzi di ritorno):'; - PreviousObjectClassMsg = #13#10#13#10'Il blocco stato usato in precedenza per una istanza della classe: '; - CurrentObjectClassMsg = #13#10#13#10'Il blocco attualmente usato da una istanza della classe: '; - PreviousAllocationGroupMsg = #13#10#13#10'Il gruppo di allocazione era: '; - PreviousAllocationNumberMsg = #13#10#13#10'Il numero di allocazione era: '; - CurrentAllocationGroupMsg = #13#10#13#10'Il gruppo di allocazione : '; - CurrentAllocationNumberMsg = #13#10#13#10'Il numero di allocazione : '; - StackTraceAtFreeMsg = #13#10#13#10'Trama di stack quando il blocco stato precedentemente deallocato (indirizzi di ritorno):'; - BlockErrorMsgTitle = 'Rilevato Errore di Memoria'; - {Virtual Method Called On Freed Object Errors} - StandardVirtualMethodNames: array[1 + vmtParent div 4 .. -1] of PChar = ( - 'SafeCallException', - 'AfterConstruction', - 'BeforeDestruction', - 'Dispatch', - 'DefaultHandler', - 'NewInstance', - 'FreeInstance', - 'Destroy'); - VirtualMethodErrorHeader = 'FastMM ha rilevato un tentativo di chiamare un metodo virtuale di una istanza deallocata. Sar generata una eccezione di Violazione di Accesso per abortire l''operazione corrente.'; - InterfaceErrorHeader = 'FastMM ha rilevato un tentativo di usare una interfaccia di una istanza deallocata. Sar generata una eccezione di Violazione di Accesso per abortire l''operazione corrente.'; - BlockHeaderCorruptedNoHistoryMsg = ' Sfortunametamente l''intestazione del blocco stata corrotta, quindi non disponibile alcuna storia.'; - FreedObjectClassMsg = #13#10#13#10'Deallocata istanza della classe: '; - VirtualMethodName = #13#10#13#10'Metodo virtuale: '; - VirtualMethodOffset = 'Offset +'; - VirtualMethodAddress = #13#10#13#10'Indirizzo metodo virtuale: '; - StackTraceAtObjectAllocMsg = #13#10#13#10'Trama di stack quando l''istanza stata allocata (indirizzi di ritorno):'; - StackTraceAtObjectFreeMsg = #13#10#13#10'Trana di stack quando l''oggetto stato in seguito deallocato (indirizzi di ritorno):'; - {Installation Messages} - AlreadyInstalledMsg = 'FastMM4 gi installato.'; - AlreadyInstalledTitle = 'Gi installato.'; - OtherMMInstalledMsg = 'FastMM4 non pu essere installato perch un altro gestore della memoria ' - + 'ha gi installato s stesso.'#13#10'Se volete usare FastMM4, ' - + 'assicuratevi che FastMM4.pas sia la prima unit nella sezione "uses"' - + #13#10'del file .dpr del vostro progetto.'; - OtherMMInstalledTitle = 'Impossibile installare FastMM4 - un altro gestore della memoria gi installato'; - MemoryAllocatedMsg = - 'FastMM4 non pu essere installato perch della memoria gi ' + - 'stata allocata dal gestore della memoria di default.'#13#10 + - 'FastMM4.pas DEVE essere la prima unit nel file .dpr del progetto, ' + - 'altrimenti la memoria pu essere allocata dal gestore di default ' + - 'prima che FastMM4 ottenga il controllo.'#13#10#13#10 + - 'Se state usando un gestore delle eccezioni come MadExcept (o qualsiasi ' + - 'altro tool che modifichi l''ordine di inizializzazione delle unit), ' + - 'configurarlo in modo che la unit FastMM4.pas sia inizializzata prima di qualsiasi altra.'; - MemoryAllocatedTitle = 'Impossibile installare FastMM4 - La memoria gi stata allocata'; - {Leak checking messages} - LeakLogHeader = 'Leak di un blocco. La dimensione : '; - LeakMessageHeader = 'L''applicazione ha dei leak di memoria. '; - SmallLeakDetail = 'I leak di piccoli blocchi sono' -{$ifdef HideExpectedLeaksRegisteredByPointer} - + ' (sono esclusi i leak attesi registrati da puntatori)' -{$endif} - + ':'#13#10; - LargeLeakDetail = 'Le dimensioni dei leak di blocchi medi e grandi sono' -{$ifdef HideExpectedLeaksRegisteredByPointer} - + ' (sono esclusi i leak attesi registrati da puntatori)' -{$endif} - + ': '; - BytesMessage = ' byte: '; - StringBlockMessage = 'String'; - LeakMessageFooter = #13#10 -{$ifndef HideMemoryLeakHintMessage} - + #13#10'Nota: ' - {$ifdef RequireIDEPresenceForLeakReporting} - + 'Questi controlli di leak della memoria sono effettuati solo se Delphi in funzione sullo stesso computer. ' - {$endif} - {$ifdef FullDebugMode} - {$ifdef LogMemoryLeakDetailToFile} - + 'I dettagli sui leak della memoria sono registrati in un file di testo nella stessa cartella di questa applicazione. ' - {$else} - + 'Abilitare "LogMemoryLeakDetailToFile" per ottenere un file di log contenente i dettagli sui leak della memoria. ' - {$endif} - {$else} - + 'Per ottenere un file di log contenente i dettagli sui leak della memoria, abilitate le direttive condizionali "FullDebugMode" e "LogMemoryLeakDetailToFile". ' - {$endif} - + 'Per disabilitare i controlli dei leak della memoria, non definire la direttiva "EnableMemoryLeakReporting".'#13#10 -{$endif} - + #0; - LeakMessageTitle = 'Rilevato leak della memoria'; -{$ifdef UseOutputDebugString} - FastMMInstallMsg = 'FastMM stato installato.'; - FastMMInstallSharedMsg = 'Inizio condivisione di una istanza esistente di FastMM.'; - FastMMUninstallMsg = 'FastMM stato disinstallato.'; - FastMMUninstallSharedMsg = 'Termine della condivisione di una istanza esistente di FastMM.'; -{$endif} -{$ifdef DetectMMOperationsAfterUninstall} - InvalidOperationTitle = 'MM operazione dopo la disinstallazione.'; - InvalidGetMemMsg = 'FastMM ha rilevato una chiamata a GetMem dopo che FastMM stato disinstallato.'; - InvalidFreeMemMsg = 'FastMM ha rilevato una chiamata a FreeMem dopo che FastMM stato disinstallato.'; - InvalidReallocMemMsg = 'FastMM ha rilevato una chiamata a ReallocMem dopo che FastMM stato disinstallato.'; - InvalidAllocMemMsg = 'FastMM ha rilevato una chiamata ad AllocMem dopo che FastMM stato disinstallato.'; -{$endif} - -implementation - -end. - diff --git a/components/fastmm/Translations/Polish/FastMM4Messages.pas b/components/fastmm/Translations/Polish/FastMM4Messages.pas deleted file mode 100644 index c89490d..0000000 --- a/components/fastmm/Translations/Polish/FastMM4Messages.pas +++ /dev/null @@ -1,138 +0,0 @@ -{ - -Fast Memory Manager: Messages - -Polish translation by Artur Redko (arturr@opegieka.pl). - -} - -unit FastMM4Messages; - -interface - -{$Include FastMM4Options.inc} - -const - {The name of the debug info support DLL} - FullDebugModeLibraryName = 'FastMM_FullDebugMode.dll'; - {Event log strings} - LogFileExtension = '_MemoryManager_raport.txt'#0; - CRLF = #13#10; - EventSeparator = '--------------------------------'; - {Class name messages} - UnknownClassNameMsg = 'Nieznany'; - {Stack trace Message} - CurrentStackTraceMsg = #13#10#13#10'Aktualny lad stosu prowadzi do tego bdu (zwraca adresy): '; - {Memory dump message} - MemoryDumpMsg = #13#10#13#10'Aktualny zrzut pamici 256 bajtw zaczynajcy si od adresu '; - {Block Error Messages} - BlockScanLogHeader = 'Zaalokowany blok zapisany przez LogAllocatedBlocksToFile. Rozmiar : '; - ErrorMsgHeader = 'FastMM wykry bd podczas operacji '; - GetMemMsg = 'GetMem'; - FreeMemMsg = 'FreeMem'; - ReallocMemMsg = 'ReallocMem'; - BlockCheckMsg = 'skanowania wolnego bloku'; - OperationMsg = '. '; - BlockHeaderCorruptedMsg = 'Nagwek bloku jest uszkodzony. '; - BlockFooterCorruptedMsg = 'Stopka bloku jest uszkodzona. '; - FreeModifiedErrorMsg = 'FastMM wykry e blok zosta zmodyfikowany po tym jak zosta zwolniony. '; - DoubleFreeErrorMsg = 'Wykryto prb zwolnienia/realokacji niezaalokowanego bloku.'; - PreviousBlockSizeMsg = #13#10#13#10'Poprzedni rozmiar bloku by: '; - CurrentBlockSizeMsg = #13#10#13#10'Rozmiar bloku jest: '; - StackTraceAtPrevAllocMsg = #13#10#13#10'lad stosu kiedy ten blok by poprzednio zaalokowany (zwraca adresy):'; - StackTraceAtAllocMsg = #13#10#13#10'lad stosu kiedy ten blok by zaalokowany (zwraca adresy):'; - PreviousObjectClassMsg = #13#10#13#10'Blok zosta poprzednio uyty w obiekcie klasy: '; - CurrentObjectClassMsg = #13#10#13#10'Blok jest aktualnie uywany w obiekcie klasy: '; - PreviousAllocationGroupMsg = #13#10#13#10'Bya grupa alokacji : '; - PreviousAllocationNumberMsg = #13#10#13#10'Bya ilo alokacji : '; - CurrentAllocationGroupMsg = #13#10#13#10'Jest grupa alokacji : '; - CurrentAllocationNumberMsg = #13#10#13#10'Jest ilo alokacji : '; - StackTraceAtFreeMsg = #13#10#13#10'lad stosu kiedy ten blok by poprzednio zwolniony (zwraca adresy):'; - BlockErrorMsgTitle = 'Wykryto bd pamici'; - {Virtual Method Called On Freed Object Errors} - StandardVirtualMethodNames: array[1 + vmtParent div 4 .. -1] of PChar = ( - 'SafeCallException', - 'AfterConstruction', - 'BeforeDestruction', - 'Dispatch', - 'DefaultHandler', - 'NewInstance', - 'FreeInstance', - 'Destroy'); - VirtualMethodErrorHeader = 'FastMM wykry prb uycia wirtualnej metody zwolnionego obiektu. Zostanie wygenerowany teraz wyjtek w celu przerwania aktualnej operacji.'; - InterfaceErrorHeader = 'FastMM wykry prb uycia interfejsu zwolnionego obiektu. Zostanie wygenerowany teraz wyjtek w celu przerwania aktualnej operacji.'; - BlockHeaderCorruptedNoHistoryMsg = ' Niestety nagwek bloku zosta uszkodzony wic historia nie jest dostpna.'; - FreedObjectClassMsg = #13#10#13#10'Klasa zwolnionego obiektu: '; - VirtualMethodName = #13#10#13#10'Metoda wirtualna: '; - VirtualMethodOffset = 'przesunicie +'; - VirtualMethodAddress = #13#10#13#10'Adres metody wirtualnej: '; - StackTraceAtObjectAllocMsg = #13#10#13#10'lad stosu kiedy obiekt zosta zaalokowany (zwraca adresy):'; - StackTraceAtObjectFreeMsg = #13#10#13#10'lad stosu kiedy obiekt zosta pniej zwolniony (zwraca adresy):'; - {Installation Messages} - AlreadyInstalledMsg = 'FastMM4 jest ju zainstalowany.'; - AlreadyInstalledTitle = 'Ju zainstalowany.'; - OtherMMInstalledMsg = 'FastMM4 nie moe by zainstalowany poniewa inny meneder pamici ' - + 'zosta ju zainstalowany.'#13#10'Jeli chcesz uy FastMM4, ' - + 'zapewniajc aby modu FastMM4.pas by zainicjowany jako pierwszy modu w twoim projekcie.'; - OtherMMInstalledTitle = 'Nie mona zainstalowa FastMM4 - inny meneder pamici jest ju zainstalowany'; - MemoryAllocatedMsg = 'FastMM4 nie moe by zainstalowany poniewa pami zostaa ' - + 'juz zaalokowana przez domylny meneder pamici.'#13#10'FastMM4.pas MUSI ' - + 'by pierwszym moduem w twoim projekcie, w przeciwnym wypadku pami moe ' - + 'by zaalokowana'#13#10'przez domylny meneder pamici zanim FastMM4 ' - + 'przejmie kontrol.'#13#10#13#10'Jeli uywasz aplikacji do przechwytywania wyjtkw ' - + 'takich jak MadExcept,'#13#10'zmie jego konfiguracj zapewniajc aby modu ' - + 'FastMM4.pas by zainicjowany jako pierwszy modu.'; - MemoryAllocatedTitle = 'Nie mona zainstalowa FastMM4 - pami zostaa ju zaalokowana.' - + 'FastMM4.pas jest inicjowany jako pierwszy modu.'; - {Leak checking messages} - LeakLogHeader = 'Wyciek blok pamici. Rozmiar wynosi: '; - LeakMessageHeader = 'Aplikacja wykrya wycieki pamici. '; - SmallLeakDetail = 'Mae bloki wyciekw s' -{$ifdef HideExpectedLeaksRegisteredByPointer} - + ' (wyczajc oczekiwane wycieki zarejestrowane przez wskanik)' -{$endif} - + ':'#13#10; - LargeLeakDetail = 'Rozmiary rednich i duych wyciekw wynosz' -{$ifdef HideExpectedLeaksRegisteredByPointer} - + ' (wyczajc oczekiwane wycieki zarejestrowane przez wskanik)' -{$endif} - + ': '; - BytesMessage = ' bajtw: '; - StringBlockMessage = 'String'; - LeakMessageFooter = #13#10 -{$ifndef HideMemoryLeakHintMessage} - + #13#10'Uwaga: ' - {$ifdef RequireIDEPresenceForLeakReporting} - + 'Sprawdzenie wyciekw pamici wystpuje tylko gdy Delphi jest uruchomione na tym samych komputerze. ' - {$endif} - {$ifdef FullDebugMode} - {$ifdef LogMemoryLeakDetailToFile} - + 'Szczegy wyciekw s rejestrowane w pliku tekstowym w tym samym katalogu co aplikacja. ' - {$else} - + 'Wcz "LogMemoryLeakDetailToFile" aby uzyska szczegowy plik z wyciekami pamici. ' - {$endif} - {$else} - + 'Aby uzyska plik ze szczegami wyciekw pamici, wcz definicje warunkowe "FullDebugMode" i "LogMemoryLeakDetailToFile". ' - {$endif} - + 'Aby wyczy raportowanie wyciekw, wycz "EnableMemoryLeakReporting".'#13#10 -{$endif} - + #0; - LeakMessageTitle = 'Wykryto wyciek pamici'; -{$ifdef UseOutputDebugString} - FastMMInstallMsg = 'FastMM zosta zainstalowany.'; - FastMMInstallSharedMsg = 'Rozpoczcie wspdzielenia istniejcej instancji FastMM.'; - FastMMUninstallMsg = 'FastMM zosta odinstalowany.'; - FastMMUninstallSharedMsg = 'Zakoczenie wspdzielenia istniejcej instancji FastMM.'; -{$endif} -{$ifdef DetectMMOperationsAfterUninstall} - InvalidOperationTitle = 'Operacja MM po deinstalacji.'; - InvalidGetMemMsg = 'FastMM wykry wywoanie GetMem po tym jak FastMM zosta odinstalowany.'; - InvalidFreeMemMsg = 'FastMM wykry wywoanie FreeMem po tym jak FastMM zosta odinstalowany.'; - InvalidReallocMemMsg = 'FastMM wykry wywoanie ReallocMem po tym jak FastMM zosta odinstalowany.'; - InvalidAllocMemMsg = 'FastMM wykry wywoanie AllocMem po tym jak FastMM zosta odinstalowany.'; -{$endif} - -implementation - -end. - diff --git a/components/fastmm/Translations/Portuguese (Brazil)/FastMM4Messages.pas b/components/fastmm/Translations/Portuguese (Brazil)/FastMM4Messages.pas deleted file mode 100644 index 138305a..0000000 --- a/components/fastmm/Translations/Portuguese (Brazil)/FastMM4Messages.pas +++ /dev/null @@ -1,139 +0,0 @@ -{ - -Fast Memory Manager: Messages - -Portuguese (Brazil) translation by Johni Jeferson Capeletto (capeletto@gmail.com) - Love you Julia. - -} - -unit FastMM4Messages; - -interface - -{$Include FastMM4Options.inc} - -const - {The name of the debug info support DLL} - FullDebugModeLibraryName = 'FastMM_FullDebugMode.dll'; - {Event log strings} - LogFileExtension = '_MemoryManager_EventosLog.txt'#0; - CRLF = #13#10; - EventSeparator = '--------------------------------'; - {Class name messages} - UnknownClassNameMsg = 'Desconhecida'; - {Stack trace Message} - CurrentStackTraceMsg = #13#10#13#10'A pilha atual que leva a esse erro (endereos de retorno): '; - {Memory dump message} - MemoryDumpMsg = #13#10#13#10'Dump de memria atual de 256 bytes iniciando no endereo '; - {Block Error Messages} - BlockScanLogHeader = 'Bloco alocado logado por LogAllocatedBlocksToFile. O tamanho : '; - ErrorMsgHeader = 'FastMM detectou um erro durante '; - GetMemMsg = 'GetMem'; - FreeMemMsg = 'FreeMem'; - ReallocMemMsg = 'ReallocMem'; - BlockCheckMsg = 'busca de bloco livre'; - OperationMsg = ' operao. '; - BlockHeaderCorruptedMsg = 'O cabealho do bloco foi corrompido. '; - BlockFooterCorruptedMsg = 'O rodap do bloco foi corrompido. '; - FreeModifiedErrorMsg = 'FastMM detectou que um bloco foi modificado aps ter sido liberado. '; - DoubleFreeErrorMsg = 'Uma tentativa foi feita para liberar/realocar um bloco no alocado.'; - PreviousBlockSizeMsg = #13#10#13#10'O tamanho anterior do bloco era: '; - CurrentBlockSizeMsg = #13#10#13#10'O tamanho do bloco : '; - StackTraceAtPrevAllocMsg = #13#10#13#10'Caminho da pilha quando esse bloco foi alocado anteriormente (endereos de retorno):'; - StackTraceAtAllocMsg = #13#10#13#10'Caminho da pilha quando esse bloco foi alocado (endereos de retorno):'; - PreviousObjectClassMsg = #13#10#13#10'O bloco foi usado anteriormente por um objeto da classe: '; - CurrentObjectClassMsg = #13#10#13#10'O bloco est sendo usado por um objeto da classe: '; - PreviousAllocationGroupMsg = #13#10#13#10'O grupo de alocao era: '; - PreviousAllocationNumberMsg = #13#10#13#10'O nmero da alocao era: '; - CurrentAllocationGroupMsg = #13#10#13#10'O grupo de alocao : '; - CurrentAllocationNumberMsg = #13#10#13#10'O nmero da alocao : '; - StackTraceAtFreeMsg = #13#10#13#10'Caminho da pilha quando o bloco foi liberado anteriormente (endereos de retorno):'; - BlockErrorMsgTitle = 'Erro de memria detectado'; - {Virtual Method Called On Freed Object Errors} - StandardVirtualMethodNames: array[1 + vmtParent div 4 .. -1] of PChar = ( - 'SafeCallException', - 'AfterConstruction', - 'BeforeDestruction', - 'Dispatch', - 'DefaultHandler', - 'NewInstance', - 'FreeInstance', - 'Destroy'); - VirtualMethodErrorHeader = 'FastMM detectou uma tentativa de chamada a um mtodo virtual de um objeto liberado. Uma violao de acesso ser disparada para abortar a operao corrente.'; - InterfaceErrorHeader = 'FastMM detectou uma tentativa de uso de uma interface de um objeto liberado. Uma violao de acesso ser disparada para abortar a operao corrente.'; - BlockHeaderCorruptedNoHistoryMsg = ' Infelizmente o cabealho do bloco foi corrompido e a histria no est disponvel.'; - FreedObjectClassMsg = #13#10#13#10'Classe do objeto liberado: '; - VirtualMethodName = #13#10#13#10'Mtodo virtual: '; - VirtualMethodOffset = 'Offset +'; - VirtualMethodAddress = #13#10#13#10'Endereo do mtodo virtual: '; - StackTraceAtObjectAllocMsg = #13#10#13#10'Caminho da pilha quando o objeto foi alocado (endereos de retorno):'; - StackTraceAtObjectFreeMsg = #13#10#13#10'Caminho da pilha quando o objeto foi liberado (endereos de retorno):'; - {Installation Messages} - AlreadyInstalledMsg = 'FastMM4 j foi instalado.'; - AlreadyInstalledTitle = 'J foi instalado.'; - OtherMMInstalledMsg = 'FastMM4 no pode ser instalado j que outro gerenciador externo ' - + 'de memria j foi instalado.'#13#10'Se voc quer usar o FastMM4, ' - + 'tenha certeza que a unit FastMM4.pas seja a primeira na seo "uses"' - + #13#10'do arquivo .dpr do seu projeto.'; - OtherMMInstalledTitle = 'Impossvel instalar FastMM4 - Outro gerenciador de memria j est instalado'; - MemoryAllocatedMsg = 'O FastMM4 no pode ser instalado j que a memria j foi ' - + 'alocada atravs do gerenciador de memria padro.'#13#10'FastMM4.pas DEVE ' - + 'ser a primeira unit no arquivo .dpr do seu projeto, caso contrrio a memria pode ' - + 'ser alocada'#13#10'atravs do gerenciador de memria padro antes que o FastMM ' - + 'ganhe o controle. '#13#10#13#10'Se voc estiver usando um interceptador de excees ' - + 'como MadExcept (ou qualquer outra ferramenta que modifica a ordem de inicializao da ' - + 'unit),'#13#10'v para sua pgina de configurao e tenha certeza que a unit ' - + 'FastMM4.pas seja inicializada antes de qualquer outra unit.'; - MemoryAllocatedTitle = 'Impossvel instalar FastMM4 - A memria j foi alocada'; - {Leak checking messages} - LeakLogHeader = 'Um bloco de memria vazou. O tamanho : '; - LeakMessageHeader = 'Essa aplicao teve vazamentos de memria. '; - SmallLeakDetail = 'Os vazamentos dos blocos pequenos so' -{$ifdef HideExpectedLeaksRegisteredByPointer} - + ' (excluindo os vazamentos esperados registrados por ponteiro)' -{$endif} - + ':'#13#10; - LargeLeakDetail = 'O tamanho dos vazamentos dos blocos mdios e grandes so' -{$ifdef HideExpectedLeaksRegisteredByPointer} - + ' (excluindo os vazamentos esperados registrados por ponteiro)' -{$endif} - + ': '; - BytesMessage = ' bytes: '; - StringBlockMessage = 'String'; - LeakMessageFooter = #13#10 -{$ifndef HideMemoryLeakHintMessage} - + #13#10'Nota: ' - {$ifdef RequireIDEPresenceForLeakReporting} - + 'Essa checagem de vazamento de memria somente feita se o Delphi est rodando atualmente no mesmo computador. ' - {$endif} - {$ifdef FullDebugMode} - {$ifdef LogMemoryLeakDetailToFile} - + 'O detalhe do vazamento de memria est logado em um arquivo texto na mesma pasta que essa aplicao. ' - {$else} - + 'Habilite o DEFINE "LogMemoryLeakDetailToFile" para obter um arquivo de log contendo detalhes dos vazamentos de memria. ' - {$endif} - {$else} - + 'Para obter um arquivo de log contendo detalhes dos vazamentos de memria, habilite os DEFINES "FullDebugMode" e "LogMemoryLeakDetailToFile". ' - {$endif} - + 'Para desabilitar essa checagem de vazamento de memria, desabilite o DEFINE "EnableMemoryLeakReporting".'#13#10 -{$endif} - + #0; - LeakMessageTitle = 'Vazamento de memria detectado'; -{$ifdef UseOutputDebugString} - FastMMInstallMsg = 'FastMM foi instalado.'; - FastMMInstallSharedMsg = 'Compartilhando uma instancia existente do FastMM.'; - FastMMUninstallMsg = 'FastMM foi desinstalado.'; - FastMMUninstallSharedMsg = 'Parando de compartilhar uma instancia existente do FastMM.'; -{$endif} -{$ifdef DetectMMOperationsAfterUninstall} - InvalidOperationTitle = 'Operao no Gerenciador de Memria aps desinstalao.'; - InvalidGetMemMsg = 'FastMM detectou uma chamada GetMem depois que o FastMM foi desinstalado.'; - InvalidFreeMemMsg = 'FastMM detectou uma chamada FreeMem depois que o FastMM foi desinstalado.'; - InvalidReallocMemMsg = 'FastMM detectou uma chamada ReallocMem depois que o FastMM foi desinstalado.'; - InvalidAllocMemMsg = 'FastMM detectou uma chamada ReallocMem depois que o FastMM foi desinstalado.'; -{$endif} - -implementation - -end. - diff --git a/components/fastmm/Translations/Portuguese/FastMM4Messages.pas b/components/fastmm/Translations/Portuguese/FastMM4Messages.pas deleted file mode 100644 index c95f062..0000000 --- a/components/fastmm/Translations/Portuguese/FastMM4Messages.pas +++ /dev/null @@ -1,139 +0,0 @@ -{ - -Fast Memory Manager: Messages - -Portuguese translation by Carlos Mao (Carlos.Macao@gmail.com). - -} - -unit FastMM4Messages; - -interface - -{$Include FastMM4Options.inc} - -const - {The name of the debug info support DLL} - FullDebugModeLibraryName = 'FastMM_FullDebugMode.dll'; - {Event log strings} - LogFileExtension = '_MemoryManager_EventosLog.txt'#0; - CRLF = #13#10; - EventSeparator = '--------------------------------'; - {Class name messages} - UnknownClassNameMsg = 'Desconhecida'; - {Stack trace Message} - CurrentStackTraceMsg = #13#10#13#10'Registo do Stack actual que leva a esse erro (endereos de retorno): '; - {Memory dump message} - MemoryDumpMsg = #13#10#13#10'O Dump de memria actual de 256 bytes tem inicio no endereo '; - {Block Error Messages} - BlockScanLogHeader = 'Bloco atribudo registado por LogAllocatedBlocksToFile. O Tamanho : '; - ErrorMsgHeader = 'FastMM detectou um erro durante '; - GetMemMsg = 'GetMem'; - FreeMemMsg = 'FreeMem'; - ReallocMemMsg = 'ReallocMem'; - BlockCheckMsg = 'procura de bloco livre'; - OperationMsg = ' operao. '; - BlockHeaderCorruptedMsg = 'O cabealho do bloco foi corrompido. '; - BlockFooterCorruptedMsg = 'O rodap do bloco foi corrompido. '; - FreeModifiedErrorMsg = 'FastMM detectou que um bloco de memria foi modificado aps ter sido libertado. '; - DoubleFreeErrorMsg = 'Foi feita uma tentativa para libertar/atribuir um bloco no atribuido.'; - PreviousBlockSizeMsg = #13#10#13#10'O tamanho anterior do bloco era: '; - CurrentBlockSizeMsg = #13#10#13#10'O tamanho do bloco : '; - StackTraceAtPrevAllocMsg = #13#10#13#10'Registo do Stack quando esse bloco foi atribuido anteriormente (endereos de retorno):'; - StackTraceAtAllocMsg = #13#10#13#10'Registo do Stack quando esse bloco foi atribuido (endereos de retorno):'; - PreviousObjectClassMsg = #13#10#13#10'O bloco foi usado anteriormente por um objecto da classe: '; - CurrentObjectClassMsg = #13#10#13#10'O bloco est sendo usado por um objecto da classe: '; - PreviousAllocationGroupMsg = #13#10#13#10'O grupo de atribuio era: '; - PreviousAllocationNumberMsg = #13#10#13#10'O nmero de atribuio era: '; - CurrentAllocationGroupMsg = #13#10#13#10'O grupo de atribuio : '; - CurrentAllocationNumberMsg = #13#10#13#10'O nmero de atribuio era: '; - StackTraceAtFreeMsg = #13#10#13#10'Registo do Stack quando o bloco foi libertado anteriormente (endereos de retorno):'; - BlockErrorMsgTitle = 'Erro de memria detectado'; - {Virtual Method Called On Freed Object Errors} - StandardVirtualMethodNames: array[1 + vmtParent div 4 .. -1] of PChar = ( - 'SafeCallException', - 'AfterConstruction', - 'BeforeDestruction', - 'Dispatch', - 'DefaultHandler', - 'NewInstance', - 'FreeInstance', - 'Destroy'); - VirtualMethodErrorHeader = 'FastMM detectou uma tentativa de chamada a um mtodo virtual de um objecto libertado. Uma violao de acesso ser iniciada para abortar a operao corrente.'; - InterfaceErrorHeader = 'FastMM detectou uma tentativa de uso de uma interface de um objecto libertado. Uma violao de acesso ser iniciada para abortar a operao corrente.'; - BlockHeaderCorruptedNoHistoryMsg = ' Infelizmente o cabealho do bloco foi corrompido e o histrico no est disponvel.'; - FreedObjectClassMsg = #13#10#13#10'Classe do objecto libertado: '; - VirtualMethodName = #13#10#13#10'Mtodo virtual: '; - VirtualMethodOffset = 'Deslocamento +'; - VirtualMethodAddress = #13#10#13#10'Endereo do mtodo virtual: '; - StackTraceAtObjectAllocMsg = #13#10#13#10'Registo do Stack quando o objecto foi atribuido (endereos de retorno):'; - StackTraceAtObjectFreeMsg = #13#10#13#10'Registo do Stack quando o objecto foi libertado (endereos de retorno):'; - {Installation Messages} - AlreadyInstalledMsg = 'FastMM4 j se encontra instalado.'; - AlreadyInstalledTitle = 'J se encontra instalado.'; - OtherMMInstalledMsg = 'FastMM4 no pde ser instalado j que outro gestor ' - + 'de memria externo j foi instalado.'#13#10'Se voc quer usar o FastMM4, ' - + 'garanta que a unit FastMM4.pas a primeira na seco "uses"' - + #13#10'do ficheiro .dpr do seu projecto.'; - OtherMMInstalledTitle = 'Impossvel instalar FastMM4 - Outro gestor de memria j se encontra instalado'; - MemoryAllocatedMsg = 'O FastMM4 no pode ser instalado j que a memria j foi ' - + 'atribuida atravs do gestor de memria padro.'#13#10'FastMM4.pas DEVE ' - + 'ser a primeira unit no arquivo .dpr do seu projecto, caso contrrio a memria pode ' - + 'ser atribuida'#13#10'atravs do gestor de memria padro antes que o FastMM ' - + 'obtenha o controle. '#13#10#13#10'Se voc estiver usando um interceptador de excepes ' - + 'como MadExcept (ou qualquer outra ferramenta que modifica a ordem de inicializao da ' - + 'unit),'#13#10'v para sua pgina de configurao e assegure-se que a unit ' - + 'FastMM4.pas '' inicializada antes de qualquer outra unit.'; - MemoryAllocatedTitle = 'Impossvel instalar FastMM4 - A memria j foi atribuida'; - {Leak checking messages} - LeakLogHeader = 'Um bloco de memria no foi libertado. O tamanho : '; - LeakMessageHeader = 'Esta aplicao teve fugas de memria. '; - SmallLeakDetail = 'As fugas dos blocos pequenos so' -{$ifdef HideExpectedLeaksRegisteredByPointer} - + ' (excluindo as fugas esperadas, registadas por ponteiro)' -{$endif} - + ':'#13#10; - LargeLeakDetail = 'O tamanho das fugas dos blocos mdios e grandes ' -{$ifdef HideExpectedLeaksRegisteredByPointer} - + ' (excluindo as fugas esperadas registadas por ponteiro)' -{$endif} - + ': '; - BytesMessage = ' bytes: '; - StringBlockMessage = 'String'; - LeakMessageFooter = #13#10 -{$ifndef HideMemoryLeakHintMessage} - + #13#10'Nota: ' - {$ifdef RequireIDEPresenceForLeakReporting} - + 'Os testes de fugas de memria s sero efectuados se o Delphi estiver activo no mesmo computador. ' - {$endif} - {$ifdef FullDebugMode} - {$ifdef LogMemoryLeakDetailToFile} - + 'O detalhe da fuga de memria foi registado num ficheiro de texto na mesma pasta desta aplicao. ' - {$else} - + 'Active o DEFINE "LogMemoryLeakDetailToFile" para obter um ficheiro de registos contendo detalhes das fugas de memria. ' - {$endif} - {$else} - + 'Para obter um ficheiro de registo contendo detalhes das fugas de memria, active os DEFINES "FullDebugMode" e "LogMemoryLeakDetailToFile". ' - {$endif} - + 'Para activar a deteco de fugas de memria, active o DEFINE "EnableMemoryLeakReporting".'#13#10 -{$endif} - + #0; - LeakMessageTitle = 'Fuga de memria detectada'; -{$ifdef UseOutputDebugString} - FastMMInstallMsg = 'FastMM foi instalado.'; - FastMMInstallSharedMsg = 'Partilhando uma instncia j existente do FastMM.'; - FastMMUninstallMsg = 'FastMM foi removido.'; - FastMMUninstallSharedMsg = 'Parando a partilha duma instncia existente do FastMM.'; -{$endif} -{$ifdef DetectMMOperationsAfterUninstall} - InvalidOperationTitle = 'Operao com o gestor de Memria aps a sua remoo.'; - InvalidGetMemMsg = 'FastMM detectou uma chamada a GetMem aps a remoo do FastMM.'; - InvalidFreeMemMsg = 'FastMM detectou uma chamada a FreeMem aps a remoo do FastMM.'; - InvalidReallocMemMsg = 'FastMM detectou uma chamada a ReallocMem aps a remoo do FastMM.'; - InvalidAllocMemMsg = 'FastMM detectou uma chamada a ReallocMem aps a remoo do FastMM.'; -{$endif} - -implementation - -end. - diff --git a/components/fastmm/Translations/Russian/FastMM4Messages.pas b/components/fastmm/Translations/Russian/FastMM4Messages.pas deleted file mode 100644 index 155b3f6..0000000 --- a/components/fastmm/Translations/Russian/FastMM4Messages.pas +++ /dev/null @@ -1,141 +0,0 @@ -{ - -Fast Memory Manager: Messages - -Russian translation by Paul Ishenin. - -2006-07-18 -Some minor updates by Andrey V. Shtukaturov. - -} - -unit FastMM4Messages; - -interface - -{$Include FastMM4Options.inc} - -const - {The name of the debug info support DLL} - FullDebugModeLibraryName = 'FastMM_FullDebugMode.dll'; - {Event log strings} - LogFileExtension = '_MemoryManager_EventLog.txt'#0; - CRLF = #13#10; - EventSeparator = '--------------------------------'; - {Class name messages} - UnknownClassNameMsg = 'Unknown'; - {Stack trace Message} - CurrentStackTraceMsg = #13#10#13#10' (): '; - {Memory dump message} - MemoryDumpMsg = #13#10#13#10' 256 '; - {Block Error Messages} - BlockScanLogHeader = ' LogAllocatedBlocksToFile. : '; - ErrorMsgHeader = 'FastMM '; - GetMemMsg = 'GetMem'; - FreeMemMsg = 'FreeMem'; - ReallocMemMsg = 'ReallocMem'; - BlockCheckMsg = ' '; - OperationMsg = ' . '; - BlockHeaderCorruptedMsg = ' . '; - BlockFooterCorruptedMsg = ' . '; - FreeModifiedErrorMsg = 'FastMM . '; - DoubleFreeErrorMsg = ' / .'; - PreviousBlockSizeMsg = #13#10#13#10' : '; - CurrentBlockSizeMsg = #13#10#13#10' : '; - StackTraceAtPrevAllocMsg = #13#10#13#10' ():'; - StackTraceAtAllocMsg = #13#10#13#10' ():'; - PreviousObjectClassMsg = #13#10#13#10' : '; - CurrentObjectClassMsg = #13#10#13#10' : '; - PreviousAllocationGroupMsg = #13#10#13#10' : '; - PreviousAllocationNumberMsg = #13#10#13#10' : '; - CurrentAllocationGroupMsg = #13#10#13#10' : '; - CurrentAllocationNumberMsg = #13#10#13#10' : '; - StackTraceAtFreeMsg = #13#10#13#10' ():'; - BlockErrorMsgTitle = ' .'; - {Virtual Method Called On Freed Object Errors} - StandardVirtualMethodNames: array[1 + vmtParent div 4 .. -1] of PChar = ( - 'SafeCallException', - 'AfterConstruction', - 'BeforeDestruction', - 'Dispatch', - 'DefaultHandler', - 'NewInstance', - 'FreeInstance', - 'Destroy'); - VirtualMethodErrorHeader = 'FastMM . .'; - InterfaceErrorHeader = 'FastMM . .'; - BlockHeaderCorruptedNoHistoryMsg = ' .'; - FreedObjectClassMsg = #13#10#13#10' : '; - VirtualMethodName = #13#10#13#10' : '; - VirtualMethodOffset = ' +'; - VirtualMethodAddress = #13#10#13#10' : '; - StackTraceAtObjectAllocMsg = #13#10#13#10' ():'; - StackTraceAtObjectFreeMsg = #13#10#13#10' ():'; - {Installation Messages} - AlreadyInstalledMsg = 'FastMM4 .'; - AlreadyInstalledTitle = ' .'; - OtherMMInstalledMsg = 'FastMM4 .' - + #13#10' FastMM4, FastMM4.pas ' - + #13#10' "uses" ''s .dpr .'; - OtherMMInstalledTitle = ' FastMM4 - .'; - MemoryAllocatedMsg = 'FastMM4 ' - + ' .'#13#10'FastMM4.pas ' - + ' .dpr , ' - + ' '#13#10' FastMM4 ' - + ' . '#13#10#13#10' ' - + ' MadExcept ( ' - + '),'#13#10' , ' - + 'FastMM4.pas .'; - MemoryAllocatedTitle = ' FastMM4 - '; - {Leak checking messages} - LeakLogHeader = ' . : '; - LeakMessageHeader = ' . '; - SmallLeakDetail = ' ' -{$ifdef HideExpectedLeaksRegisteredByPointer} - + ' ( )' -{$endif} - + ':'#13#10; - LargeLeakDetail = ' ' -{$ifdef HideExpectedLeaksRegisteredByPointer} - + ' ( )' -{$endif} - + ': '; - BytesMessage = ' : '; - StringBlockMessage = 'String'; - LeakMessageFooter = #13#10 -{$ifndef HideMemoryLeakHintMessage} - + #13#10'Note: ' - {$ifdef RequireIDEPresenceForLeakReporting} - + ' Delphi . ' - {$endif} - {$ifdef FullDebugMode} - {$ifdef LogMemoryLeakDetailToFile} - + ' , . ' - {$else} - + ' "LogMemoryLeakDetailToFile" , . ' - {$endif} - {$else} - + ' , , "FullDebugMode" "LogMemoryLeakDetailToFile". ' - {$endif} - + ' , "EnableMemoryLeakReporting".'#13#10 -{$endif} - + #0; - LeakMessageTitle = ' '; -{$ifdef UseOutputDebugString} - FastMMInstallMsg = 'FastMM has been installed.'; - FastMMInstallSharedMsg = 'Sharing an existing instance of FastMM.'; - FastMMUninstallMsg = 'FastMM has been uninstalled.'; - FastMMUninstallSharedMsg = 'Stopped sharing an existing instance of FastMM.'; -{$endif} -{$ifdef DetectMMOperationsAfterUninstall} - InvalidOperationTitle = 'MM Operation after uninstall.'; - InvalidGetMemMsg = 'FastMM has detected a GetMem call after FastMM was uninstalled.'; - InvalidFreeMemMsg = 'FastMM has detected a FreeMem call after FastMM was uninstalled.'; - InvalidReallocMemMsg = 'FastMM has detected a ReallocMem call after FastMM was uninstalled.'; - InvalidAllocMemMsg = 'FastMM has detected a ReallocMem call after FastMM was uninstalled.'; -{$endif} - -implementation - -end. - diff --git a/components/fastmm/Translations/Spanish/FastMM4Messages.pas b/components/fastmm/Translations/Spanish/FastMM4Messages.pas deleted file mode 100644 index 5897e6a..0000000 --- a/components/fastmm/Translations/Spanish/FastMM4Messages.pas +++ /dev/null @@ -1,147 +0,0 @@ -{ - -Fast Memory Manager: Messages - -Spanish translation by JRG (TheDelphiGuy@gmail.com). - -Change Log: - 15 Feb 2006: Updated by Marcelo Montenegro. - -} - -unit FastMM4Messages; - -interface - -{$Include FastMM4Options.inc} - -const - {The name of the debug info support DLL} - FullDebugModeLibraryName = 'FastMM_FullDebugMode.dll'; - {Event log strings} - LogFileExtension = '_ManipuladorMemoria_Reporte.txt'#0; - CRLF = #13#10; - EventSeparator = '--------------------------------'; - {Class name messages} - UnknownClassNameMsg = 'Desconocida'; - {Traza del stack Message} - CurrentStackTraceMsg = #13#10#13#10'Traza del stack que concluy en este error (direcciones de retorno): '; - {Memory dump message} - MemoryDumpMsg = #13#10#13#10'Vaciado de memoria actual de 256 bytes en la direccin '; - {Block Error Messages} - BlockScanLogHeader = 'Allocated block logged by LogAllocatedBlocksToFile. The size is: '; - ErrorMsgHeader = 'FastMM ha detectado un error durante una operacin '; - GetMemMsg = 'GetMem'; - FreeMemMsg = 'FreeMem'; - ReallocMemMsg = 'ReallocMem'; - BlockCheckMsg = 'de bsqueda de bloque libre'; - OperationMsg = '. '; - BlockHeaderCorruptedMsg = 'El encabezamiento de bloque ha sido corrompido. '; - BlockFooterCorruptedMsg = 'La terminacin de bloque ha sido corrompida. '; - FreeModifiedErrorMsg = 'FastMM detect que un bloque ha sido modificado luego de liberarse. '; - DoubleFreeErrorMsg = 'Se realiz un intento de liberar/reasignar un bloque no reservado.'; - PreviousBlockSizeMsg = #13#10#13#10'El tamao anterior del bloque era: '; - CurrentBlockSizeMsg = #13#10#13#10'El tamao del bloque es: '; - StackTraceAtPrevAllocMsg = #13#10#13#10'Traza del stack de cuando este bloque fue previamente reservado (direcciones de retorno):'; - StackTraceAtAllocMsg = #13#10#13#10'Traza del stack de cuando este bloque fue allocated (direcciones de retorno):'; - PreviousObjectClassMsg = #13#10#13#10'El bloque estuvo anteriormente reservado para un objeto de clase: '; - CurrentObjectClassMsg = #13#10#13#10'El bloque est reservado para un objeto de clase: '; - PreviousAllocationGroupMsg = #13#10#13#10'The allocation group was: '; - PreviousAllocationNumberMsg = #13#10#13#10'The allocation number was: '; - CurrentAllocationGroupMsg = #13#10#13#10'The allocation group is: '; - CurrentAllocationNumberMsg = #13#10#13#10'The allocation number is: '; - StackTraceAtFreeMsg = #13#10#13#10'Traza del stack de cuando este bloque fue anteriormente liberado (direcciones de retorno):'; - BlockErrorMsgTitle = 'Detectado Error de Memoria'; - {Virtual Method Called On Freed Object Errors} - StandardVirtualMethodNames: array[1 + vmtParent div 4 .. -1] of PChar = ( - 'SafeCallException', - 'AfterConstruction', - 'BeforeDestruction', - 'Dispatch', - 'DefaultHandler', - 'NewInstance', - 'FreeInstance', - 'Destroy'); - VirtualMethodErrorHeader = - 'FastMM ha detectado un intento de ejecutar un mtodo virtual de un objeto liberado. Una violacin de acceso se generar ahora para abortar la operacin.'; - InterfaceErrorHeader = - 'FastMM ha detectado un intento de utlizacin de una interfaz de un objeto liberado. Una violacin de acceso se generar ahora para abortar la operacin.'; - BlockHeaderCorruptedNoHistoryMsg = - ' Desafortunadamente el encabezamiento de bloque ha sido corrompido as que no hay historia disponible.'; - FreedObjectClassMsg = #13#10#13#10'Clase del objeto liberado: '; - VirtualMethodName = #13#10#13#10'Mtodo virtual: '; - VirtualMethodOffset = 'Desplazamiento +'; - VirtualMethodAddress = #13#10#13#10'Direccin del mtodo virtual: '; - StackTraceAtObjectAllocMsg = - #13#10#13#10 + - 'Traza del stack en el momento que el objeto fue creado (direcciones de retorno):'; - StackTraceAtObjectFreeMsg = - #13#10#13#10 + - 'Traza del stack en el momento que el objeto fue liberado (direcciones de retorno):'; - {Installation Messages} - AlreadyInstalledMsg = 'FastMM4 ya ha sido instalado.'; - AlreadyInstalledTitle = 'Ya Instalado.'; - OtherMMInstalledMsg = - 'FastMM4 no puede instalarse ya que otro manipulador de memoria alternativo se ha instalado anteriormente.'#13#10 + - 'Si desea utilizar FastMM4, por favor asegrese de que FastMM4.pas es la primera unit en la seccin "uses"'#13#10 + - 'del .DPR de su proyecto.'; - OtherMMInstalledTitle = 'FastMM4 no se puede instalar - Otro manipulador de memoria instalado'; - MemoryAllocatedMsg = - 'FastMM4 no puede instalarse ya que se ha reservado memoria mediante el manipulador de memoria estndar.'#13#10 + - 'FastMM4.pas TIENE que ser la primera unit en el fichero .DPR de su proyecto, de otra manera podra reservarse memoria'#13#10 + - 'mediante el manipulador de memoria estndar antes de que FastMM4 pueda ganar el control. '#13#10#13#10 + - 'Si est utilizando un interceptor de excepciones como MadExcept (o cualquier otra herramienta que modifique el orden de inicializacin de las units),'#13#10 + //Fixed by MFM - 'vaya a su pgina de configuracin y asegrese de que FastMM4.pas es inicializada antes que cualquier otra unit.'; - MemoryAllocatedTitle = 'FastMM4 no se puede instalar - Ya se ha reservado memoria'; - {Leak checking messages} - LeakLogHeader = 'Un bloque de memoria ha escapado. El tamao es: '; - LeakMessageHeader = 'Esta aplicacin ha tenido escapes de memoria. '; - SmallLeakDetail = 'Los escapes de bloques pequeos son' -{$ifdef HideExpectedLeaksRegisteredByPointer} - + ' (excluyendo los escapes esperados registrados por apuntador)' -{$endif} - + ':'#13#10; - LargeLeakDetail = 'Los escapes de bloques medianos y grandes son' -{$ifdef HideExpectedLeaksRegisteredByPointer} - + ' (excluyendo los escapes esperados registrados por apuntador)' -{$endif} - + ': '; - BytesMessage = ' bytes: '; - StringBlockMessage = 'String'; - LeakMessageFooter = #13#10 -{$ifndef HideMemoryLeakHintMessage} - + #13#10'Nota: ' - {$ifdef RequireIDEPresenceForLeakReporting} - + 'Este chequeo de escape de memoria slo se realiza si Delphi est ejecutndose en el mismo ordenador. ' - {$endif} - {$ifdef FullDebugMode} - {$ifdef LogMemoryLeakDetailToFile} - + 'Los detalles del escape de memoria se salvan a un fichero texto en la misma carpeta donde reside esta aplicacin. ' - {$else} - + 'Abilite "LogMemoryLeakDetailToFile" para obtener un *log* con los detalles de los escapes de memoria. ' - {$endif} - {$else} - + 'Para obtener un *log* con los detalles de los escapes de memoria, abilite las definiciones condicionales "FullDebugMode" y "LogMemoryLeakDetailToFile". ' - {$endif} - + 'Para desabilitar este chequeo de escapes de memoria, indefina "EnableMemoryLeakReporting".'#13#10 -{$endif} - + #0; - LeakMessageTitle = 'Detectado Escape de Memoria'; -{$ifdef UseOutputDebugString} - FastMMInstallMsg = 'FastMM ha sido instalado.'; - FastMMInstallSharedMsg = 'Compartiendo una instancia existente de FastMM.'; - FastMMUninstallMsg = 'FastMM ha sido desinstalado.'; - FastMMUninstallSharedMsg = 'Cesando de compartir una instancia existente de FastMM.'; -{$endif} -{$ifdef DetectMMOperationsAfterUninstall} - InvalidOperationTitle = 'Operacin en el MM luego de desinstalarlo.'; - InvalidGetMemMsg = 'FastMM ha detectado una llamada a GetMem luego de desinstalar FastMM.'; - InvalidFreeMemMsg = 'FastMM ha detectado una llamada a FreeMem luego de desinstalar FastMM.'; - InvalidReallocMemMsg = 'FastMM ha detectado una llamada a ReallocMem luego de desinstalar FastMM.'; - InvalidAllocMemMsg = 'FastMM ha detectado una llamada a ReallocMem luego de desinstalar FastMM.'; -{$endif} - -implementation - -end. - diff --git a/components/fastmm/Translations/Ukrainian/FastMM4Messages.pas b/components/fastmm/Translations/Ukrainian/FastMM4Messages.pas deleted file mode 100644 index c265b31..0000000 --- a/components/fastmm/Translations/Ukrainian/FastMM4Messages.pas +++ /dev/null @@ -1,139 +0,0 @@ -{ - -Fast Memory Manager: Messages - -2006-07-18 -Ukrainian translation by Andrey V. Shtukaturov. - -} - -unit FastMM4MessagesUKR; - -interface - -{$Include FastMM4Options.inc} - -const - {The name of the debug info support DLL} - FullDebugModeLibraryName = 'FastMM_FullDebugMode.dll'; - {Event log strings} - LogFileExtension = '_MemoryManager_EventLog.txt'#0; - CRLF = #13#10; - EventSeparator = '--------------------------------'; - {Class name messages} - UnknownClassNameMsg = 'Unknown'; - {Stack trace Message} - CurrentStackTraceMsg = #13#10#13#10' (): '; - {Memory dump message} - MemoryDumpMsg = #13#10#13#10' 쒒 256 '; - {Block Error Messages} - BlockScanLogHeader = ' LogAllocatedBlocksToFile. : '; - ErrorMsgHeader = 'FastMM '; - GetMemMsg = 'GetMem'; - FreeMemMsg = 'FreeMem'; - ReallocMemMsg = 'ReallocMem'; - BlockCheckMsg = ' '; - OperationMsg = ' . '; - BlockHeaderCorruptedMsg = ' . '; - BlockFooterCorruptedMsg = ' . '; - FreeModifiedErrorMsg = 'FastMM . '; - DoubleFreeErrorMsg = ' / .'; - PreviousBlockSizeMsg = #13#10#13#10' : '; - CurrentBlockSizeMsg = #13#10#13#10' : '; - StackTraceAtPrevAllocMsg = #13#10#13#10' ():'; - StackTraceAtAllocMsg = #13#10#13#10' ():'; - PreviousObjectClassMsg = #13#10#13#10' ᒒ : '; - CurrentObjectClassMsg = #13#10#13#10' ᒒ : '; - PreviousAllocationGroupMsg = #13#10#13#10' : '; - PreviousAllocationNumberMsg = #13#10#13#10' : '; - CurrentAllocationGroupMsg = #13#10#13#10' : '; - CurrentAllocationNumberMsg = #13#10#13#10' : '; - StackTraceAtFreeMsg = #13#10#13#10' ():'; - BlockErrorMsgTitle = ' 쒒.'; - {Virtual Method Called On Freed Object Errors} - StandardVirtualMethodNames: array[1 + vmtParent div 4 .. -1] of PChar = ( - 'SafeCallException', - 'AfterConstruction', - 'BeforeDestruction', - 'Dispatch', - 'DefaultHandler', - 'NewInstance', - 'FreeInstance', - 'Destroy'); - VirtualMethodErrorHeader = 'FastMM ᒒ. .'; - InterfaceErrorHeader = 'FastMM ᒒ. .'; - BlockHeaderCorruptedNoHistoryMsg = ' .'; - FreedObjectClassMsg = #13#10#13#10' ᒒ: '; - VirtualMethodName = #13#10#13#10'³ : '; - VirtualMethodOffset = ' +'; - VirtualMethodAddress = #13#10#13#10' : '; - StackTraceAtObjectAllocMsg = #13#10#13#10' 쒒 ᒒ ():'; - StackTraceAtObjectFreeMsg = #13#10#13#10' 쒒 ᒒ ():'; - {Installation Messages} - AlreadyInstalledMsg = 'FastMM4 .'; - AlreadyInstalledTitle = ' .'; - OtherMMInstalledMsg = 'FastMM4 쒒.' - + #13#10' FastMM4, - FastMM4.pas ' - + #13#10' "uses" .dpr .'; - OtherMMInstalledTitle = ' FastMM4 - 쒒.'; - MemoryAllocatedMsg = 'FastMM4 쒒 ' - + ' 쒒.'#13#10'FastMM4.pas ' - + ' .dpr , 쒒 ' - + ' '#13#10' 쒒 FastMM4 ' - + ' . '#13#10#13#10' , ' - + ' MadExcept ( - ' - + '),'#13#10' , ' - + 'FastMM4.pas - .'; - MemoryAllocatedTitle = ' FastMM4 - 쒒 '; - {Leak checking messages} - LeakLogHeader = ' 쒒 . : '; - LeakMessageHeader = ' 쒒.'; - SmallLeakDetail = ' '' ' -{$ifdef HideExpectedLeaksRegisteredByPointer} - + ' ( '' )' -{$endif} - + ':'#13#10; - LargeLeakDetail = ' '' ' -{$ifdef HideExpectedLeaksRegisteredByPointer} - + ' ( '' )' -{$endif} - + ': '; - BytesMessage = ' : '; - StringBlockMessage = 'String'; - LeakMessageFooter = #13#10 -{$ifndef HideMemoryLeakHintMessage} - + #13#10'Note: ' - {$ifdef RequireIDEPresenceForLeakReporting} - + ' 쒒 Delphi . ' - {$endif} - {$ifdef FullDebugMode} - {$ifdef LogMemoryLeakDetailToFile} - + ' 쒒 , . ' - {$else} - + ' "LogMemoryLeakDetailToFile" , 쒒. ' - {$endif} - {$else} - + ' , 쒒, "FullDebugMode" "LogMemoryLeakDetailToFile". ' - {$endif} - + ' 쒒, "EnableMemoryLeakReporting".'#13#10 -{$endif} - + #0; - LeakMessageTitle = ' 쒒'; -{$ifdef UseOutputDebugString} - FastMMInstallMsg = 'FastMM has been installed.'; - FastMMInstallSharedMsg = 'Sharing an existing instance of FastMM.'; - FastMMUninstallMsg = 'FastMM has been uninstalled.'; - FastMMUninstallSharedMsg = 'Stopped sharing an existing instance of FastMM.'; -{$endif} -{$ifdef DetectMMOperationsAfterUninstall} - InvalidOperationTitle = 'MM Operation after uninstall.'; - InvalidGetMemMsg = 'FastMM has detected a GetMem call after FastMM was uninstalled.'; - InvalidFreeMemMsg = 'FastMM has detected a FreeMem call after FastMM was uninstalled.'; - InvalidReallocMemMsg = 'FastMM has detected a ReallocMem call after FastMM was uninstalled.'; - InvalidAllocMemMsg = 'FastMM has detected a ReallocMem call after FastMM was uninstalled.'; -{$endif} - -implementation - -end. - diff --git a/components/pascal-parser/JcfMiscFunctions.pas b/components/pascal-parser/JcfMiscFunctions.pas index 4aed62b..84102c8 100644 --- a/components/pascal-parser/JcfMiscFunctions.pas +++ b/components/pascal-parser/JcfMiscFunctions.pas @@ -103,11 +103,15 @@ function Str2Float(s: string): double; var code: integer; begin + {$IF CompilerVersion >= 17} + // de-localise the string if need be + if (FormatSettings.DecimalSeparator <> '.') and (Pos(FormatSettings.DecimalSeparator, s) > 0) then + StrReplace(s, FormatSettings.DecimalSeparator, '.'); + {$ELSE} // de-localise the string if need be if (DecimalSeparator <> '.') and (Pos(DecimalSeparator, s) > 0) then - begin StrReplace(s, DecimalSeparator, '.'); - end; + {$IFEND} Val(s, Result, Code); if code <> 0 then @@ -120,10 +124,15 @@ function Float2Str(const d: double): string; var OrgSep: char; begin - OrgSep := DecimalSeparator; + {$IF CompilerVersion >= 17} + OrgSep := FormatSettings.DecimalSeparator; + Result := FloatToStr(d); + FormatSettings.DecimalSeparator := OrgSep; + {$ELSE} DecimalSeparator := '.'; Result := FloatToStr(d); DecimalSeparator := OrgSep; + {$IFEND} end; diff --git a/components/pascal-parser/SourceTokenList.pas b/components/pascal-parser/SourceTokenList.pas index 52109a9..2479f28 100644 --- a/components/pascal-parser/SourceTokenList.pas +++ b/components/pascal-parser/SourceTokenList.pas @@ -129,7 +129,7 @@ procedure TSourceTokenList.Clear; function TSourceTokenList.GetItem(const piIndex: integer): TSourceToken; begin - Result := TSourceToken(List^[piIndex]); + Result := TSourceToken(List[piIndex]); end; procedure TSourceTokenList.SetItem(const piIndex: integer; const pcObject: TSourceToken); @@ -139,21 +139,21 @@ procedure TSourceTokenList.SetItem(const piIndex: integer; const pcObject: TSour function TSourceTokenList.First: TSourceToken; begin - Result := TSourceToken(List^[fiCurrentTokenIndex]); + Result := TSourceToken(List[fiCurrentTokenIndex]); end; function TSourceTokenList.FirstTokenType: TTokenType; begin Result := ttUnknown; if Count > 0 then - Result := TSourceToken(List^[fiCurrentTokenIndex]).TokenType; + Result := TSourceToken(List[fiCurrentTokenIndex]).TokenType; end; function TSourceTokenList.FirstWordType: TWordType; begin Result := wtNotAWord; if Count > 0 then - Result := TSourceToken(List^[fiCurrentTokenIndex]).WordType; + Result := TSourceToken(List[fiCurrentTokenIndex]).WordType; end; function TSourceTokenList.FirstTokenLength: integer; @@ -206,7 +206,7 @@ function TSourceTokenList.FirstTokenWithExclusion( liLoop := fiCurrentTokenIndex; while liLoop < Count do begin - lcItem := TSourceToken(List^[liLoop]); + lcItem := TSourceToken(List[liLoop]); if not (lcItem.TokenType in AExclusions) then begin Result := lcItem; @@ -237,7 +237,7 @@ function TSourceTokenList.SolidToken(piIndex: integer): TSourceToken; while liLoop < Count do begin - lcTestToken := TSourceToken(List^[liLoop]); + lcTestToken := TSourceToken(List[liLoop]); if (lcTestToken <> nil) and lcTestToken.IsSolid then begin // found a solid token. @@ -285,7 +285,7 @@ procedure TSourceTokenList.SetXYPositions; liLoop := fiCurrentTokenIndex; while liLoop < Count do begin - lcToken := TSourceToken(List^[liLoop]); + lcToken := TSourceToken(List[liLoop]); lcToken.XPosition := liX; lcToken.YPosition := liY; AdvanceTextPos(lcToken.SourceCode, liX, liY); @@ -299,8 +299,8 @@ function TSourceTokenList.Extract: TSourceToken; Here I am not doing any index checking at all. This thing needs to be FAST. Access to here is quite controlled anyway.} - Result := TSourceToken(List^[fiCurrentTokenIndex]); - List^[fiCurrentTokenIndex] := nil; + Result := TSourceToken(List[fiCurrentTokenIndex]); + List[fiCurrentTokenIndex] := nil; inc(fiCurrentTokenIndex); end; diff --git a/core/IncludeParser.pas b/core/IncludeParser.pas index 23beac6..1636620 100644 --- a/core/IncludeParser.pas +++ b/core/IncludeParser.pas @@ -108,5 +108,4 @@ procedure TIncludeParser.ParseIncludes(Source: TStrings); end; end; -end. - +end. \ No newline at end of file diff --git a/core/ProjectUnitsRegistratorVisitor.pas b/core/ProjectUnitsRegistratorVisitor.pas index 9d09f69..dedc388 100644 --- a/core/ProjectUnitsRegistratorVisitor.pas +++ b/core/ProjectUnitsRegistratorVisitor.pas @@ -51,5 +51,4 @@ procedure TProjectUnitsRegistratorVisitor.Visit(Node: TParseTreeNode); end; end; -end. - +end. \ No newline at end of file diff --git a/core/SourceTreeDumperVisitor.pas b/core/SourceTreeDumperVisitor.pas index 2174de3..c5d0784 100644 --- a/core/SourceTreeDumperVisitor.pas +++ b/core/SourceTreeDumperVisitor.pas @@ -45,5 +45,4 @@ procedure TSourceTreeDumperVisitor.Visit(Node: TParseTreeNode); Output.Add(DupeString(' ', GetNodeDepth(Node)) + Node.Describe); end; -end. - +end. \ No newline at end of file diff --git a/core/SourceTreeWalker.pas b/core/SourceTreeWalker.pas index 02d933c..b29337b 100644 --- a/core/SourceTreeWalker.pas +++ b/core/SourceTreeWalker.pas @@ -62,8 +62,4 @@ procedure TSourceTreeWalker.Walk(Root: TParseTreeNode; Visitor: INodeVisitor); end; end; -end. - - - - +end. \ No newline at end of file diff --git a/core/UnitRegistry.pas b/core/UnitRegistry.pas index 63c7c0b..ceebc5a 100644 --- a/core/UnitRegistry.pas +++ b/core/UnitRegistry.pas @@ -218,7 +218,4 @@ initialization finalization TUnitRegistry.Shutdown; -end. - - - +end. \ No newline at end of file diff --git a/cui/Options.pas b/cui/Options.pas index f6d2453..dd1ef74 100644 --- a/cui/Options.pas +++ b/cui/Options.pas @@ -170,9 +170,8 @@ procedure TOptions.WriteProgramHeader; end; procedure TOptions.WriteProgramVersion; -{$I revision.inc} begin - Writeln('version 1.0 (r', REVISION, ')'); + Writeln('version 1.0'); Writeln; end; diff --git a/delcos.dpr b/delcos.dpr index aaf9e8f..f1eebe6 100644 --- a/delcos.dpr +++ b/delcos.dpr @@ -117,7 +117,4 @@ begin end; end; end; -end. - - - +end. \ No newline at end of file diff --git a/submodules/FastMM4 b/submodules/FastMM4 new file mode 160000 index 0000000..3e0b924 --- /dev/null +++ b/submodules/FastMM4 @@ -0,0 +1 @@ +Subproject commit 3e0b924d4b1c07ac91817f42567dfa24f2510c2b